From e7d21ee4f8ac907665a7e170c71d59e13a01da09 Mon Sep 17 00:00:00 2001 From: partain Date: Mon, 8 Jan 1996 20:28:12 +0000 Subject: [PATCH] [project @ 1996-01-08 20:28:12 by partain] Initial revision --- ANNOUNCE-0.26 | 153 + Makefile.config | 23 + Makefile.in | 36 + README | 20 + STARTUP.in | 116 + config.guess | 536 ++ config.sub | 866 ++++ configure.in | 1916 +++++++ ghc/.gdbinit | 125 + ghc/CONTRIB/README | 17 + ghc/CONTRIB/fptags | 53 + ghc/CONTRIB/haskel.gif | Bin 0 -> 5380 bytes ghc/CONTRIB/haskell.el | 185 + ghc/CONTRIB/haskell_poem | 58 + ghc/CONTRIB/mira2hs | 364 ++ ghc/CONTRIB/pphs/Jmakefile | 16 + ghc/CONTRIB/pphs/README | 18 + ghc/CONTRIB/pphs/docs/Code.tex | 53 + ghc/CONTRIB/pphs/docs/Error_Messages.tex | 36 + ghc/CONTRIB/pphs/docs/External_Specification.tex | 117 + ghc/CONTRIB/pphs/docs/Faults.tex | 66 + ghc/CONTRIB/pphs/docs/Future_Work.tex | 30 + ghc/CONTRIB/pphs/docs/Haskell_char.tex | 7 + ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex | 12 + ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex | 4 + ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex | 7 + ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex | 9 + ghc/CONTRIB/pphs/docs/Haskell_math.tex | 5 + ghc/CONTRIB/pphs/docs/Haskell_simple.tex | 5 + ghc/CONTRIB/pphs/docs/Haskell_string1.tex | 8 + ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex | 7 + ghc/CONTRIB/pphs/docs/How.tex | 465 ++ ghc/CONTRIB/pphs/docs/Introduction.tex | 137 + ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex | 12 + ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex | 6 + ghc/CONTRIB/pphs/docs/LaTeX_char.tex | 9 + ghc/CONTRIB/pphs/docs/LaTeX_comment.tex | 3 + ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex | 13 + ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex | 8 + ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex | 8 + ghc/CONTRIB/pphs/docs/LaTeX_math.tex | 7 + ghc/CONTRIB/pphs/docs/LaTeX_simple.tex | 5 + ghc/CONTRIB/pphs/docs/LaTeX_string1.tex | 10 + ghc/CONTRIB/pphs/docs/LaTeX_string2.tex | 10 + ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex | 9 + ghc/CONTRIB/pphs/docs/Problem_Definition.tex | 37 + ghc/CONTRIB/pphs/docs/Project_Documents.tex | 7 + ghc/CONTRIB/pphs/docs/Report.tex | 49 + .../pphs/docs/Statement_Of_Requirements.tex | 32 + ghc/CONTRIB/pphs/docs/UserGuide.tex | 9 + ghc/CONTRIB/pphs/docs/UserGuide_Text.tex | 231 + ghc/CONTRIB/pphs/docs/User_Documents.tex | 5 + ghc/CONTRIB/pphs/docs/Uses.tex | 262 + ghc/CONTRIB/pphs/docs/What.tex | 136 + ghc/CONTRIB/pphs/docs/Wrapper.tex | 6 + ghc/CONTRIB/pphs/docs/char.hs | 5 + ghc/CONTRIB/pphs/docs/comment.hs | 1 + ghc/CONTRIB/pphs/docs/internalalign1.hs | 9 + ghc/CONTRIB/pphs/docs/leftindent1.hs | 4 + ghc/CONTRIB/pphs/docs/leftindent2.hs | 6 + ghc/CONTRIB/pphs/docs/math.hs | 3 + ghc/CONTRIB/pphs/docs/pphs.sty | 26 + ghc/CONTRIB/pphs/docs/rep.sty | 80 + ghc/CONTRIB/pphs/docs/simple.hs | 3 + ghc/CONTRIB/pphs/docs/string1.hs | 6 + ghc/CONTRIB/pphs/docs/string2.hs | 8 + ghc/CONTRIB/pphs/pphs.c | 1030 ++++ ghc/Jmakefile | 47 + ghc/Makefile.BOOT | 59 + ghc/PATCHLEVEL | 1 + ghc/README | 78 + ghc/compiler/HsVersions.h | 178 + ghc/compiler/Jmakefile | 1355 +++++ ghc/compiler/README | 45 + ghc/compiler/absCSyn/AbsCFuns.hi | 41 + ghc/compiler/absCSyn/AbsCFuns.lhs | 864 ++++ ghc/compiler/absCSyn/AbsCSyn.hi | 333 ++ ghc/compiler/absCSyn/AbsCSyn.lhs | 689 +++ ghc/compiler/absCSyn/Costs.hi | 32 + ghc/compiler/absCSyn/Costs.lhs | 628 +++ ghc/compiler/absCSyn/HeapOffs.hi | 38 + ghc/compiler/absCSyn/HeapOffs.lhs | 402 ++ ghc/compiler/absCSyn/PprAbsC.hi | 27 + ghc/compiler/absCSyn/PprAbsC.lhs | 1447 ++++++ ghc/compiler/abstractSyn/AbsSyn.hi | 798 +++ ghc/compiler/abstractSyn/AbsSyn.lhs | 301 ++ ghc/compiler/abstractSyn/AbsSynFuns.hi | 51 + ghc/compiler/abstractSyn/AbsSynFuns.lhs | 563 +++ ghc/compiler/abstractSyn/HsBinds.hi | 51 + ghc/compiler/abstractSyn/HsBinds.lhs | 329 ++ ghc/compiler/abstractSyn/HsCore.hi | 27 + ghc/compiler/abstractSyn/HsCore.lhs | 353 ++ ghc/compiler/abstractSyn/HsDecls.hi | 54 + ghc/compiler/abstractSyn/HsDecls.lhs | 299 ++ ghc/compiler/abstractSyn/HsExpr.hi | 38 + ghc/compiler/abstractSyn/HsExpr.lhs | 506 ++ ghc/compiler/abstractSyn/HsImpExp.hi | 42 + ghc/compiler/abstractSyn/HsImpExp.lhs | 226 + ghc/compiler/abstractSyn/HsLit.hi | 13 + ghc/compiler/abstractSyn/HsLit.lhs | 76 + ghc/compiler/abstractSyn/HsMatches.hi | 39 + ghc/compiler/abstractSyn/HsMatches.lhs | 215 + ghc/compiler/abstractSyn/HsPat.hi | 58 + ghc/compiler/abstractSyn/HsPat.lhs | 352 ++ ghc/compiler/abstractSyn/HsPragmas.hi | 41 + ghc/compiler/abstractSyn/HsPragmas.lhs | 200 + ghc/compiler/abstractSyn/HsTypes.hi | 33 + ghc/compiler/abstractSyn/HsTypes.lhs | 273 + ghc/compiler/abstractSyn/Name.hi | 66 + ghc/compiler/abstractSyn/Name.lhs | 318 ++ ghc/compiler/basicTypes/BasicLit.hi | 45 + ghc/compiler/basicTypes/BasicLit.lhs | 197 + ghc/compiler/basicTypes/CLabelInfo.hi | 99 + ghc/compiler/basicTypes/CLabelInfo.lhs | 650 +++ ghc/compiler/basicTypes/Id.hi | 266 + ghc/compiler/basicTypes/Id.lhs | 2264 +++++++++ ghc/compiler/basicTypes/IdInfo.hi | 284 ++ ghc/compiler/basicTypes/IdInfo.lhs | 1172 +++++ ghc/compiler/basicTypes/Inst.hi | 89 + ghc/compiler/basicTypes/Inst.lhs | 391 ++ ghc/compiler/basicTypes/Jmakefile | 12 + ghc/compiler/basicTypes/NameTypes.hi | 59 + ghc/compiler/basicTypes/NameTypes.lhs | 318 ++ ghc/compiler/basicTypes/OrdList.hi | 14 + ghc/compiler/basicTypes/OrdList.lhs | 236 + ghc/compiler/basicTypes/ProtoName.hi | 45 + ghc/compiler/basicTypes/ProtoName.lhs | 256 + ghc/compiler/basicTypes/SplitUniq.hi | 31 + ghc/compiler/basicTypes/SplitUniq.lhs | 305 ++ ghc/compiler/basicTypes/SrcLoc.hi | 21 + ghc/compiler/basicTypes/SrcLoc.lhs | 84 + ghc/compiler/basicTypes/Unique.hi | 335 ++ ghc/compiler/basicTypes/Unique.lhs | 866 ++++ ghc/compiler/basicTypes/basicTypes.lit | 36 + ghc/compiler/codeGen/CgBindery.hi | 88 + ghc/compiler/codeGen/CgBindery.lhs | 416 ++ ghc/compiler/codeGen/CgCase.hi | 25 + ghc/compiler/codeGen/CgCase.lhs | 1107 ++++ ghc/compiler/codeGen/CgClosure.hi | 32 + ghc/compiler/codeGen/CgClosure.lhs | 1014 ++++ ghc/compiler/codeGen/CgCompInfo.hi | 94 + ghc/compiler/codeGen/CgCompInfo.lhs | 189 + ghc/compiler/codeGen/CgCon.hi | 35 + ghc/compiler/codeGen/CgCon.lhs | 515 ++ ghc/compiler/codeGen/CgConTbls.hi | 24 + ghc/compiler/codeGen/CgConTbls.lhs | 430 ++ ghc/compiler/codeGen/CgExpr.hi | 24 + ghc/compiler/codeGen/CgExpr.lhs | 414 ++ ghc/compiler/codeGen/CgHeapery.hi | 33 + ghc/compiler/codeGen/CgHeapery.lhs | 278 + ghc/compiler/codeGen/CgLetNoEscape.hi | 12 + ghc/compiler/codeGen/CgLetNoEscape.lhs | 202 + ghc/compiler/codeGen/CgMonad.hi | 209 + ghc/compiler/codeGen/CgMonad.lhs | 914 ++++ ghc/compiler/codeGen/CgRetConv.hi | 39 + ghc/compiler/codeGen/CgRetConv.lhs | 436 ++ ghc/compiler/codeGen/CgStackery.hi | 35 + ghc/compiler/codeGen/CgStackery.lhs | 264 + ghc/compiler/codeGen/CgTailCall.hi | 44 + ghc/compiler/codeGen/CgTailCall.lhs | 548 ++ ghc/compiler/codeGen/CgUpdate.hi | 7 + ghc/compiler/codeGen/CgUpdate.lhs | 155 + ghc/compiler/codeGen/CgUsages.hi | 39 + ghc/compiler/codeGen/CgUsages.lhs | 152 + ghc/compiler/codeGen/ClosureInfo.hi | 169 + ghc/compiler/codeGen/ClosureInfo.lhs | 1328 +++++ ghc/compiler/codeGen/CodeGen.hi | 27 + ghc/compiler/codeGen/CodeGen.lhs | 177 + ghc/compiler/codeGen/Jmakefile | 19 + ghc/compiler/codeGen/SMRep.hi | 37 + ghc/compiler/codeGen/SMRep.lhs | 208 + ghc/compiler/codeGen/cgintro.lit | 783 +++ ghc/compiler/coreSyn/AnnCoreSyn.hi | 127 + ghc/compiler/coreSyn/AnnCoreSyn.lhs | 185 + ghc/compiler/coreSyn/CoreFuns.hi | 102 + ghc/compiler/coreSyn/CoreFuns.lhs | 1307 +++++ ghc/compiler/coreSyn/CoreLift.hi | 31 + ghc/compiler/coreSyn/CoreLift.lhs | 316 ++ ghc/compiler/coreSyn/CoreLint.hi | 20 + ghc/compiler/coreSyn/CoreLint.lhs | 651 +++ ghc/compiler/coreSyn/CoreSyn.hi | 63 + ghc/compiler/coreSyn/CoreSyn.lhs | 738 +++ ghc/compiler/coreSyn/CoreUnfold.hi | 15 + ghc/compiler/coreSyn/CoreUnfold.lhs | 569 +++ ghc/compiler/coreSyn/FreeVars.hi | 41 + ghc/compiler/coreSyn/FreeVars.lhs | 609 +++ ghc/compiler/coreSyn/Jmakefile | 11 + ghc/compiler/coreSyn/PlainCore.hi | 357 ++ ghc/compiler/coreSyn/PlainCore.lhs | 185 + ghc/compiler/coreSyn/TaggedCore.hi | 130 + ghc/compiler/coreSyn/TaggedCore.lhs | 93 + ghc/compiler/coreSyn/root.lit | 41 + ghc/compiler/count_bytes | 43 + ghc/compiler/count_lines | 62 + ghc/compiler/deSugar/Desugar.hi | 36 + ghc/compiler/deSugar/Desugar.lhs | 96 + ghc/compiler/deSugar/DsBinds.hi | 21 + ghc/compiler/deSugar/DsBinds.lhs | 612 +++ ghc/compiler/deSugar/DsCCall.hi | 15 + ghc/compiler/deSugar/DsCCall.lhs | 295 ++ ghc/compiler/deSugar/DsExpr.hi | 16 + ghc/compiler/deSugar/DsExpr.lhs | 514 ++ ghc/compiler/deSugar/DsGRHSs.hi | 20 + ghc/compiler/deSugar/DsGRHSs.lhs | 104 + ghc/compiler/deSugar/DsListComp.hi | 16 + ghc/compiler/deSugar/DsListComp.lhs | 234 + ghc/compiler/deSugar/DsMonad.hi | 118 + ghc/compiler/deSugar/DsMonad.lhs | 309 ++ ghc/compiler/deSugar/DsParZF.lhs | 233 + ghc/compiler/deSugar/DsUtils.hi | 50 + ghc/compiler/deSugar/DsUtils.lhs | 556 ++ ghc/compiler/deSugar/Jmakefile | 11 + ghc/compiler/deSugar/Match.hi | 22 + ghc/compiler/deSugar/Match.lhs | 712 +++ ghc/compiler/deSugar/MatchCon.hi | 15 + ghc/compiler/deSugar/MatchCon.lhs | 150 + ghc/compiler/deSugar/MatchLit.hi | 15 + ghc/compiler/deSugar/MatchLit.lhs | 205 + ghc/compiler/deSugar/MatchProc.lhs | 98 + ghc/compiler/deSugar/intro.lit | 24 + ghc/compiler/deSugar/root.lit | 53 + ghc/compiler/deforest/Core2Def.hi | 22 + ghc/compiler/deforest/Core2Def.lhs | 147 + ghc/compiler/deforest/Cyclic.hi | 11 + ghc/compiler/deforest/Cyclic.lhs | 411 ++ ghc/compiler/deforest/Def2Core.hi | 23 + ghc/compiler/deforest/Def2Core.lhs | 156 + ghc/compiler/deforest/DefExpr.hi | 12 + ghc/compiler/deforest/DefExpr.lhs | 657 +++ ghc/compiler/deforest/DefSyn.hi | 15 + ghc/compiler/deforest/DefSyn.lhs | 59 + ghc/compiler/deforest/DefUtils.hi | 44 + ghc/compiler/deforest/DefUtils.lhs | 622 +++ ghc/compiler/deforest/Deforest.hi | 9 + ghc/compiler/deforest/Deforest.lhs | 140 + ghc/compiler/deforest/TreelessForm.hi | 10 + ghc/compiler/deforest/TreelessForm.lhs | 189 + ghc/compiler/envs/CE.hi | 51 + ghc/compiler/envs/CE.lhs | 90 + ghc/compiler/envs/E.hi | 65 + ghc/compiler/envs/E.lhs | 268 + ghc/compiler/envs/IdEnv.hi | 73 + ghc/compiler/envs/IdEnv.lhs | 113 + ghc/compiler/envs/InstEnv.hi | 59 + ghc/compiler/envs/InstEnv.lhs | 549 ++ ghc/compiler/envs/LIE.hi | 20 + ghc/compiler/envs/LIE.lhs | 44 + ghc/compiler/envs/TCE.hi | 50 + ghc/compiler/envs/TCE.lhs | 110 + ghc/compiler/envs/TVE.hi | 42 + ghc/compiler/envs/TVE.lhs | 74 + ghc/compiler/envs/TyVarEnv.hi | 54 + ghc/compiler/envs/TyVarEnv.lhs | 71 + ghc/compiler/main/CmdLineOpts.hi | 48 + ghc/compiler/main/CmdLineOpts.lhs | 969 ++++ ghc/compiler/main/ErrUtils.hi | 15 + ghc/compiler/main/ErrUtils.lhs | 61 + ghc/compiler/main/Errors.hi | 173 + ghc/compiler/main/Errors.lhs | 122 + ghc/compiler/main/ErrsRn.hi | 42 + ghc/compiler/main/ErrsRn.lhs | 194 + ghc/compiler/main/ErrsTc.hi | 82 + ghc/compiler/main/ErrsTc.lhs | 935 ++++ ghc/compiler/main/Main.hi | 5 + ghc/compiler/main/Main.lhs | 510 ++ ghc/compiler/main/MainMonad.hi | 52 + ghc/compiler/main/MainMonad.lhs | 258 + ghc/compiler/main/MkIface.hi | 43 + ghc/compiler/main/MkIface.lhs | 607 +++ ghc/compiler/nativeGen/AbsCStixGen.hi | 28 + ghc/compiler/nativeGen/AbsCStixGen.lhs | 616 +++ ghc/compiler/nativeGen/AlphaCode.hi | 86 + ghc/compiler/nativeGen/AlphaCode.lhs | 1413 ++++++ ghc/compiler/nativeGen/AlphaDesc.hi | 24 + ghc/compiler/nativeGen/AlphaDesc.lhs | 206 + ghc/compiler/nativeGen/AlphaGen.hi | 18 + ghc/compiler/nativeGen/AlphaGen.lhs | 1120 ++++ ghc/compiler/nativeGen/AsmCodeGen.hi | 24 + ghc/compiler/nativeGen/AsmCodeGen.lhs | 454 ++ ghc/compiler/nativeGen/AsmRegAlloc.hi | 94 + ghc/compiler/nativeGen/AsmRegAlloc.lhs | 498 ++ ghc/compiler/nativeGen/Jmakefile | 22 + ghc/compiler/nativeGen/MachDesc.hi | 95 + ghc/compiler/nativeGen/MachDesc.lhs | 113 + ghc/compiler/nativeGen/SparcCode.hi | 85 + ghc/compiler/nativeGen/SparcCode.lhs | 1398 +++++ ghc/compiler/nativeGen/SparcDesc.hi | 24 + ghc/compiler/nativeGen/SparcDesc.lhs | 199 + ghc/compiler/nativeGen/SparcGen.hi | 18 + ghc/compiler/nativeGen/SparcGen.lhs | 1304 +++++ ghc/compiler/nativeGen/Stix.hi | 63 + ghc/compiler/nativeGen/Stix.lhs | 175 + ghc/compiler/nativeGen/StixInfo.hi | 9 + ghc/compiler/nativeGen/StixInfo.lhs | 142 + ghc/compiler/nativeGen/StixInteger.hi | 27 + ghc/compiler/nativeGen/StixInteger.lhs | 376 ++ ghc/compiler/nativeGen/StixMacro.hi | 32 + ghc/compiler/nativeGen/StixMacro.lhs | 381 ++ ghc/compiler/nativeGen/StixPrim.hi | 33 + ghc/compiler/nativeGen/StixPrim.lhs | 599 +++ ghc/compiler/nativeGen/root.lit | 60 + ghc/compiler/prelude/AbsPrel.hi | 365 ++ ghc/compiler/prelude/AbsPrel.lhs | 611 +++ ghc/compiler/prelude/Jmakefile | 19 + ghc/compiler/prelude/Makefile-fig | 18 + ghc/compiler/prelude/PrelFuns.hi | 230 + ghc/compiler/prelude/PrelFuns.lhs | 239 + ghc/compiler/prelude/PrelVals.hi | 61 + ghc/compiler/prelude/PrelVals.lhs | 652 +++ ghc/compiler/prelude/PrimKind.hi | 50 + ghc/compiler/prelude/PrimKind.lhs | 279 + ghc/compiler/prelude/PrimOps.hi | 65 + ghc/compiler/prelude/PrimOps.lhs | 1663 ++++++ ghc/compiler/prelude/TyPod.lhs | 159 + ghc/compiler/prelude/TyProcs.lhs | 26 + ghc/compiler/prelude/TysPrim.hi | 67 + ghc/compiler/prelude/TysPrim.lhs | 162 + ghc/compiler/prelude/TysWiredIn.hi | 146 + ghc/compiler/prelude/TysWiredIn.lhs | 757 +++ ghc/compiler/prelude/prelude-structure.fig | 67 + ghc/compiler/prelude/prelude-structure.tex | 7 + ghc/compiler/prelude/prelude.lit | 420 ++ ghc/compiler/profiling/CostCentre.hi | 76 + ghc/compiler/profiling/CostCentre.lhs | 503 ++ ghc/compiler/profiling/NOTES | 301 ++ ghc/compiler/profiling/SCCauto.hi | 9 + ghc/compiler/profiling/SCCauto.lhs | 80 + ghc/compiler/profiling/SCCfinal.hi | 11 + ghc/compiler/profiling/SCCfinal.lhs | 445 ++ ghc/compiler/reader/Jmakefile | 18 + ghc/compiler/reader/PrefixSyn.hi | 23 + ghc/compiler/reader/PrefixSyn.lhs | 121 + ghc/compiler/reader/PrefixToHs.hi | 33 + ghc/compiler/reader/PrefixToHs.lhs | 366 ++ ghc/compiler/reader/ReadPragmas.hi | 46 + ghc/compiler/reader/ReadPragmas.lhs | 607 +++ ghc/compiler/reader/ReadPragmas2.hi | 21 + ghc/compiler/reader/ReadPragmas2.lhs | 595 +++ ghc/compiler/reader/ReadPrefix.hi | 23 + ghc/compiler/reader/ReadPrefix.lhs | 996 ++++ ghc/compiler/reader/ReadPrefix2.hi | 19 + ghc/compiler/reader/ReadPrefix2.lhs | 856 ++++ ghc/compiler/reader/reader.lit | 30 + ghc/compiler/rename/Rename.hi | 46 + ghc/compiler/rename/Rename.lhs | 145 + ghc/compiler/rename/Rename1.hi | 37 + ghc/compiler/rename/Rename1.lhs | 894 ++++ ghc/compiler/rename/Rename2.hi | 27 + ghc/compiler/rename/Rename2.lhs | 816 +++ ghc/compiler/rename/Rename3.hi | 46 + ghc/compiler/rename/Rename3.lhs | 559 ++ ghc/compiler/rename/Rename4.hi | 55 + ghc/compiler/rename/Rename4.lhs | 829 +++ ghc/compiler/rename/RenameAuxFuns.hi | 19 + ghc/compiler/rename/RenameAuxFuns.lhs | 132 + ghc/compiler/rename/RenameBinds4.hi | 54 + ghc/compiler/rename/RenameBinds4.lhs | 652 +++ ghc/compiler/rename/RenameExpr4.hi | 47 + ghc/compiler/rename/RenameExpr4.lhs | 431 ++ ghc/compiler/rename/RenameMonad12.hi | 32 + ghc/compiler/rename/RenameMonad12.lhs | 98 + ghc/compiler/rename/RenameMonad3.hi | 42 + ghc/compiler/rename/RenameMonad3.lhs | 200 + ghc/compiler/rename/RenameMonad4.hi | 110 + ghc/compiler/rename/RenameMonad4.lhs | 480 ++ ghc/compiler/root.lit | 115 + ghc/compiler/simplCore/AnalFBWW.hi | 8 + ghc/compiler/simplCore/AnalFBWW.lhs | 253 + ghc/compiler/simplCore/BinderInfo.hi | 39 + ghc/compiler/simplCore/BinderInfo.lhs | 238 + ghc/compiler/simplCore/ConFold.hi | 12 + ghc/compiler/simplCore/ConFold.lhs | 321 ++ ghc/compiler/simplCore/FloatIn.hi | 20 + ghc/compiler/simplCore/FloatIn.lhs | 390 ++ ghc/compiler/simplCore/FloatOut.hi | 9 + ghc/compiler/simplCore/FloatOut.lhs | 427 ++ ghc/compiler/simplCore/FoldrBuildWW.hi | 9 + ghc/compiler/simplCore/FoldrBuildWW.lhs | 181 + ghc/compiler/simplCore/LiberateCase.hi | 7 + ghc/compiler/simplCore/LiberateCase.lhs | 336 ++ ghc/compiler/simplCore/MagicUFs.hi | 41 + ghc/compiler/simplCore/MagicUFs.lhs | 525 ++ ghc/compiler/simplCore/NewOccurAnal.hi | 31 + ghc/compiler/simplCore/NewOccurAnal.lhs | 720 +++ ghc/compiler/simplCore/OccurAnal.hi | 33 + ghc/compiler/simplCore/OccurAnal.lhs | 546 ++ ghc/compiler/simplCore/SAT.hi | 20 + ghc/compiler/simplCore/SAT.lhs | 215 + ghc/compiler/simplCore/SATMonad.hi | 55 + ghc/compiler/simplCore/SATMonad.lhs | 259 + ghc/compiler/simplCore/SetLevels.hi | 24 + ghc/compiler/simplCore/SetLevels.lhs | 789 +++ ghc/compiler/simplCore/SimplCase.hi | 14 + ghc/compiler/simplCore/SimplCase.lhs | 941 ++++ ghc/compiler/simplCore/SimplCore.hi | 30 + ghc/compiler/simplCore/SimplCore.lhs | 602 +++ ghc/compiler/simplCore/SimplEnv.hi | 163 + ghc/compiler/simplCore/SimplEnv.lhs | 1056 ++++ ghc/compiler/simplCore/SimplHaskell.lhs | 249 + ghc/compiler/simplCore/SimplMonad.hi | 95 + ghc/compiler/simplCore/SimplMonad.lhs | 330 ++ ghc/compiler/simplCore/SimplPgm.hi | 10 + ghc/compiler/simplCore/SimplPgm.lhs | 256 + ghc/compiler/simplCore/SimplUtils.hi | 25 + ghc/compiler/simplCore/SimplUtils.lhs | 456 ++ ghc/compiler/simplCore/SimplVar.hi | 13 + ghc/compiler/simplCore/SimplVar.lhs | 317 ++ ghc/compiler/simplCore/Simplify.hi | 16 + ghc/compiler/simplCore/Simplify.lhs | 1222 +++++ ghc/compiler/simplCore/simplifier.tib | 771 +++ ghc/compiler/simplStg/LambdaLift.hi | 8 + ghc/compiler/simplStg/LambdaLift.lhs | 527 ++ ghc/compiler/simplStg/SatStgRhs.hi | 8 + ghc/compiler/simplStg/SatStgRhs.lhs | 307 ++ ghc/compiler/simplStg/SimplStg.hi | 12 + ghc/compiler/simplStg/SimplStg.lhs | 354 ++ ghc/compiler/simplStg/StgSAT.hi | 18 + ghc/compiler/simplStg/StgSAT.lhs | 186 + ghc/compiler/simplStg/StgSATMonad.hi | 22 + ghc/compiler/simplStg/StgSATMonad.lhs | 182 + ghc/compiler/simplStg/StgStats.hi | 7 + ghc/compiler/simplStg/StgStats.lhs | 188 + ghc/compiler/simplStg/StgVarInfo.hi | 7 + ghc/compiler/simplStg/StgVarInfo.lhs | 790 +++ ghc/compiler/simplStg/UpdAnal.hi | 7 + ghc/compiler/simplStg/UpdAnal.lhs | 510 ++ ghc/compiler/specialise/SpecTyFuns.hi | 29 + ghc/compiler/specialise/SpecTyFuns.lhs | 293 ++ ghc/compiler/specialise/Specialise.hi | 19 + ghc/compiler/specialise/Specialise.lhs | 2535 ++++++++++ ghc/compiler/stgSyn/CoreToStg.hi | 23 + ghc/compiler/stgSyn/CoreToStg.lhs | 698 +++ ghc/compiler/stgSyn/Jmakefile | 5 + ghc/compiler/stgSyn/StgFuns.hi | 7 + ghc/compiler/stgSyn/StgFuns.lhs | 93 + ghc/compiler/stgSyn/StgLint.hi | 16 + ghc/compiler/stgSyn/StgLint.lhs | 541 ++ ghc/compiler/stgSyn/StgSyn.hi | 443 ++ ghc/compiler/stgSyn/StgSyn.lhs | 882 ++++ ghc/compiler/stgSyn/root.lit | 9 + ghc/compiler/stranal/SaAbsInt.hi | 20 + ghc/compiler/stranal/SaAbsInt.lhs | 1043 ++++ ghc/compiler/stranal/SaLib.hi | 48 + ghc/compiler/stranal/SaLib.lhs | 122 + ghc/compiler/stranal/StrictAnal.hi | 11 + ghc/compiler/stranal/StrictAnal.lhs | 502 ++ ghc/compiler/stranal/WorkWrap.hi | 9 + ghc/compiler/stranal/WorkWrap.lhs | 254 + ghc/compiler/stranal/WwLib.hi | 56 + ghc/compiler/stranal/WwLib.lhs | 470 ++ ghc/compiler/tests/Jmakefile | 11 + ghc/compiler/tests/README | 77 + ghc/compiler/tests/TIMING/HelpMicroPrel.hi | 378 ++ ghc/compiler/tests/ccall/Jmakefile | 21 + ghc/compiler/tests/ccall/cc001.hs | 25 + ghc/compiler/tests/ccall/cc001.stderr | 188 + ghc/compiler/tests/ccall/cc002.hs | 21 + ghc/compiler/tests/ccall/cc002.stderr | 140 + ghc/compiler/tests/ccall/cc003.hs | 8 + ghc/compiler/tests/ccall/cc003.stderr | 15 + ghc/compiler/tests/ccall/cc004.hs | 29 + ghc/compiler/tests/deSugar/Jmakefile | 54 + .../tests/deSugar/cvh-ds-unboxed/Jmakefile | 3 + .../tests/deSugar/cvh-ds-unboxed/Life2.lhs | 39 + ghc/compiler/tests/deSugar/cvh-ds-unboxed/UCopy.hi | 9 + .../tests/deSugar/cvh-ds-unboxed/UTypes.hi | 7 + ghc/compiler/tests/deSugar/ds-wildcard.hs | 3 + ghc/compiler/tests/deSugar/ds001.hs | 25 + ghc/compiler/tests/deSugar/ds001.stderr | 23 + ghc/compiler/tests/deSugar/ds002.hs | 16 + ghc/compiler/tests/deSugar/ds002.stderr | 12 + ghc/compiler/tests/deSugar/ds003.hs | 8 + ghc/compiler/tests/deSugar/ds003.stderr | 61 + ghc/compiler/tests/deSugar/ds004.hs | 9 + ghc/compiler/tests/deSugar/ds004.stderr | 31 + ghc/compiler/tests/deSugar/ds005.hs | 15 + ghc/compiler/tests/deSugar/ds005.stderr | 65 + ghc/compiler/tests/deSugar/ds006.hs | 6 + ghc/compiler/tests/deSugar/ds006.stderr | 19 + ghc/compiler/tests/deSugar/ds007.hs | 6 + ghc/compiler/tests/deSugar/ds007.stderr | 7 + ghc/compiler/tests/deSugar/ds008.hs | 11 + ghc/compiler/tests/deSugar/ds008.stderr | 21 + ghc/compiler/tests/deSugar/ds009.hs | 13 + ghc/compiler/tests/deSugar/ds009.stderr | 150 + ghc/compiler/tests/deSugar/ds010.hs | 15 + ghc/compiler/tests/deSugar/ds010.stderr | 228 + ghc/compiler/tests/deSugar/ds011.hs | 11 + ghc/compiler/tests/deSugar/ds011.stderr | 10 + ghc/compiler/tests/deSugar/ds012.hs | 10 + ghc/compiler/tests/deSugar/ds012.stderr | 58 + ghc/compiler/tests/deSugar/ds013.hs | 23 + ghc/compiler/tests/deSugar/ds013.stderr | 89 + ghc/compiler/tests/deSugar/ds014.hs | 76 + ghc/compiler/tests/deSugar/ds014.stderr | 105 + ghc/compiler/tests/deSugar/ds014a.hs | 4 + ghc/compiler/tests/deSugar/ds015.hs | 9 + ghc/compiler/tests/deSugar/ds015.stderr | 21 + ghc/compiler/tests/deSugar/ds016.hs | 15 + ghc/compiler/tests/deSugar/ds016.stderr | 47 + ghc/compiler/tests/deSugar/ds017.hs | 12 + ghc/compiler/tests/deSugar/ds017.stderr | 10 + ghc/compiler/tests/deSugar/ds018.hs | 50 + ghc/compiler/tests/deSugar/ds018.stderr | 911 ++++ ghc/compiler/tests/deSugar/ds019.hs | 8 + ghc/compiler/tests/deSugar/ds019.stderr | 34 + ghc/compiler/tests/deSugar/ds020.hs | 52 + ghc/compiler/tests/deSugar/ds020.stderr | 464 ++ ghc/compiler/tests/deSugar/ds021.hs | 8 + ghc/compiler/tests/deSugar/ds021.stderr | 23 + ghc/compiler/tests/deSugar/ds022.hs | 32 + ghc/compiler/tests/deSugar/ds022.stderr | 368 ++ ghc/compiler/tests/deSugar/ds023.hs | 7 + ghc/compiler/tests/deSugar/ds023.stderr | 12 + ghc/compiler/tests/deSugar/ds024.hs | 8 + ghc/compiler/tests/deSugar/ds024.stderr | 10 + ghc/compiler/tests/deSugar/ds025.hs | 18 + ghc/compiler/tests/deSugar/ds025.stderr | 84 + ghc/compiler/tests/deSugar/ds026.hs | 12 + ghc/compiler/tests/deSugar/ds026.stderr | 49 + ghc/compiler/tests/deSugar/ds027.hs | 9 + ghc/compiler/tests/deSugar/ds027.stderr | 44 + ghc/compiler/tests/deSugar/ds028.hs | 10 + ghc/compiler/tests/deSugar/ds028.stderr | 30 + ghc/compiler/tests/deSugar/ds029.hs | 9 + ghc/compiler/tests/deSugar/ds029.stderr | 70 + ghc/compiler/tests/deSugar/ds030.hs | 5 + ghc/compiler/tests/deSugar/ds030.stderr | 31 + ghc/compiler/tests/deSugar/ds031.hs | 5 + ghc/compiler/tests/deSugar/ds031.stderr | 51 + ghc/compiler/tests/deSugar/ds032.hs | 14 + ghc/compiler/tests/deSugar/ds032.stderr | 64 + ghc/compiler/tests/deSugar/ds033.hs | 15 + ghc/compiler/tests/deSugar/ds033.stderr | 22 + ghc/compiler/tests/deSugar/ds034.hs | 11 + ghc/compiler/tests/deSugar/ds034.stderr | 27 + ghc/compiler/tests/deSugar/ds035.hs | 18 + ghc/compiler/tests/deSugar/ds035.stderr | 5 + ghc/compiler/tests/deSugar/ds036.hs | 45 + ghc/compiler/tests/deSugar/ds036.stderr | 145 + ghc/compiler/tests/deSugar/ds037.hs | 4 + ghc/compiler/tests/deSugar/ds038.hs | 7 + ghc/compiler/tests/deSugar/ds039.hs | 4 + ghc/compiler/tests/deSugar/ds040.hs | 13 + ghc/compiler/tests/deriving/Jmakefile | 9 + ghc/compiler/tests/deriving/drv001.hs | 19 + ghc/compiler/tests/deriving/drv002.hs | 11 + ghc/compiler/tests/deriving/drv003.hs | 15 + ghc/compiler/tests/deriving/drv004.hs | 6 + ghc/compiler/tests/deriving/drv005.hs | 4 + ghc/compiler/tests/deriving/drv006.hs | 6 + ghc/compiler/tests/deriving/drv007.hs | 3 + ghc/compiler/tests/printing/Jmakefile | 9 + ghc/compiler/tests/printing/Print001.hs | 18 + ghc/compiler/tests/printing/Print001.stderr | 10 + ghc/compiler/tests/printing/Print002.hs | 40 + ghc/compiler/tests/printing/Print002.stderr | 272 + ghc/compiler/tests/printing/Print003.hs | 6 + ghc/compiler/tests/printing/Print004.hs | 18 + ghc/compiler/tests/reader/Jmakefile | 9 + ghc/compiler/tests/reader/OneA.hi | 15 + ghc/compiler/tests/reader/OneB.hi | 3 + ghc/compiler/tests/reader/OneC.hi | 3 + ghc/compiler/tests/reader/expr001.hs | 14 + ghc/compiler/tests/reader/read001.hs | 113 + ghc/compiler/tests/reader/read001.stderr | 593 +++ ghc/compiler/tests/reader/read002.hs | 13 + ghc/compiler/tests/reader/read002.stderr | 466 ++ ghc/compiler/tests/reader/read003.hs | 5 + ghc/compiler/tests/reader/read004.hs | 43 + ghc/compiler/tests/rename/Int10.hi | 21 + ghc/compiler/tests/rename/Jmakefile | 29 + ghc/compiler/tests/rename/Rn016.hi | 11 + ghc/compiler/tests/rename/Rn017.hi | 8 + ghc/compiler/tests/rename/bevan-bug-1/Jmakefile | 4 + ghc/compiler/tests/rename/bevan-bug-1/Lexeme.hi | 18 + .../tests/rename/bevan-bug-1/Lexer_Buffer.hi | 13 + .../tests/rename/bevan-bug-1/Lexer_Combinators.hi | 11 + .../tests/rename/bevan-bug-1/Lexer_Ops.lhs | 97 + .../tests/rename/bevan-bug-1/Lexer_State.hi | 22 + .../tests/rename/bevan-bug-1/Lexer_Token.hi | 16 + ghc/compiler/tests/rename/bevan-bug-1/Oberon_Id.hi | 15 + .../tests/rename/bevan-bug-1/Oberon_Integer.hi | 21 + .../tests/rename/bevan-bug-1/Oberon_Real.hi | 13 + .../tests/rename/bevan-bug-1/Oberon_String.hi | 13 + .../tests/rename/bevan-bug-1/Source_Position.hi | 18 + ghc/compiler/tests/rename/bevan-bug-1/Symbol.hi | 12 + .../tests/rename/bevan-bug-1/bevan-bug-1.stderr | 147 + ghc/compiler/tests/rename/rn001.hs | 10 + ghc/compiler/tests/rename/rn001.stderr | 74 + ghc/compiler/tests/rename/rn002.hs | 4 + ghc/compiler/tests/rename/rn002.stderr | 69 + ghc/compiler/tests/rename/rn003.hs | 9 + ghc/compiler/tests/rename/rn003.stderr | 67 + ghc/compiler/tests/rename/rn004.hs | 9 + ghc/compiler/tests/rename/rn004.stderr | 71 + ghc/compiler/tests/rename/rn005.hs | 8 + ghc/compiler/tests/rename/rn005.stderr | 65 + ghc/compiler/tests/rename/rn006.hs | 14 + ghc/compiler/tests/rename/rn006.stderr | 68 + ghc/compiler/tests/rename/rn007.hs | 20 + ghc/compiler/tests/rename/rn007.stderr | 70 + ghc/compiler/tests/rename/rn008.hs | 14 + ghc/compiler/tests/rename/rn008.stderr | 68 + ghc/compiler/tests/rename/rn009.hs | 2 + ghc/compiler/tests/rename/rn009.stderr | 94 + ghc/compiler/tests/rename/rn010.hs | 12 + ghc/compiler/tests/rename/rn010.stderr | 94 + ghc/compiler/tests/rename/rn011.hs | 102 + ghc/compiler/tests/rename/rn011.stderr | 94 + ghc/compiler/tests/rename/rn012.hs | 52 + ghc/compiler/tests/rename/rn012.stderr | 94 + ghc/compiler/tests/rename/rn013.hs | 21 + ghc/compiler/tests/rename/rn013.stderr | 94 + ghc/compiler/tests/rename/rn014.hs | 1 + ghc/compiler/tests/rename/rn014.stderr | 54 + ghc/compiler/tests/rename/rn015.hs | 19 + ghc/compiler/tests/rename/rn015.stderr | 73 + ghc/compiler/tests/rename/rn016.hs | 6 + ghc/compiler/tests/rename/rn016.stderr | 60 + ghc/compiler/tests/rename/rn017.hs | 13 + ghc/compiler/tests/rename/rn017.stderr | 48 + ghc/compiler/tests/rename/timing001.hs | 506 ++ ghc/compiler/tests/rename/timing002.hs | 502 ++ ghc/compiler/tests/rename/timing003.hs | 506 ++ ghc/compiler/tests/simplCore/Jmakefile | 10 + ghc/compiler/tests/simplCore/simpl001.hs | 11 + ghc/compiler/tests/simplCore/simpl002.hs | 9 + ghc/compiler/tests/stranal/default.lhs | 15 + ghc/compiler/tests/stranal/fact.lhs | 2 + ghc/compiler/tests/stranal/fun.lhs | 5 + ghc/compiler/tests/stranal/goo.lhs | 9 + ghc/compiler/tests/stranal/ins.lhs | 26 + ghc/compiler/tests/stranal/map.lhs | 31 + ghc/compiler/tests/stranal/moo.lhs | 5 + ghc/compiler/tests/stranal/sim.lhs | 102 + ghc/compiler/tests/stranal/syn.lhs | 14 + ghc/compiler/tests/stranal/test.lhs | 5 + ghc/compiler/tests/stranal/tst.lhs | 2 + ghc/compiler/tests/stranal/unu.lhs | 75 + ghc/compiler/tests/typecheck/Jmakefile | 7 + .../tests/typecheck/should_fail/Digraph.hs | 56 + .../tests/typecheck/should_fail/Digraph.stderr | 8 + ghc/compiler/tests/typecheck/should_fail/Jmakefile | 78 + .../tests/typecheck/should_fail/tcfail001.hs | 8 + .../tests/typecheck/should_fail/tcfail001.stderr | 8 + .../tests/typecheck/should_fail/tcfail002.hs | 4 + .../tests/typecheck/should_fail/tcfail002.stderr | 9 + .../tests/typecheck/should_fail/tcfail003.hs | 3 + .../tests/typecheck/should_fail/tcfail003.stderr | 6 + .../tests/typecheck/should_fail/tcfail004.hs | 3 + .../tests/typecheck/should_fail/tcfail004.stderr | 8 + .../tests/typecheck/should_fail/tcfail005.hs | 3 + .../tests/typecheck/should_fail/tcfail005.stderr | 8 + .../tests/typecheck/should_fail/tcfail006.hs | 5 + .../tests/typecheck/should_fail/tcfail006.stderr | 6 + .../tests/typecheck/should_fail/tcfail007.hs | 4 + .../tests/typecheck/should_fail/tcfail007.stderr | 6 + .../tests/typecheck/should_fail/tcfail008.hs | 3 + .../tests/typecheck/should_fail/tcfail008.stderr | 6 + .../tests/typecheck/should_fail/tcfail009.hs | 3 + .../tests/typecheck/should_fail/tcfail009.stderr | 7 + .../tests/typecheck/should_fail/tcfail010.hs | 3 + .../tests/typecheck/should_fail/tcfail010.stderr | 6 + .../tests/typecheck/should_fail/tcfail011.hs | 3 + .../tests/typecheck/should_fail/tcfail011.stderr | 5 + .../tests/typecheck/should_fail/tcfail012.hs | 3 + .../tests/typecheck/should_fail/tcfail012.stderr | 8 + .../tests/typecheck/should_fail/tcfail013.hs | 4 + .../tests/typecheck/should_fail/tcfail013.stderr | 9 + .../tests/typecheck/should_fail/tcfail014.hs | 5 + .../tests/typecheck/should_fail/tcfail014.stderr | 10 + .../tests/typecheck/should_fail/tcfail015.hs | 9 + .../tests/typecheck/should_fail/tcfail015.stderr | 6 + .../tests/typecheck/should_fail/tcfail016.hs | 9 + .../tests/typecheck/should_fail/tcfail016.stderr | 11 + .../tests/typecheck/should_fail/tcfail017.hs | 13 + .../tests/typecheck/should_fail/tcfail017.stderr | 6 + .../tests/typecheck/should_fail/tcfail018.hs | 5 + .../tests/typecheck/should_fail/tcfail018.stderr | 6 + .../tests/typecheck/should_fail/tcfail019.hs | 21 + .../tests/typecheck/should_fail/tcfail019.stderr | 6 + .../tests/typecheck/should_fail/tcfail020.hs | 17 + .../tests/typecheck/should_fail/tcfail020.stderr | 6 + .../tests/typecheck/should_fail/tcfail021.hs | 2 + .../tests/typecheck/should_fail/tcfail021.stderr | 6 + .../tests/typecheck/should_fail/tcfail022.hs | 6 + .../tests/typecheck/should_fail/tcfail022.stderr | 6 + .../tests/typecheck/should_fail/tcfail023.hs | 13 + .../tests/typecheck/should_fail/tcfail023.stderr | 11 + .../tests/typecheck/should_fail/tcfail024.hs | 4 + .../tests/typecheck/should_fail/tcfail024.stderr | 6 + .../tests/typecheck/should_fail/tcfail025.hs | 6 + .../tests/typecheck/should_fail/tcfail025.stderr | 6 + .../tests/typecheck/should_fail/tcfail026.hs | 9 + .../tests/typecheck/should_fail/tcfail026.stderr | 6 + .../tests/typecheck/should_fail/tcfail027.hs | 7 + .../tests/typecheck/should_fail/tcfail027.stderr | 7 + .../tests/typecheck/should_fail/tcfail028.hs | 3 + .../tests/typecheck/should_fail/tcfail028.stderr | 6 + .../tests/typecheck/should_fail/tcfail029.hs | 5 + .../tests/typecheck/should_fail/tcfail029.stderr | 6 + .../tests/typecheck/should_fail/tcfail030.hs | 1 + .../tests/typecheck/should_fail/tcfail030.stderr | 3 + .../tests/typecheck/should_fail/tcfail031.hs | 2 + .../tests/typecheck/should_fail/tcfail031.stderr | 6 + .../tests/typecheck/should_fail/tcfail032.hs | 16 + .../tests/typecheck/should_fail/tcfail032.stderr | 8 + .../tests/typecheck/should_fail/tcfail033.hs | 3 + .../tests/typecheck/should_fail/tcfail033.stderr | 8 + .../tests/typecheck/should_fail/tcfail034.hs | 37 + .../tests/typecheck/should_fail/tcfail034.stderr | 7 + .../tests/typecheck/should_fail/tcfail035.hs | 9 + .../tests/typecheck/should_fail/tcfail036.hs | 10 + .../tests/typecheck/should_fail/tcfail037.hs | 11 + .../tests/typecheck/should_fail/tcfail038.hs | 11 + .../tests/typecheck/should_fail/tcfail039.hs | 12 + .../tests/typecheck/should_fail/tcfail040.hs | 29 + .../tests/typecheck/should_fail/tcfail041.hs | 60 + .../tests/typecheck/should_fail/tcfail042.hs | 28 + .../tests/typecheck/should_fail/tcfail043.hs | 222 + .../tests/typecheck/should_fail/tcfail044.hs | 22 + .../tests/typecheck/should_fail/tcfail045.hs | 7 + .../tests/typecheck/should_fail/tcfail046.hs | 32 + .../tests/typecheck/should_fail/tcfail047.hs | 6 + .../tests/typecheck/should_fail/tcfail047.stderr | 2 + .../tests/typecheck/should_fail/tcfail048.hs | 3 + .../tests/typecheck/should_fail/tcfail048.stderr | 5 + .../tests/typecheck/should_fail/tcfail049.hs | 2 + .../tests/typecheck/should_fail/tcfail049.stderr | 5 + .../tests/typecheck/should_fail/tcfail050.hs | 2 + .../tests/typecheck/should_fail/tcfail050.stderr | 5 + .../tests/typecheck/should_fail/tcfail051.hs | 3 + .../tests/typecheck/should_fail/tcfail051.stderr | 7 + .../tests/typecheck/should_fail/tcfail052.hs | 2 + .../tests/typecheck/should_fail/tcfail052.stderr | 5 + .../tests/typecheck/should_fail/tcfail053.hs | 2 + .../tests/typecheck/should_fail/tcfail053.stderr | 5 + .../tests/typecheck/should_fail/tcfail054.hs | 2 + .../tests/typecheck/should_fail/tcfail054.stderr | 5 + .../tests/typecheck/should_fail/tcfail055.hs | 2 + .../tests/typecheck/should_fail/tcfail055.stderr | 7 + .../tests/typecheck/should_fail/tcfail056.hs | 10 + .../tests/typecheck/should_fail/tcfail056.stderr | 5 + .../tests/typecheck/should_fail/tcfail057.hs | 6 + .../tests/typecheck/should_fail/tcfail057.stderr | 5 + .../tests/typecheck/should_fail/tcfail058.hs | 6 + .../tests/typecheck/should_fail/tcfail058.stderr | 5 + .../tests/typecheck/should_fail/tcfail059.hs | 3 + .../tests/typecheck/should_fail/tcfail060.hs | 9 + .../tests/typecheck/should_fail/tcfail061.hs | 10 + .../tests/typecheck/should_fail/tcfail062.hs | 37 + .../tests/typecheck/should_fail/tcfail063.hs | 5 + .../tests/typecheck/should_fail/tcfail065.hs | 37 + .../tests/typecheck/should_fail/tcfail066.hs | 41 + .../tests/typecheck/should_fail/tcfail067.hs | 98 + .../tests/typecheck/should_fail/tcfail068.hs | 92 + .../tests/typecheck/should_succeed/ClassFoo.hi | 4 + .../tests/typecheck/should_succeed/Jmakefile | 93 + ghc/compiler/tests/typecheck/should_succeed/M.hi | 4 + .../typecheck/should_succeed/ShouldSucceed.hi | 7 + .../tests/typecheck/should_succeed/TheUtils.hi | 33 + .../tests/typecheck/should_succeed/tc001.hs | 3 + .../tests/typecheck/should_succeed/tc001.stderr | 19 + .../tests/typecheck/should_succeed/tc002.hs | 1 + .../tests/typecheck/should_succeed/tc002.stderr | 11 + .../tests/typecheck/should_succeed/tc003.hs | 12 + .../tests/typecheck/should_succeed/tc003.stderr | 25 + .../tests/typecheck/should_succeed/tc004.hs | 5 + .../tests/typecheck/should_succeed/tc004.stderr | 8 + .../tests/typecheck/should_succeed/tc005.hs | 4 + .../tests/typecheck/should_succeed/tc005.stderr | 11 + .../tests/typecheck/should_succeed/tc006.hs | 3 + .../tests/typecheck/should_succeed/tc006.stderr | 9 + .../tests/typecheck/should_succeed/tc007.hs | 9 + .../tests/typecheck/should_succeed/tc007.stderr | 26 + .../tests/typecheck/should_succeed/tc008.hs | 4 + .../tests/typecheck/should_succeed/tc008.stderr | 11 + .../tests/typecheck/should_succeed/tc009.hs | 4 + .../tests/typecheck/should_succeed/tc009.stderr | 13 + .../tests/typecheck/should_succeed/tc010.hs | 3 + .../tests/typecheck/should_succeed/tc010.stderr | 14 + .../tests/typecheck/should_succeed/tc011.hs | 3 + .../tests/typecheck/should_succeed/tc011.stderr | 6 + .../tests/typecheck/should_succeed/tc012.hs | 3 + .../tests/typecheck/should_succeed/tc012.stderr | 6 + .../tests/typecheck/should_succeed/tc013.hs | 3 + .../tests/typecheck/should_succeed/tc013.stderr | 9 + .../tests/typecheck/should_succeed/tc014.hs | 3 + .../tests/typecheck/should_succeed/tc014.stderr | 11 + .../tests/typecheck/should_succeed/tc015.hs | 3 + .../tests/typecheck/should_succeed/tc015.stderr | 7 + .../tests/typecheck/should_succeed/tc016.hs | 3 + .../tests/typecheck/should_succeed/tc016.stderr | 7 + .../tests/typecheck/should_succeed/tc017.hs | 4 + .../tests/typecheck/should_succeed/tc017.stderr | 12 + .../tests/typecheck/should_succeed/tc018.hs | 4 + .../tests/typecheck/should_succeed/tc018.stderr | 20 + .../tests/typecheck/should_succeed/tc019.hs | 3 + .../tests/typecheck/should_succeed/tc019.stderr | 17 + .../tests/typecheck/should_succeed/tc020.hs | 3 + .../tests/typecheck/should_succeed/tc020.stderr | 12 + .../tests/typecheck/should_succeed/tc021.hs | 7 + .../tests/typecheck/should_succeed/tc021.stderr | 14 + .../tests/typecheck/should_succeed/tc022.hs | 5 + .../tests/typecheck/should_succeed/tc022.stderr | 11 + .../tests/typecheck/should_succeed/tc023.hs | 7 + .../tests/typecheck/should_succeed/tc023.stderr | 19 + .../tests/typecheck/should_succeed/tc024.hs | 7 + .../tests/typecheck/should_succeed/tc024.stderr | 20 + .../tests/typecheck/should_succeed/tc025.hs | 3 + .../tests/typecheck/should_succeed/tc025.stderr | 13 + .../tests/typecheck/should_succeed/tc026.hs | 4 + .../tests/typecheck/should_succeed/tc026.stderr | 12 + .../tests/typecheck/should_succeed/tc027.hs | 5 + .../tests/typecheck/should_succeed/tc027.stderr | 15 + .../tests/typecheck/should_succeed/tc028.hs | 3 + .../tests/typecheck/should_succeed/tc028.stderr | 3 + .../tests/typecheck/should_succeed/tc029.hs | 6 + .../tests/typecheck/should_succeed/tc029.stderr | 3 + .../tests/typecheck/should_succeed/tc030.hs | 5 + .../tests/typecheck/should_succeed/tc030.stderr | 3 + .../tests/typecheck/should_succeed/tc031.hs | 3 + .../tests/typecheck/should_succeed/tc031.stderr | 3 + .../tests/typecheck/should_succeed/tc032.hs | 3 + .../tests/typecheck/should_succeed/tc032.stderr | 3 + .../tests/typecheck/should_succeed/tc033.hs | 7 + .../tests/typecheck/should_succeed/tc033.stderr | 3 + .../tests/typecheck/should_succeed/tc034.hs | 11 + .../tests/typecheck/should_succeed/tc034.stderr | 16 + .../tests/typecheck/should_succeed/tc035.hs | 9 + .../tests/typecheck/should_succeed/tc035.stderr | 9 + .../tests/typecheck/should_succeed/tc036.hs | 4 + .../tests/typecheck/should_succeed/tc036.stderr | 12 + .../tests/typecheck/should_succeed/tc037.hi | 6 + .../tests/typecheck/should_succeed/tc037.hs | 9 + .../tests/typecheck/should_succeed/tc037.stderr | 34 + .../tests/typecheck/should_succeed/tc038.hs | 3 + .../tests/typecheck/should_succeed/tc038.stderr | 15 + .../tests/typecheck/should_succeed/tc039.hs | 4 + .../tests/typecheck/should_succeed/tc039.stderr | 11 + .../tests/typecheck/should_succeed/tc040.hi | 4 + .../tests/typecheck/should_succeed/tc040.hs | 9 + .../tests/typecheck/should_succeed/tc040.stderr | 17 + .../tests/typecheck/should_succeed/tc041.hs | 12 + .../tests/typecheck/should_succeed/tc041.stderr | 22 + .../tests/typecheck/should_succeed/tc042.hs | 73 + .../tests/typecheck/should_succeed/tc042.stderr | 125 + .../tests/typecheck/should_succeed/tc043.hs | 18 + .../tests/typecheck/should_succeed/tc043.stderr | 44 + .../tests/typecheck/should_succeed/tc044.hs | 6 + .../tests/typecheck/should_succeed/tc044.stderr | 6 + .../tests/typecheck/should_succeed/tc045.hs | 19 + .../tests/typecheck/should_succeed/tc045.stderr | 32 + .../tests/typecheck/should_succeed/tc046.hs | 9 + .../tests/typecheck/should_succeed/tc046.stderr | 19 + .../tests/typecheck/should_succeed/tc047.hs | 23 + .../tests/typecheck/should_succeed/tc047.stderr | 29 + .../tests/typecheck/should_succeed/tc048.hs | 21 + .../tests/typecheck/should_succeed/tc048.stderr | 31 + .../tests/typecheck/should_succeed/tc049.hs | 39 + .../tests/typecheck/should_succeed/tc049.stderr | 123 + .../tests/typecheck/should_succeed/tc050.hs | 23 + .../tests/typecheck/should_succeed/tc050.stderr | 60 + .../tests/typecheck/should_succeed/tc051.hs | 30 + .../tests/typecheck/should_succeed/tc051.stderr | 49 + .../tests/typecheck/should_succeed/tc052.hs | 8 + .../tests/typecheck/should_succeed/tc052.stderr | 3 + .../tests/typecheck/should_succeed/tc053.hs | 12 + .../tests/typecheck/should_succeed/tc053.stderr | 45 + .../tests/typecheck/should_succeed/tc054.hs | 16 + .../tests/typecheck/should_succeed/tc054.stderr | 52 + .../tests/typecheck/should_succeed/tc055.hs | 3 + .../tests/typecheck/should_succeed/tc055.stderr | 8 + .../tests/typecheck/should_succeed/tc056.hs | 15 + .../tests/typecheck/should_succeed/tc056.stderr | 57 + .../tests/typecheck/should_succeed/tc057.hi | 7 + .../tests/typecheck/should_succeed/tc057.hs | 18 + .../tests/typecheck/should_succeed/tc057.stderr | 58 + .../tests/typecheck/should_succeed/tc058.hs | 18 + .../tests/typecheck/should_succeed/tc058.stderr | 66 + .../tests/typecheck/should_succeed/tc059.hs | 15 + .../tests/typecheck/should_succeed/tc059.stderr | 70 + .../tests/typecheck/should_succeed/tc060.hs | 12 + .../tests/typecheck/should_succeed/tc060.stderr | 35 + .../tests/typecheck/should_succeed/tc061.hs | 11 + .../tests/typecheck/should_succeed/tc061.stderr | 29 + .../tests/typecheck/should_succeed/tc062.hs | 12 + .../tests/typecheck/should_succeed/tc062.stderr | 44 + .../tests/typecheck/should_succeed/tc063.hs | 18 + .../tests/typecheck/should_succeed/tc063.stderr | 35 + .../tests/typecheck/should_succeed/tc064.hs | 7 + .../tests/typecheck/should_succeed/tc064.stderr | 7 + .../tests/typecheck/should_succeed/tc065.hs | 105 + .../tests/typecheck/should_succeed/tc065.stderr | 4 + .../tests/typecheck/should_succeed/tc066.hs | 4 + .../tests/typecheck/should_succeed/tc066.stderr | 6 + .../tests/typecheck/should_succeed/tc067.hs | 4 + .../tests/typecheck/should_succeed/tc067.stderr | 8 + .../tests/typecheck/should_succeed/tc068.hs | 18 + .../tests/typecheck/should_succeed/tc068.stderr | 45 + .../tests/typecheck/should_succeed/tc069.hs | 4 + .../tests/typecheck/should_succeed/tc069.stderr | 16 + .../tests/typecheck/should_succeed/tc070.hs | 7 + .../tests/typecheck/should_succeed/tc070.stderr | 7 + .../tests/typecheck/should_succeed/tc073.hs | 5 + .../tests/typecheck/should_succeed/tc073.stderr | 8 + .../tests/typecheck/should_succeed/tc074.hs | 18 + .../tests/typecheck/should_succeed/tc074.stderr | 45 + .../tests/typecheck/should_succeed/tc075.hs | 8 + .../tests/typecheck/should_succeed/tc076.hs | 8 + .../tests/typecheck/should_succeed/tc076.stderr | 10 + .../tests/typecheck/should_succeed/tc077.hs | 9 + .../tests/typecheck/should_succeed/tc077.stderr | 25 + .../tests/typecheck/should_succeed/tc078.hs | 8 + .../tests/typecheck/should_succeed/tc078.stderr | 27 + .../tests/typecheck/should_succeed/tc079.hs | 14 + .../tests/typecheck/should_succeed/tc079.stderr | 42 + .../tests/typecheck/should_succeed/tc080.hs | 53 + .../tests/typecheck/should_succeed/tc080.stderr | 303 ++ .../tests/typecheck/should_succeed/tc081.hs | 27 + .../tests/typecheck/should_succeed/tc082.hs | 12 + .../tests/typecheck/should_succeed/tc083.hs | 10 + .../tests/typecheck/should_succeed/tc084.hs | 23 + .../tests/typecheck/should_succeed/tc085.hs | 9 + ghc/compiler/tests/typecheck/stress/tcstress001.hs | 71 + ghc/compiler/tests/validation-misc/Echo.hs | 8 + ghc/compiler/tests/validation-misc/Jmakefile | 11 + ghc/compiler/tests/validation-misc/dotests | 27 + ghc/compiler/tests/validation-misc/naming001.hs | 1 + ghc/compiler/tests/validation-misc/naming002.hs | 1 + ghc/compiler/tests/validation-misc/naming003.hs | 1 + ghc/compiler/tests/validation-misc/naming004.hs | 2 + ghc/compiler/tests/validation-misc/naming005.hs | 1 + ghc/compiler/tests/validation-misc/testexpr.hs | 103 + ghc/compiler/tests/validation-misc/testgrhss.hs | 16 + ghc/compiler/tests/validation-misc/testmatches.hs | 12 + .../tests/validation-misc/testmonobinds.hs | 45 + ghc/compiler/tests/validation-misc/testmrule.hs | 7 + ghc/compiler/tests/validation-misc/testpats.hs | 26 + ghc/compiler/tests/wdp-array.hs | 4 + ghc/compiler/tests/wdp-otherwise.hs | 11 + ghc/compiler/tests/wdp-ppr.hs | 13 + ghc/compiler/tests/wdp-prel-insts.hs | 8 + ghc/compiler/typecheck/BackSubst.hi | 29 + ghc/compiler/typecheck/BackSubst.lhs | 451 ++ ghc/compiler/typecheck/Disambig.hi | 32 + ghc/compiler/typecheck/Disambig.lhs | 162 + ghc/compiler/typecheck/GenSpecEtc.hi | 58 + ghc/compiler/typecheck/GenSpecEtc.lhs | 506 ++ ghc/compiler/typecheck/Jmakefile | 11 + ghc/compiler/typecheck/Spec.hi | 20 + ghc/compiler/typecheck/Spec.lhs | 158 + ghc/compiler/typecheck/Subst.hi | 36 + ghc/compiler/typecheck/Subst.lhs | 827 +++ ghc/compiler/typecheck/TcBinds.hi | 21 + ghc/compiler/typecheck/TcBinds.lhs | 541 ++ ghc/compiler/typecheck/TcClassDcl.hi | 27 + ghc/compiler/typecheck/TcClassDcl.lhs | 510 ++ ghc/compiler/typecheck/TcClassSig.hi | 20 + ghc/compiler/typecheck/TcClassSig.lhs | 105 + ghc/compiler/typecheck/TcConDecls.hi | 19 + ghc/compiler/typecheck/TcConDecls.lhs | 55 + ghc/compiler/typecheck/TcContext.hi | 16 + ghc/compiler/typecheck/TcContext.lhs | 55 + ghc/compiler/typecheck/TcDefaults.hi | 16 + ghc/compiler/typecheck/TcDefaults.lhs | 67 + ghc/compiler/typecheck/TcDeriv.hi | 33 + ghc/compiler/typecheck/TcDeriv.lhs | 755 +++ ghc/compiler/typecheck/TcExpr.hi | 19 + ghc/compiler/typecheck/TcExpr.lhs | 701 +++ ghc/compiler/typecheck/TcGRHSs.hi | 19 + ghc/compiler/typecheck/TcGRHSs.lhs | 76 + ghc/compiler/typecheck/TcGenDeriv.hi | 95 + ghc/compiler/typecheck/TcGenDeriv.lhs | 1070 ++++ ghc/compiler/typecheck/TcIfaceSig.hi | 15 + ghc/compiler/typecheck/TcIfaceSig.lhs | 77 + ghc/compiler/typecheck/TcInstDcls.hi | 41 + ghc/compiler/typecheck/TcInstDcls.lhs | 1079 ++++ ghc/compiler/typecheck/TcMatches.hi | 23 + ghc/compiler/typecheck/TcMatches.lhs | 221 + ghc/compiler/typecheck/TcModule.hi | 68 + ghc/compiler/typecheck/TcModule.lhs | 279 + ghc/compiler/typecheck/TcMonad.hi | 218 + ghc/compiler/typecheck/TcMonad.lhs | 718 +++ ghc/compiler/typecheck/TcMonadFns.hi | 95 + ghc/compiler/typecheck/TcMonadFns.lhs | 243 + ghc/compiler/typecheck/TcMonoBnds.hi | 19 + ghc/compiler/typecheck/TcMonoBnds.lhs | 130 + ghc/compiler/typecheck/TcMonoType.hi | 19 + ghc/compiler/typecheck/TcMonoType.lhs | 186 + ghc/compiler/typecheck/TcParQuals.lhs | 97 + ghc/compiler/typecheck/TcPat.hi | 17 + ghc/compiler/typecheck/TcPat.lhs | 389 ++ ghc/compiler/typecheck/TcPolyType.hi | 17 + ghc/compiler/typecheck/TcPolyType.lhs | 110 + ghc/compiler/typecheck/TcPragmas.hi | 30 + ghc/compiler/typecheck/TcPragmas.lhs | 696 +++ ghc/compiler/typecheck/TcQuals.hi | 19 + ghc/compiler/typecheck/TcQuals.lhs | 55 + ghc/compiler/typecheck/TcSimplify.hi | 34 + ghc/compiler/typecheck/TcSimplify.lhs | 602 +++ ghc/compiler/typecheck/TcTyDecls.hi | 20 + ghc/compiler/typecheck/TcTyDecls.lhs | 280 + ghc/compiler/typecheck/Typecheck.hi | 64 + ghc/compiler/typecheck/Typecheck.lhs | 83 + ghc/compiler/typecheck/Unify.hi | 18 + ghc/compiler/typecheck/Unify.lhs | 360 ++ ghc/compiler/typecheck/root.lit | 71 + ghc/compiler/uniType/AbsUniType.hi | 568 +++ ghc/compiler/uniType/AbsUniType.lhs | 223 + ghc/compiler/uniType/Class.hi | 108 + ghc/compiler/uniType/Class.lhs | 386 ++ ghc/compiler/uniType/TyCon.hi | 113 + ghc/compiler/uniType/TyCon.lhs | 585 +++ ghc/compiler/uniType/TyVar.hi | 114 + ghc/compiler/uniType/TyVar.lhs | 344 ++ ghc/compiler/uniType/UniTyFuns.hi | 175 + ghc/compiler/uniType/UniTyFuns.lhs | 1940 +++++++ ghc/compiler/uniType/UniType.hi | 74 + ghc/compiler/uniType/UniType.lhs | 370 ++ ghc/compiler/utils/Bag.hi | 27 + ghc/compiler/utils/Bag.lhs | 110 + ghc/compiler/utils/BitSet.hi | 16 + ghc/compiler/utils/BitSet.lhs | 197 + ghc/compiler/utils/CharSeq.hi | 26 + ghc/compiler/utils/CharSeq.lhs | 282 ++ ghc/compiler/utils/Digraph.hi | 11 + ghc/compiler/utils/Digraph.lhs | 159 + ghc/compiler/utils/FiniteMap.hi | 58 + ghc/compiler/utils/FiniteMap.lhs | 851 ++++ ghc/compiler/utils/LiftMonad.hi | 5 + ghc/compiler/utils/LiftMonad.lhs | 39 + ghc/compiler/utils/ListSetOps.hi | 9 + ghc/compiler/utils/ListSetOps.lhs | 95 + ghc/compiler/utils/Maybes.hi | 31 + ghc/compiler/utils/Maybes.lhs | 222 + ghc/compiler/utils/Outputable.hi | 100 + ghc/compiler/utils/Outputable.lhs | 318 ++ ghc/compiler/utils/Pretty.hi | 81 + ghc/compiler/utils/Pretty.lhs | 439 ++ ghc/compiler/utils/UniqFM.hi | 59 + ghc/compiler/utils/UniqFM.lhs | 881 ++++ ghc/compiler/utils/UniqSet.hi | 61 + ghc/compiler/utils/UniqSet.lhs | 164 + ghc/compiler/utils/Unpretty.hi | 67 + ghc/compiler/utils/Unpretty.lhs | 170 + ghc/compiler/utils/Util.hi | 390 ++ ghc/compiler/utils/Util.lhs | 1056 ++++ ghc/compiler/yaccParser/Jmakefile | 112 + ghc/compiler/yaccParser/MAIL.byacc | 146 + ghc/compiler/yaccParser/README-DPH | 241 + ghc/compiler/yaccParser/README.debug | 12 + ghc/compiler/yaccParser/U_atype.hi | 9 + ghc/compiler/yaccParser/U_atype.hs | 22 + ghc/compiler/yaccParser/U_binding.hi | 11 + ghc/compiler/yaccParser/U_binding.hs | 222 + ghc/compiler/yaccParser/U_coresyn.hi | 12 + ghc/compiler/yaccParser/U_coresyn.hs | 278 + ghc/compiler/yaccParser/U_entidt.hi | 8 + ghc/compiler/yaccParser/U_entidt.hs | 42 + ghc/compiler/yaccParser/U_finfot.hi | 7 + ghc/compiler/yaccParser/U_finfot.hs | 20 + ghc/compiler/yaccParser/U_hpragma.hi | 10 + ghc/compiler/yaccParser/U_hpragma.hs | 139 + ghc/compiler/yaccParser/U_list.hi | 7 + ghc/compiler/yaccParser/U_list.hs | 20 + ghc/compiler/yaccParser/U_literal.hi | 7 + ghc/compiler/yaccParser/U_literal.hs | 68 + ghc/compiler/yaccParser/U_pbinding.hi | 10 + ghc/compiler/yaccParser/U_pbinding.hs | 32 + ghc/compiler/yaccParser/U_tree.hs | 184 + ghc/compiler/yaccParser/U_treeHACK.hi | 15 + ghc/compiler/yaccParser/U_treeHACK.hs | 185 + ghc/compiler/yaccParser/U_ttype.hi | 9 + ghc/compiler/yaccParser/U_ttype.hs | 66 + ghc/compiler/yaccParser/UgenAll.hi | 95 + ghc/compiler/yaccParser/UgenAll.lhs | 48 + ghc/compiler/yaccParser/UgenUtil.hi | 48 + ghc/compiler/yaccParser/UgenUtil.lhs | 98 + ghc/compiler/yaccParser/atype.c | 57 + ghc/compiler/yaccParser/atype.h | 83 + ghc/compiler/yaccParser/atype.ugn | 15 + ghc/compiler/yaccParser/binding.c | 1187 +++++ ghc/compiler/yaccParser/binding.h | 1444 ++++++ ghc/compiler/yaccParser/binding.ugn | 106 + ghc/compiler/yaccParser/constants.h | 52 + ghc/compiler/yaccParser/coresyn.c | 1495 ++++++ ghc/compiler/yaccParser/coresyn.h | 1728 +++++++ ghc/compiler/yaccParser/coresyn.ugn | 120 + ghc/compiler/yaccParser/entidt.c | 167 + ghc/compiler/yaccParser/entidt.h | 198 + ghc/compiler/yaccParser/entidt.ugn | 20 + ghc/compiler/yaccParser/finfot.c | 55 + ghc/compiler/yaccParser/finfot.h | 74 + ghc/compiler/yaccParser/finfot.ugn | 12 + ghc/compiler/yaccParser/hpragma.c | 701 +++ ghc/compiler/yaccParser/hpragma.h | 815 +++ ghc/compiler/yaccParser/hpragma.ugn | 73 + ghc/compiler/yaccParser/hschooks.c | 65 + ghc/compiler/yaccParser/hsclink.c | 63 + ghc/compiler/yaccParser/hslexer-DPH.lex | 1397 +++++ ghc/compiler/yaccParser/hslexer.c | 4116 +++++++++++++++ ghc/compiler/yaccParser/hslexer.flex | 1362 +++++ ghc/compiler/yaccParser/hsparser-DPH.y | 1555 ++++++ ghc/compiler/yaccParser/hsparser.tab.c | 4665 +++++++++++++++++ ghc/compiler/yaccParser/hsparser.tab.h | 138 + ghc/compiler/yaccParser/hsparser.y | 2131 ++++++++ ghc/compiler/yaccParser/hspincl.h | 74 + ghc/compiler/yaccParser/id.c | 286 ++ ghc/compiler/yaccParser/id.h | 15 + ghc/compiler/yaccParser/impidt.c | 320 ++ ghc/compiler/yaccParser/impidt.h | 143 + ghc/compiler/yaccParser/import_dirlist.c | 224 + ghc/compiler/yaccParser/infix.c | 260 + ghc/compiler/yaccParser/list.c | 55 + ghc/compiler/yaccParser/list.h | 74 + ghc/compiler/yaccParser/list.ugn | 13 + ghc/compiler/yaccParser/listcomp.c | 67 + ghc/compiler/yaccParser/literal.c | 321 ++ ghc/compiler/yaccParser/literal.h | 359 ++ ghc/compiler/yaccParser/literal.ugn | 25 + ghc/compiler/yaccParser/main.c | 57 + ghc/compiler/yaccParser/pbinding.c | 81 + ghc/compiler/yaccParser/pbinding.h | 115 + ghc/compiler/yaccParser/pbinding.ugn | 23 + ghc/compiler/yaccParser/printtree.c | 998 ++++ ghc/compiler/yaccParser/syntax.c | 728 +++ ghc/compiler/yaccParser/tree-DPH.ugn | 80 + ghc/compiler/yaccParser/tree.c | 869 ++++ ghc/compiler/yaccParser/tree.h | 1001 ++++ ghc/compiler/yaccParser/tree.ugn | 80 + ghc/compiler/yaccParser/ttype-DPH.ugn | 23 + ghc/compiler/yaccParser/ttype.c | 301 ++ ghc/compiler/yaccParser/ttype.h | 345 ++ ghc/compiler/yaccParser/ttype.ugn | 31 + ghc/compiler/yaccParser/type2context.c | 160 + ghc/compiler/yaccParser/util.c | 312 ++ ghc/compiler/yaccParser/utils.h | 140 + ghc/docs/ANNOUNCE-0.06 | 116 + ghc/docs/ANNOUNCE-0.10 | 135 + ghc/docs/ANNOUNCE-0.16 | 146 + ghc/docs/ANNOUNCE-0.19 | 130 + ghc/docs/ANNOUNCE-0.20 | 55 + ghc/docs/ANNOUNCE-0.22 | 109 + ghc/docs/ANNOUNCE-0.23 | 124 + ghc/docs/ANNOUNCE-0.25 | 54 + ghc/docs/Jmakefile | 19 + ghc/docs/NOTES.adding-PrimOp | 51 + ghc/docs/NOTES.arbitary-ints | 54 + ghc/docs/NOTES.c-optimisation | 2361 +++++++++ ghc/docs/NOTES.core-overview | 94 + ghc/docs/NOTES.desugar | 323 ++ ghc/docs/NOTES.garbage.collection | 206 + ghc/docs/NOTES.import | 90 + ghc/docs/NOTES.interface | 54 + ghc/docs/NOTES.mkworld2 | 48 + ghc/docs/NOTES.part-of-book | 73 + ghc/docs/NOTES.rename | 109 + ghc/docs/NOTES.saving-space | 250 + ghc/docs/NOTES.update-mechanism | 195 + ghc/docs/Prefix_Form | 294 ++ ghc/docs/README | 71 + ghc/docs/abstracts/README | 4 + ghc/docs/abstracts/abstracts.sty | 30 + ghc/docs/abstracts/abstracts89.tex | 487 ++ ghc/docs/abstracts/abstracts90.tex | 153 + ghc/docs/abstracts/abstracts91.tex | 232 + ghc/docs/abstracts/abstracts92.tex | 292 ++ ghc/docs/abstracts/abstracts93.tex | 326 ++ ghc/docs/abstracts/abstracts94.tex | 187 + ghc/docs/abstracts/before90.tex | 471 ++ ghc/docs/abstracts/reports.tex | 111 + ghc/docs/abstracts/slpj.sty | 41 + ghc/docs/abstracts/useful.sty | 186 + ghc/docs/add_to_compiler/Jmakefile | 22 + ghc/docs/add_to_compiler/back-end.verb | 41 + ghc/docs/add_to_compiler/core-summary-fig.verb | 45 + ghc/docs/add_to_compiler/core-syntax.verb | 142 + ghc/docs/add_to_compiler/front-end.verb | 304 ++ ghc/docs/add_to_compiler/howto-add.verb | 353 ++ ghc/docs/add_to_compiler/overview-fig.fig | 136 + ghc/docs/add_to_compiler/overview.verb | 70 + ghc/docs/add_to_compiler/paper.bbl | 72 + ghc/docs/add_to_compiler/paper.verb | 77 + ghc/docs/add_to_compiler/slides-root.tex | 8 + ghc/docs/add_to_compiler/slides.tex | 86 + ghc/docs/add_to_compiler/state-of-play.NOTES | 73 + ghc/docs/add_to_compiler/state-of-play.verb | 14 + ghc/docs/add_to_compiler/stg-summary-fig.verb | 55 + ghc/docs/grasp.sty | 177 + ghc/docs/install_guide/Jmakefile | 7 + ghc/docs/install_guide/installing.lit | 2133 ++++++++ ghc/docs/release_notes/0-02-notes.lit | 230 + ghc/docs/release_notes/0-03-README | 47 + ghc/docs/release_notes/0-04-README | 15 + ghc/docs/release_notes/0-05-notes.lit | 86 + ghc/docs/release_notes/0-06-notes.lit | 266 + ghc/docs/release_notes/0-07-README | 4 + ghc/docs/release_notes/0-07-notes.lit | 51 + ghc/docs/release_notes/0-08-notes.lit | 149 + ghc/docs/release_notes/0-10-notes.lit | 72 + ghc/docs/release_notes/0-16-notes.lit | 106 + ghc/docs/release_notes/0-17-notes.lit | 1 + ghc/docs/release_notes/0-18-README | 63 + ghc/docs/release_notes/0-19-notes.lit | 187 + ghc/docs/release_notes/0-22-notes.lit | 205 + ghc/docs/release_notes/0-23-notes.lit | 253 + ghc/docs/release_notes/0-26-notes.lit | 244 + ghc/docs/release_notes/Jmakefile | 13 + ghc/docs/release_notes/real-soon-now.lit | 49 + ghc/docs/release_notes/release.lit | 93 + ghc/docs/simple-monad.lhs | 264 + ghc/docs/users_guide/Jmakefile | 9 + ghc/docs/users_guide/glasgow_exts.lit | 722 +++ ghc/docs/users_guide/gone_wrong.lit | 332 ++ ghc/docs/users_guide/how_to_run.lit | 1139 +++++ ghc/docs/users_guide/intro.lit | 69 + ghc/docs/users_guide/libraries.lit | 1047 ++++ ghc/docs/users_guide/parallel.lit | 662 +++ ghc/docs/users_guide/prof-compiler-options.lit | 84 + ghc/docs/users_guide/prof-options.lit | 30 + ghc/docs/users_guide/prof-post-processors.lit | 130 + ghc/docs/users_guide/prof-reports.lit | 1 + ghc/docs/users_guide/prof-rts-options.lit | 120 + ghc/docs/users_guide/profiling.lit | 239 + ghc/docs/users_guide/runtime_control.lit | 332 ++ ghc/docs/users_guide/sooner.lit | 530 ++ ghc/docs/users_guide/ticky.lit | 26 + ghc/docs/users_guide/tutorial.lit | 129 + ghc/docs/users_guide/user.lit | 36 + ghc/docs/users_guide/utils.lit | 143 + ghc/docs/users_guide/vs_haskell.lit | 575 +++ ghc/driver/Jmakefile | 64 + ghc/driver/driver.lit | 39 + ghc/driver/ghc-asm-alpha.lprl | 510 ++ ghc/driver/ghc-asm-hppa.lprl | 575 +++ ghc/driver/ghc-asm-iX86.lprl | 640 +++ ghc/driver/ghc-asm-m68k.lprl | 475 ++ ghc/driver/ghc-asm-mips.lprl | 517 ++ ghc/driver/ghc-asm-sgi.prl | 69 + ghc/driver/ghc-asm-solaris.lprl | 487 ++ ghc/driver/ghc-asm-sparc.lprl | 477 ++ ghc/driver/ghc-consist.lprl | 64 + ghc/driver/ghc-split.lprl | 435 ++ ghc/driver/ghc.lprl | 2679 ++++++++++ ghc/driver/ordering-passes | 257 + ghc/driver/test_mangler | 27 + ghc/glue_TAGS_files.prl | 28 + ghc/includes/AgeProfile.lh | 151 + ghc/includes/COptJumps.lh | 534 ++ ghc/includes/COptRegs.lh | 1261 +++++ ghc/includes/COptWraps.lh | 657 +++ ghc/includes/CostCentre.lh | 674 +++ ghc/includes/Force_GC.lh | 25 + ghc/includes/GhcConstants.lh | 277 + ghc/includes/GranSim.lh | 71 + ghc/includes/HLC.h | 45 + ghc/includes/Info.lh | 27 + ghc/includes/Jmakefile | 110 + ghc/includes/LLC.h | 90 + ghc/includes/MachRegs.lh | 847 ++++ ghc/includes/NativeGen.h | 40 + ghc/includes/PEOpCodes.h | 52 + ghc/includes/Parallel.lh | 512 ++ ghc/includes/RednCounts.lh | 849 ++++ ghc/includes/SMClosures.lh | 1110 ++++ ghc/includes/SMInfoTables.lh | 1763 +++++++ ghc/includes/SMcompact.lh | 176 + ghc/includes/SMcopying.lh | 179 + ghc/includes/SMinterface.lh | 537 ++ ghc/includes/SMmark.lh | 157 + ghc/includes/SMupdate.lh | 556 ++ ghc/includes/StgDirections.h | 89 + ghc/includes/StgMachDeps.h | 89 + ghc/includes/StgMacros.lh | 2103 ++++++++ ghc/includes/StgRegs.lh | 337 ++ ghc/includes/StgTypes.lh | 243 + ghc/includes/Threads.lh | 843 +++ ghc/includes/c-as-asm.lit | 509 ++ ghc/includes/closure.ps | 1032 ++++ ghc/includes/config.h.in | 179 + ghc/includes/error.h | 141 + ghc/includes/ghcReadline.h | 21 + ghc/includes/ghcRegex.h | 520 ++ ghc/includes/ghcSockets.h | 19 + ghc/includes/gmp.h | 302 ++ ghc/includes/ieee-flpt.h | 35 + ghc/includes/libposix.h | 61 + ghc/includes/mkNativeHdr.lc | 117 + ghc/includes/platform.h.in | 50 + ghc/includes/pvm3.h | 315 ++ ghc/includes/root.lit | 89 + ghc/includes/rtsTypes.lh | 162 + ghc/includes/rtsdefs.h | 14 + ghc/includes/sparc-sun-sunos4.h | 44 + ghc/includes/stgdefs.h | 219 + ghc/includes/stgio.h | 125 + ghc/includes/timezone.h | 29 + ghc/includes/update-frame.ps | 592 +++ ghc/lib/Jmakefile | 1159 +++++ ghc/lib/README | 22 + ghc/lib/ghc/BSD.hi | 72 + ghc/lib/ghc/BSD.lhs | 390 ++ ghc/lib/ghc/BSD_mc.hi | 72 + ghc/lib/ghc/BSD_mg.hi | 72 + ghc/lib/ghc/BSD_mp.hi | 72 + ghc/lib/ghc/BSD_p.hi | 72 + ghc/lib/ghc/BSD_t.hi | 72 + ghc/lib/ghc/Bag.hi | 26 + ghc/lib/ghc/Bag.lhs | 110 + ghc/lib/ghc/Bag_mc.hi | 26 + ghc/lib/ghc/Bag_mg.hi | 26 + ghc/lib/ghc/Bag_mp.hi | 26 + ghc/lib/ghc/Bag_mr.hi | 26 + ghc/lib/ghc/Bag_mt.hi | 26 + ghc/lib/ghc/Bag_p.hi | 26 + ghc/lib/ghc/Bag_t.hi | 26 + ghc/lib/ghc/BitSet.hi | 22 + ghc/lib/ghc/BitSet.lhs | 197 + ghc/lib/ghc/BitSet_mc.hi | 22 + ghc/lib/ghc/BitSet_mg.hi | 22 + ghc/lib/ghc/BitSet_mp.hi | 22 + ghc/lib/ghc/BitSet_mr.hi | 22 + ghc/lib/ghc/BitSet_mt.hi | 22 + ghc/lib/ghc/BitSet_p.hi | 22 + ghc/lib/ghc/BitSet_t.hi | 22 + ghc/lib/ghc/CError.hi | 35 + ghc/lib/ghc/CError.lhs | 285 ++ ghc/lib/ghc/CError_mc.hi | 35 + ghc/lib/ghc/CError_mg.hi | 35 + ghc/lib/ghc/CError_mp.hi | 35 + ghc/lib/ghc/CError_p.hi | 35 + ghc/lib/ghc/CError_t.hi | 35 + ghc/lib/ghc/CharSeq.hi | 26 + ghc/lib/ghc/CharSeq.lhs | 282 ++ ghc/lib/ghc/CharSeq_mc.hi | 26 + ghc/lib/ghc/CharSeq_mg.hi | 26 + ghc/lib/ghc/CharSeq_mp.hi | 26 + ghc/lib/ghc/CharSeq_mr.hi | 26 + ghc/lib/ghc/CharSeq_mt.hi | 26 + ghc/lib/ghc/CharSeq_p.hi | 26 + ghc/lib/ghc/CharSeq_t.hi | 26 + ghc/lib/ghc/FiniteMap.hi | 55 + ghc/lib/ghc/FiniteMap.lhs | 851 ++++ ghc/lib/ghc/FiniteMap_mc.hi | 55 + ghc/lib/ghc/FiniteMap_mg.hi | 55 + ghc/lib/ghc/FiniteMap_mp.hi | 55 + ghc/lib/ghc/FiniteMap_mr.hi | 55 + ghc/lib/ghc/FiniteMap_mt.hi | 55 + ghc/lib/ghc/FiniteMap_p.hi | 55 + ghc/lib/ghc/FiniteMap_t.hi | 55 + ghc/lib/ghc/ListSetOps.hi | 13 + ghc/lib/ghc/ListSetOps.lhs | 95 + ghc/lib/ghc/ListSetOps_mc.hi | 13 + ghc/lib/ghc/ListSetOps_mg.hi | 13 + ghc/lib/ghc/ListSetOps_mp.hi | 13 + ghc/lib/ghc/ListSetOps_mr.hi | 13 + ghc/lib/ghc/ListSetOps_mt.hi | 13 + ghc/lib/ghc/ListSetOps_p.hi | 13 + ghc/lib/ghc/ListSetOps_t.hi | 13 + ghc/lib/ghc/MatchPS.hi | 38 + ghc/lib/ghc/MatchPS.lhs | 494 ++ ghc/lib/ghc/MatchPS_mc.hi | 38 + ghc/lib/ghc/MatchPS_mg.hi | 38 + ghc/lib/ghc/MatchPS_mp.hi | 38 + ghc/lib/ghc/MatchPS_p.hi | 38 + ghc/lib/ghc/MatchPS_t.hi | 38 + ghc/lib/ghc/Maybes.hi | 39 + ghc/lib/ghc/Maybes.lhs | 222 + ghc/lib/ghc/Maybes_mc.hi | 39 + ghc/lib/ghc/Maybes_mg.hi | 39 + ghc/lib/ghc/Maybes_mp.hi | 39 + ghc/lib/ghc/Maybes_mr.hi | 39 + ghc/lib/ghc/Maybes_mt.hi | 39 + ghc/lib/ghc/Maybes_p.hi | 39 + ghc/lib/ghc/Maybes_t.hi | 39 + ghc/lib/ghc/PackedString.hi | 75 + ghc/lib/ghc/PackedString.lhs | 97 + ghc/lib/ghc/PackedString_mc.hi | 75 + ghc/lib/ghc/PackedString_mg.hi | 75 + ghc/lib/ghc/PackedString_mp.hi | 75 + ghc/lib/ghc/PackedString_mr.hi | 75 + ghc/lib/ghc/PackedString_mt.hi | 75 + ghc/lib/ghc/PackedString_p.hi | 75 + ghc/lib/ghc/PackedString_t.hi | 75 + ghc/lib/ghc/Pretty.hi | 67 + ghc/lib/ghc/Pretty.lhs | 439 ++ ghc/lib/ghc/Pretty_mc.hi | 67 + ghc/lib/ghc/Pretty_mg.hi | 67 + ghc/lib/ghc/Pretty_mp.hi | 67 + ghc/lib/ghc/Pretty_mr.hi | 67 + ghc/lib/ghc/Pretty_mt.hi | 67 + ghc/lib/ghc/Pretty_p.hi | 67 + ghc/lib/ghc/Pretty_t.hi | 67 + ghc/lib/ghc/Readline.hi | 44 + ghc/lib/ghc/Readline.lhs | 325 ++ ghc/lib/ghc/Readline_mc.hi | 44 + ghc/lib/ghc/Readline_mg.hi | 44 + ghc/lib/ghc/Readline_mp.hi | 44 + ghc/lib/ghc/Readline_p.hi | 44 + ghc/lib/ghc/Readline_t.hi | 44 + ghc/lib/ghc/Regex.hi | 22 + ghc/lib/ghc/Regex.lhs | 389 ++ ghc/lib/ghc/Regex_mc.hi | 22 + ghc/lib/ghc/Regex_mg.hi | 22 + ghc/lib/ghc/Regex_mp.hi | 22 + ghc/lib/ghc/Regex_p.hi | 22 + ghc/lib/ghc/Regex_t.hi | 22 + ghc/lib/ghc/Set.hi | 36 + ghc/lib/ghc/Set.lhs | 103 + ghc/lib/ghc/Set_mc.hi | 36 + ghc/lib/ghc/Set_mg.hi | 36 + ghc/lib/ghc/Set_mp.hi | 36 + ghc/lib/ghc/Set_mr.hi | 36 + ghc/lib/ghc/Set_mt.hi | 36 + ghc/lib/ghc/Set_p.hi | 36 + ghc/lib/ghc/Set_t.hi | 36 + ghc/lib/ghc/Socket.hi | 23 + ghc/lib/ghc/Socket.lhs | 189 + ghc/lib/ghc/SocketPrim.hi | 125 + ghc/lib/ghc/SocketPrim.lhs | 966 ++++ ghc/lib/ghc/SocketPrim_mc.hi | 125 + ghc/lib/ghc/SocketPrim_mg.hi | 125 + ghc/lib/ghc/SocketPrim_mp.hi | 125 + ghc/lib/ghc/SocketPrim_p.hi | 125 + ghc/lib/ghc/SocketPrim_t.hi | 125 + ghc/lib/ghc/Socket_mc.hi | 23 + ghc/lib/ghc/Socket_mg.hi | 23 + ghc/lib/ghc/Socket_mp.hi | 23 + ghc/lib/ghc/Socket_p.hi | 23 + ghc/lib/ghc/Socket_t.hi | 23 + ghc/lib/ghc/Util.hi | 65 + ghc/lib/ghc/Util.lhs | 1056 ++++ ghc/lib/ghc/Util_mc.hi | 65 + ghc/lib/ghc/Util_mg.hi | 65 + ghc/lib/ghc/Util_mp.hi | 65 + ghc/lib/ghc/Util_mr.hi | 65 + ghc/lib/ghc/Util_mt.hi | 65 + ghc/lib/ghc/Util_p.hi | 65 + ghc/lib/ghc/Util_t.hi | 65 + ghc/lib/glaExts/ByteOps.hi | 24 + ghc/lib/glaExts/ByteOps.lhs | 147 + ghc/lib/glaExts/ByteOps_mc.hi | 24 + ghc/lib/glaExts/ByteOps_mg.hi | 24 + ghc/lib/glaExts/ByteOps_mp.hi | 24 + ghc/lib/glaExts/ByteOps_mr.hi | 24 + ghc/lib/glaExts/ByteOps_mt.hi | 24 + ghc/lib/glaExts/ByteOps_p.hi | 24 + ghc/lib/glaExts/ByteOps_t.hi | 24 + ghc/lib/glaExts/Jmakefile | 8 + ghc/lib/glaExts/MainIO.lhs | 25 + ghc/lib/glaExts/MainIO13.hi | 6 + ghc/lib/glaExts/MainIO13.lhs | 40 + ghc/lib/glaExts/MainIO13_mc.hi | 6 + ghc/lib/glaExts/MainIO13_mg.hi | 6 + ghc/lib/glaExts/MainIO13_mp.hi | 6 + ghc/lib/glaExts/MainIO13_mr.hi | 6 + ghc/lib/glaExts/MainIO13_mt.hi | 6 + ghc/lib/glaExts/MainIO13_p.hi | 6 + ghc/lib/glaExts/MainIO13_t.hi | 6 + ghc/lib/glaExts/PreludeDialogueIO.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO.lhs | 346 ++ ghc/lib/glaExts/PreludeDialogueIO_mc.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO_mg.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO_mp.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO_mr.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO_mt.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO_p.hi | 17 + ghc/lib/glaExts/PreludeDialogueIO_t.hi | 17 + ghc/lib/glaExts/PreludeErrIO.hi | 6 + ghc/lib/glaExts/PreludeErrIO.lhs | 18 + ghc/lib/glaExts/PreludeErrIO_mc.hi | 6 + ghc/lib/glaExts/PreludeErrIO_mg.hi | 6 + ghc/lib/glaExts/PreludeErrIO_mp.hi | 6 + ghc/lib/glaExts/PreludeErrIO_mr.hi | 6 + ghc/lib/glaExts/PreludeErrIO_mt.hi | 6 + ghc/lib/glaExts/PreludeErrIO_p.hi | 6 + ghc/lib/glaExts/PreludeErrIO_t.hi | 6 + ghc/lib/glaExts/PreludeGlaMisc.hi | 23 + ghc/lib/glaExts/PreludeGlaMisc.lhs | 115 + ghc/lib/glaExts/PreludeGlaMisc_mc.hi | 23 + ghc/lib/glaExts/PreludeGlaMisc_mg.hi | 23 + ghc/lib/glaExts/PreludeGlaMisc_mp.hi | 8 + ghc/lib/glaExts/PreludeGlaMisc_mr.hi | 23 + ghc/lib/glaExts/PreludeGlaMisc_mt.hi | 23 + ghc/lib/glaExts/PreludeGlaMisc_p.hi | 23 + ghc/lib/glaExts/PreludeGlaMisc_t.hi | 23 + ghc/lib/glaExts/PreludeGlaST.hi | 187 + ghc/lib/glaExts/PreludeGlaST.lhs | 712 +++ ghc/lib/glaExts/PreludeGlaST_mc.hi | 187 + ghc/lib/glaExts/PreludeGlaST_mg.hi | 187 + ghc/lib/glaExts/PreludeGlaST_mp.hi | 187 + ghc/lib/glaExts/PreludeGlaST_mr.hi | 187 + ghc/lib/glaExts/PreludeGlaST_mt.hi | 187 + ghc/lib/glaExts/PreludeGlaST_p.hi | 187 + ghc/lib/glaExts/PreludeGlaST_t.hi | 187 + ghc/lib/glaExts/PreludeMain13_help.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_1s.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_2s.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_du.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_i.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_j.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_k.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_l.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_m.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_mc.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_mg.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_mp.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_mr.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_mt.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_n.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_o.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_p.hi | 5 + ghc/lib/glaExts/PreludeMain13_help_t.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_1s.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_2s.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_du.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_i.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_j.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_k.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_l.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_m.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_mc.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_mg.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_mp.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_mr.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_mt.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_n.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_o.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_p.hi | 5 + ghc/lib/glaExts/PreludeMainIO_help_t.hi | 5 + ghc/lib/glaExts/PreludePrimIO.hi | 82 + ghc/lib/glaExts/PreludePrimIO.lhs | 293 ++ ghc/lib/glaExts/PreludePrimIO_mc.hi | 82 + ghc/lib/glaExts/PreludePrimIO_mg.hi | 82 + ghc/lib/glaExts/PreludePrimIO_mp.hi | 82 + ghc/lib/glaExts/PreludePrimIO_mr.hi | 82 + ghc/lib/glaExts/PreludePrimIO_mt.hi | 82 + ghc/lib/glaExts/PreludePrimIO_p.hi | 82 + ghc/lib/glaExts/PreludePrimIO_t.hi | 82 + ghc/lib/glaExts/Stdio.hi | 30 + ghc/lib/glaExts/Stdio.lhs | 116 + ghc/lib/glaExts/Stdio_mc.hi | 30 + ghc/lib/glaExts/Stdio_mg.hi | 30 + ghc/lib/glaExts/Stdio_mp.hi | 30 + ghc/lib/glaExts/Stdio_mr.hi | 30 + ghc/lib/glaExts/Stdio_mt.hi | 30 + ghc/lib/glaExts/Stdio_p.hi | 30 + ghc/lib/glaExts/Stdio_t.hi | 30 + ghc/lib/glaExts/lazyimp.lit | 70 + ghc/lib/haskell-1.3/LibCPUTime.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime.lhs | 31 + ghc/lib/haskell-1.3/LibCPUTime_mc.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime_mg.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime_mp.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime_mr.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime_mt.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime_p.hi | 7 + ghc/lib/haskell-1.3/LibCPUTime_t.hi | 7 + ghc/lib/haskell-1.3/LibDirectory.hi | 21 + ghc/lib/haskell-1.3/LibDirectory.lhs | 376 ++ ghc/lib/haskell-1.3/LibDirectory_mc.hi | 21 + ghc/lib/haskell-1.3/LibDirectory_mg.hi | 21 + ghc/lib/haskell-1.3/LibDirectory_mp.hi | 21 + ghc/lib/haskell-1.3/LibDirectory_mr.hi | 21 + ghc/lib/haskell-1.3/LibDirectory_mt.hi | 21 + ghc/lib/haskell-1.3/LibDirectory_p.hi | 21 + ghc/lib/haskell-1.3/LibDirectory_t.hi | 21 + ghc/lib/haskell-1.3/LibPosix.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix.lhs | 101 + ghc/lib/haskell-1.3/LibPosixDB.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB.lhs | 135 + ghc/lib/haskell-1.3/LibPosixDB_mc.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB_mg.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB_mp.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB_mr.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB_mt.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB_p.hi | 31 + ghc/lib/haskell-1.3/LibPosixDB_t.hi | 31 + ghc/lib/haskell-1.3/LibPosixErr.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr.lhs | 164 + ghc/lib/haskell-1.3/LibPosixErr_mc.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr_mg.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr_mp.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr_mr.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr_mt.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr_p.hi | 148 + ghc/lib/haskell-1.3/LibPosixErr_t.hi | 148 + ghc/lib/haskell-1.3/LibPosixFiles.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles.lhs | 559 ++ ghc/lib/haskell-1.3/LibPosixFiles_mc.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles_mg.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles_mp.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles_mr.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles_mt.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles_p.hi | 139 + ghc/lib/haskell-1.3/LibPosixFiles_t.hi | 139 + ghc/lib/haskell-1.3/LibPosixIO.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO.lhs | 258 + ghc/lib/haskell-1.3/LibPosixIO_mc.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO_mg.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO_mp.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO_mr.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO_mt.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO_p.hi | 33 + ghc/lib/haskell-1.3/LibPosixIO_t.hi | 33 + ghc/lib/haskell-1.3/LibPosixProcEnv.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv.lhs | 325 ++ ghc/lib/haskell-1.3/LibPosixProcEnv_mc.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv_mg.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv_mp.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv_mr.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv_mt.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv_p.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcEnv_t.hi | 75 + ghc/lib/haskell-1.3/LibPosixProcPrim.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim.lhs | 543 ++ ghc/lib/haskell-1.3/LibPosixProcPrim_mc.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim_mg.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim_mp.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim_mr.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim_mt.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim_p.hi | 193 + ghc/lib/haskell-1.3/LibPosixProcPrim_t.hi | 193 + ghc/lib/haskell-1.3/LibPosixTTY.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY.lhs | 578 +++ ghc/lib/haskell-1.3/LibPosixTTY_mc.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY_mg.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY_mp.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY_mr.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY_mt.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY_p.hi | 62 + ghc/lib/haskell-1.3/LibPosixTTY_t.hi | 62 + ghc/lib/haskell-1.3/LibPosixUtil.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil.lhs | 123 + ghc/lib/haskell-1.3/LibPosixUtil_mc.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil_mg.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil_mp.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil_mr.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil_mt.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil_p.hi | 34 + ghc/lib/haskell-1.3/LibPosixUtil_t.hi | 34 + ghc/lib/haskell-1.3/LibPosix_mc.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix_mg.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix_mp.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix_mr.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix_mt.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix_p.hi | 667 +++ ghc/lib/haskell-1.3/LibPosix_t.hi | 667 +++ ghc/lib/haskell-1.3/LibSystem.hi | 35 + ghc/lib/haskell-1.3/LibSystem.lhs | 103 + ghc/lib/haskell-1.3/LibSystem_mc.hi | 35 + ghc/lib/haskell-1.3/LibSystem_mg.hi | 35 + ghc/lib/haskell-1.3/LibSystem_mp.hi | 35 + ghc/lib/haskell-1.3/LibSystem_mr.hi | 35 + ghc/lib/haskell-1.3/LibSystem_mt.hi | 35 + ghc/lib/haskell-1.3/LibSystem_p.hi | 35 + ghc/lib/haskell-1.3/LibSystem_t.hi | 35 + ghc/lib/haskell-1.3/LibTime.hi | 52 + ghc/lib/haskell-1.3/LibTime.lhs | 232 + ghc/lib/haskell-1.3/LibTime_mc.hi | 52 + ghc/lib/haskell-1.3/LibTime_mg.hi | 52 + ghc/lib/haskell-1.3/LibTime_mp.hi | 52 + ghc/lib/haskell-1.3/LibTime_mr.hi | 52 + ghc/lib/haskell-1.3/LibTime_mt.hi | 52 + ghc/lib/haskell-1.3/LibTime_p.hi | 52 + ghc/lib/haskell-1.3/LibTime_t.hi | 52 + ghc/lib/hbc/Algebra.hi | 162 + ghc/lib/hbc/Algebra.hs | 145 + ghc/lib/hbc/Algebra_mc.hi | 162 + ghc/lib/hbc/Algebra_mg.hi | 162 + ghc/lib/hbc/Algebra_mp.hi | 162 + ghc/lib/hbc/Algebra_mr.hi | 162 + ghc/lib/hbc/Algebra_mt.hi | 162 + ghc/lib/hbc/Algebra_p.hi | 162 + ghc/lib/hbc/Algebra_t.hi | 162 + ghc/lib/hbc/Hash.hi | 69 + ghc/lib/hbc/Hash.hs | 100 + ghc/lib/hbc/Hash_mc.hi | 69 + ghc/lib/hbc/Hash_mg.hi | 69 + ghc/lib/hbc/Hash_mp.hi | 69 + ghc/lib/hbc/Hash_mr.hi | 69 + ghc/lib/hbc/Hash_mt.hi | 69 + ghc/lib/hbc/Hash_p.hi | 69 + ghc/lib/hbc/Hash_t.hi | 69 + ghc/lib/hbc/ListUtil.hi | 36 + ghc/lib/hbc/ListUtil.hs | 109 + ghc/lib/hbc/ListUtil_mc.hi | 36 + ghc/lib/hbc/ListUtil_mg.hi | 36 + ghc/lib/hbc/ListUtil_mp.hi | 36 + ghc/lib/hbc/ListUtil_mr.hi | 36 + ghc/lib/hbc/ListUtil_mt.hi | 36 + ghc/lib/hbc/ListUtil_p.hi | 36 + ghc/lib/hbc/ListUtil_t.hi | 36 + ghc/lib/hbc/Miranda.hi | 24 + ghc/lib/hbc/Miranda.hs | 90 + ghc/lib/hbc/Miranda_mc.hi | 24 + ghc/lib/hbc/Miranda_mg.hi | 24 + ghc/lib/hbc/Miranda_mp.hi | 24 + ghc/lib/hbc/Miranda_mr.hi | 24 + ghc/lib/hbc/Miranda_mt.hi | 24 + ghc/lib/hbc/Miranda_p.hi | 24 + ghc/lib/hbc/Miranda_t.hi | 24 + ghc/lib/hbc/NameSupply.hi | 13 + ghc/lib/hbc/NameSupply.hs | 67 + ghc/lib/hbc/NameSupply_mc.hi | 13 + ghc/lib/hbc/NameSupply_mg.hi | 13 + ghc/lib/hbc/NameSupply_mp.hi | 13 + ghc/lib/hbc/NameSupply_mr.hi | 13 + ghc/lib/hbc/NameSupply_mt.hi | 13 + ghc/lib/hbc/NameSupply_p.hi | 13 + ghc/lib/hbc/NameSupply_t.hi | 13 + ghc/lib/hbc/Native.hi | 71 + ghc/lib/hbc/Native.hs | 356 ++ ghc/lib/hbc/Native_mc.hi | 71 + ghc/lib/hbc/Native_mg.hi | 71 + ghc/lib/hbc/Native_mp.hi | 71 + ghc/lib/hbc/Native_mr.hi | 71 + ghc/lib/hbc/Native_mt.hi | 71 + ghc/lib/hbc/Native_p.hi | 71 + ghc/lib/hbc/Native_t.hi | 71 + ghc/lib/hbc/Number.hi | 103 + ghc/lib/hbc/Number.hs | 124 + ghc/lib/hbc/Number_mc.hi | 103 + ghc/lib/hbc/Number_mg.hi | 103 + ghc/lib/hbc/Number_mp.hi | 103 + ghc/lib/hbc/Number_mr.hi | 103 + ghc/lib/hbc/Number_mt.hi | 103 + ghc/lib/hbc/Number_p.hi | 103 + ghc/lib/hbc/Number_t.hi | 103 + ghc/lib/hbc/Parse.hi | 69 + ghc/lib/hbc/Parse.hs | 293 ++ ghc/lib/hbc/Parse_mc.hi | 69 + ghc/lib/hbc/Parse_mg.hi | 69 + ghc/lib/hbc/Parse_mp.hi | 69 + ghc/lib/hbc/Parse_mr.hi | 69 + ghc/lib/hbc/Parse_mt.hi | 69 + ghc/lib/hbc/Parse_p.hi | 69 + ghc/lib/hbc/Parse_t.hi | 69 + ghc/lib/hbc/Pretty.hi | 21 + ghc/lib/hbc/Pretty.hs | 86 + ghc/lib/hbc/Pretty_mc.hi | 21 + ghc/lib/hbc/Pretty_mg.hi | 21 + ghc/lib/hbc/Pretty_mp.hi | 21 + ghc/lib/hbc/Pretty_mr.hi | 21 + ghc/lib/hbc/Pretty_mt.hi | 21 + ghc/lib/hbc/Pretty_p.hi | 21 + ghc/lib/hbc/Pretty_t.hi | 21 + ghc/lib/hbc/Printf.hi | 6 + ghc/lib/hbc/Printf.hs | 221 + ghc/lib/hbc/Printf_mc.hi | 6 + ghc/lib/hbc/Printf_mg.hi | 6 + ghc/lib/hbc/Printf_mp.hi | 6 + ghc/lib/hbc/Printf_mr.hi | 6 + ghc/lib/hbc/Printf_mt.hi | 6 + ghc/lib/hbc/Printf_p.hi | 6 + ghc/lib/hbc/Printf_t.hi | 6 + ghc/lib/hbc/QSort.hi | 7 + ghc/lib/hbc/QSort.hs | 47 + ghc/lib/hbc/QSort_mc.hi | 7 + ghc/lib/hbc/QSort_mg.hi | 7 + ghc/lib/hbc/QSort_mp.hi | 7 + ghc/lib/hbc/QSort_mr.hi | 7 + ghc/lib/hbc/QSort_mt.hi | 7 + ghc/lib/hbc/QSort_p.hi | 7 + ghc/lib/hbc/QSort_t.hi | 7 + ghc/lib/hbc/Random.hi | 9 + ghc/lib/hbc/Random.hs | 59 + ghc/lib/hbc/Random_mc.hi | 9 + ghc/lib/hbc/Random_mg.hi | 9 + ghc/lib/hbc/Random_mp.hi | 9 + ghc/lib/hbc/Random_mr.hi | 9 + ghc/lib/hbc/Random_mt.hi | 9 + ghc/lib/hbc/Random_p.hi | 9 + ghc/lib/hbc/Random_t.hi | 9 + ghc/lib/hbc/SimpleLex.hi | 5 + ghc/lib/hbc/SimpleLex.hs | 26 + ghc/lib/hbc/SimpleLex_mc.hi | 5 + ghc/lib/hbc/SimpleLex_mg.hi | 5 + ghc/lib/hbc/SimpleLex_mp.hi | 5 + ghc/lib/hbc/SimpleLex_mr.hi | 5 + ghc/lib/hbc/SimpleLex_mt.hi | 5 + ghc/lib/hbc/SimpleLex_p.hi | 5 + ghc/lib/hbc/SimpleLex_t.hi | 5 + ghc/lib/hbc/Time.hi | 29 + ghc/lib/hbc/Time.hs | 53 + ghc/lib/hbc/Time_mc.hi | 29 + ghc/lib/hbc/Time_mg.hi | 29 + ghc/lib/hbc/Time_mp.hi | 29 + ghc/lib/hbc/Time_mr.hi | 29 + ghc/lib/hbc/Time_mt.hi | 29 + ghc/lib/hbc/Time_p.hi | 29 + ghc/lib/hbc/Time_t.hi | 29 + ghc/lib/hbc/Trace.hi | 5 + ghc/lib/hbc/Trace.hs | 2 + ghc/lib/hbc/Trace_mc.hi | 5 + ghc/lib/hbc/Trace_mg.hi | 5 + ghc/lib/hbc/Trace_mp.hi | 5 + ghc/lib/hbc/Trace_p.hi | 5 + ghc/lib/hbc/Trace_t.hi | 5 + ghc/lib/hbc/Word.hi | 171 + ghc/lib/hbc/Word.hs | 156 + ghc/lib/hbc/Word_mc.hi | 171 + ghc/lib/hbc/Word_mg.hi | 171 + ghc/lib/hbc/Word_mp.hi | 171 + ghc/lib/hbc/Word_mr.hi | 171 + ghc/lib/hbc/Word_mt.hi | 171 + ghc/lib/hbc/Word_p.hi | 171 + ghc/lib/hbc/Word_t.hi | 171 + ghc/lib/make_extra_deps | 31 + ghc/lib/prelude/Builtin.hi | 13 + ghc/lib/prelude/Builtin.hs | 114 + ghc/lib/prelude/Builtin_mc.hi | 13 + ghc/lib/prelude/Builtin_mg.hi | 13 + ghc/lib/prelude/Builtin_mp.hi | 13 + ghc/lib/prelude/Builtin_mr.hi | 13 + ghc/lib/prelude/Builtin_mt.hi | 13 + ghc/lib/prelude/Builtin_p.hi | 13 + ghc/lib/prelude/Builtin_t.hi | 13 + ghc/lib/prelude/Channel.hi | 19 + ghc/lib/prelude/Channel.lhs | 120 + ghc/lib/prelude/ChannelVar.hi | 14 + ghc/lib/prelude/ChannelVar.lhs | 58 + ghc/lib/prelude/ChannelVar_mc.hi | 14 + ghc/lib/prelude/ChannelVar_mg.hi | 14 + ghc/lib/prelude/ChannelVar_mp.hi | 14 + ghc/lib/prelude/ChannelVar_p.hi | 14 + ghc/lib/prelude/ChannelVar_t.hi | 14 + ghc/lib/prelude/Channel_mc.hi | 19 + ghc/lib/prelude/Channel_mg.hi | 19 + ghc/lib/prelude/Channel_mp.hi | 19 + ghc/lib/prelude/Channel_p.hi | 19 + ghc/lib/prelude/Channel_t.hi | 19 + ghc/lib/prelude/Cls.hi | 248 + ghc/lib/prelude/Cls.hs | 200 + ghc/lib/prelude/Cls_mc.hi | 248 + ghc/lib/prelude/Cls_mg.hi | 248 + ghc/lib/prelude/Cls_mp.hi | 248 + ghc/lib/prelude/Cls_mr.hi | 248 + ghc/lib/prelude/Cls_mt.hi | 248 + ghc/lib/prelude/Cls_p.hi | 248 + ghc/lib/prelude/Cls_t.hi | 248 + ghc/lib/prelude/Concurrent.hi | 93 + ghc/lib/prelude/Concurrent.lhs | 59 + ghc/lib/prelude/Concurrent_mc.hi | 93 + ghc/lib/prelude/Concurrent_mg.hi | 93 + ghc/lib/prelude/Concurrent_mp.hi | 93 + ghc/lib/prelude/Concurrent_p.hi | 93 + ghc/lib/prelude/Concurrent_t.hi | 93 + ghc/lib/prelude/Core.hi | 45 + ghc/lib/prelude/Core.hs | 326 ++ ghc/lib/prelude/Core_mc.hi | 45 + ghc/lib/prelude/Core_mg.hi | 45 + ghc/lib/prelude/Core_mp.hi | 45 + ghc/lib/prelude/Core_mr.hi | 45 + ghc/lib/prelude/Core_mt.hi | 45 + ghc/lib/prelude/Core_p.hi | 45 + ghc/lib/prelude/Core_t.hi | 45 + ghc/lib/prelude/FoldrBuild.hs | 20 + ghc/lib/prelude/IArray.hi | 45 + ghc/lib/prelude/IArray.hs | 285 ++ ghc/lib/prelude/IArray_mc.hi | 45 + ghc/lib/prelude/IArray_mg.hi | 45 + ghc/lib/prelude/IArray_mp.hi | 45 + ghc/lib/prelude/IArray_mr.hi | 45 + ghc/lib/prelude/IArray_mt.hi | 45 + ghc/lib/prelude/IArray_p.hi | 45 + ghc/lib/prelude/IArray_t.hi | 45 + ghc/lib/prelude/IBool.hi | 33 + ghc/lib/prelude/IBool.hs | 71 + ghc/lib/prelude/IBool_mc.hi | 33 + ghc/lib/prelude/IBool_mg.hi | 33 + ghc/lib/prelude/IBool_mp.hi | 33 + ghc/lib/prelude/IBool_mr.hi | 33 + ghc/lib/prelude/IBool_mt.hi | 33 + ghc/lib/prelude/IBool_p.hi | 33 + ghc/lib/prelude/IBool_t.hi | 33 + ghc/lib/prelude/IChar.hi | 38 + ghc/lib/prelude/IChar.hs | 123 + ghc/lib/prelude/IChar_mc.hi | 38 + ghc/lib/prelude/IChar_mg.hi | 38 + ghc/lib/prelude/IChar_mp.hi | 38 + ghc/lib/prelude/IChar_mr.hi | 38 + ghc/lib/prelude/IChar_mt.hi | 38 + ghc/lib/prelude/IChar_p.hi | 38 + ghc/lib/prelude/IChar_t.hi | 38 + ghc/lib/prelude/IComplex.hi | 70 + ghc/lib/prelude/IComplex.hs | 168 + ghc/lib/prelude/IComplex_mc.hi | 70 + ghc/lib/prelude/IComplex_mg.hi | 70 + ghc/lib/prelude/IComplex_mp.hi | 70 + ghc/lib/prelude/IComplex_mr.hi | 70 + ghc/lib/prelude/IComplex_mt.hi | 70 + ghc/lib/prelude/IComplex_p.hi | 70 + ghc/lib/prelude/IComplex_t.hi | 70 + ghc/lib/prelude/IDouble.hi | 88 + ghc/lib/prelude/IDouble.hs | 299 ++ ghc/lib/prelude/IDouble_mc.hi | 88 + ghc/lib/prelude/IDouble_mg.hi | 88 + ghc/lib/prelude/IDouble_mp.hi | 88 + ghc/lib/prelude/IDouble_mr.hi | 88 + ghc/lib/prelude/IDouble_mt.hi | 88 + ghc/lib/prelude/IDouble_p.hi | 88 + ghc/lib/prelude/IDouble_t.hi | 88 + ghc/lib/prelude/IFloat.hi | 88 + ghc/lib/prelude/IFloat.hs | 154 + ghc/lib/prelude/IFloat_mc.hi | 88 + ghc/lib/prelude/IFloat_mg.hi | 88 + ghc/lib/prelude/IFloat_mp.hi | 88 + ghc/lib/prelude/IFloat_mr.hi | 88 + ghc/lib/prelude/IFloat_mt.hi | 88 + ghc/lib/prelude/IFloat_p.hi | 88 + ghc/lib/prelude/IFloat_t.hi | 88 + ghc/lib/prelude/IInt.hi | 110 + ghc/lib/prelude/IInt.hs | 299 ++ ghc/lib/prelude/IInt_mc.hi | 110 + ghc/lib/prelude/IInt_mg.hi | 110 + ghc/lib/prelude/IInt_mp.hi | 106 + ghc/lib/prelude/IInt_mr.hi | 110 + ghc/lib/prelude/IInt_mt.hi | 110 + ghc/lib/prelude/IInt_p.hi | 110 + ghc/lib/prelude/IInt_t.hi | 110 + ghc/lib/prelude/IInteger.hi | 67 + ghc/lib/prelude/IInteger.hs | 162 + ghc/lib/prelude/IInteger_mc.hi | 67 + ghc/lib/prelude/IInteger_mg.hi | 67 + ghc/lib/prelude/IInteger_mp.hi | 67 + ghc/lib/prelude/IInteger_mr.hi | 67 + ghc/lib/prelude/IInteger_mt.hi | 67 + ghc/lib/prelude/IInteger_p.hi | 67 + ghc/lib/prelude/IInteger_t.hi | 67 + ghc/lib/prelude/IList.hi | 52 + ghc/lib/prelude/IList.hs | 63 + ghc/lib/prelude/IList_mc.hi | 52 + ghc/lib/prelude/IList_mg.hi | 52 + ghc/lib/prelude/IList_mp.hi | 52 + ghc/lib/prelude/IList_mr.hi | 52 + ghc/lib/prelude/IList_mt.hi | 52 + ghc/lib/prelude/IList_p.hi | 52 + ghc/lib/prelude/IList_t.hi | 52 + ghc/lib/prelude/IO.hi | 71 + ghc/lib/prelude/IO.hs | 137 + ghc/lib/prelude/IO_mc.hi | 71 + ghc/lib/prelude/IO_mg.hi | 71 + ghc/lib/prelude/IO_mp.hi | 71 + ghc/lib/prelude/IO_mr.hi | 71 + ghc/lib/prelude/IO_mt.hi | 71 + ghc/lib/prelude/IO_p.hi | 71 + ghc/lib/prelude/IO_t.hi | 71 + ghc/lib/prelude/IRatio.hi | 83 + ghc/lib/prelude/IRatio.hs | 156 + ghc/lib/prelude/IRatio_mc.hi | 83 + ghc/lib/prelude/IRatio_mg.hi | 83 + ghc/lib/prelude/IRatio_mp.hi | 83 + ghc/lib/prelude/IRatio_mr.hi | 83 + ghc/lib/prelude/IRatio_mt.hi | 83 + ghc/lib/prelude/IRatio_p.hi | 83 + ghc/lib/prelude/IRatio_t.hi | 83 + ghc/lib/prelude/ITup0.hi | 34 + ghc/lib/prelude/ITup0.hs | 43 + ghc/lib/prelude/ITup0_mc.hi | 34 + ghc/lib/prelude/ITup0_mg.hi | 34 + ghc/lib/prelude/ITup0_mp.hi | 34 + ghc/lib/prelude/ITup0_mr.hi | 34 + ghc/lib/prelude/ITup0_mt.hi | 34 + ghc/lib/prelude/ITup0_p.hi | 34 + ghc/lib/prelude/ITup0_t.hi | 34 + ghc/lib/prelude/ITup2.hi | 56 + ghc/lib/prelude/ITup2.hs | 69 + ghc/lib/prelude/ITup2_mc.hi | 56 + ghc/lib/prelude/ITup2_mg.hi | 56 + ghc/lib/prelude/ITup2_mp.hi | 56 + ghc/lib/prelude/ITup2_mr.hi | 56 + ghc/lib/prelude/ITup2_mt.hi | 56 + ghc/lib/prelude/ITup2_p.hi | 56 + ghc/lib/prelude/ITup2_t.hi | 56 + ghc/lib/prelude/ITup3.hi | 12 + ghc/lib/prelude/ITup3.hs | 91 + ghc/lib/prelude/ITup3_mc.hi | 12 + ghc/lib/prelude/ITup3_mg.hi | 12 + ghc/lib/prelude/ITup3_mp.hi | 12 + ghc/lib/prelude/ITup3_mr.hi | 12 + ghc/lib/prelude/ITup3_mt.hi | 12 + ghc/lib/prelude/ITup3_p.hi | 12 + ghc/lib/prelude/ITup3_t.hi | 12 + ghc/lib/prelude/ITup4.hi | 12 + ghc/lib/prelude/ITup4.hs | 100 + ghc/lib/prelude/ITup4_mc.hi | 12 + ghc/lib/prelude/ITup4_mg.hi | 12 + ghc/lib/prelude/ITup4_mp.hi | 12 + ghc/lib/prelude/ITup4_mr.hi | 12 + ghc/lib/prelude/ITup4_mt.hi | 12 + ghc/lib/prelude/ITup4_p.hi | 12 + ghc/lib/prelude/ITup4_t.hi | 12 + ghc/lib/prelude/ITup5.hi | 12 + ghc/lib/prelude/ITup5.hs | 109 + ghc/lib/prelude/ITup5_mc.hi | 12 + ghc/lib/prelude/ITup5_mg.hi | 12 + ghc/lib/prelude/ITup5_mp.hi | 12 + ghc/lib/prelude/ITup5_mr.hi | 12 + ghc/lib/prelude/ITup5_mt.hi | 12 + ghc/lib/prelude/ITup5_p.hi | 12 + ghc/lib/prelude/ITup5_t.hi | 12 + ghc/lib/prelude/List.hi | 139 + ghc/lib/prelude/List.hs | 799 +++ ghc/lib/prelude/List_mc.hi | 139 + ghc/lib/prelude/List_mg.hi | 139 + ghc/lib/prelude/List_mp.hi | 139 + ghc/lib/prelude/List_mr.hi | 139 + ghc/lib/prelude/List_mt.hi | 139 + ghc/lib/prelude/List_p.hi | 139 + ghc/lib/prelude/List_t.hi | 139 + ghc/lib/prelude/Merge.hi | 9 + ghc/lib/prelude/Merge.lhs | 117 + ghc/lib/prelude/Merge_mc.hi | 9 + ghc/lib/prelude/Merge_mg.hi | 9 + ghc/lib/prelude/Merge_mp.hi | 9 + ghc/lib/prelude/Merge_p.hi | 9 + ghc/lib/prelude/Merge_t.hi | 9 + ghc/lib/prelude/PS.hi | 104 + ghc/lib/prelude/PS.lhs | 681 +++ ghc/lib/prelude/PS_mc.hi | 104 + ghc/lib/prelude/PS_mg.hi | 104 + ghc/lib/prelude/PS_mp.hi | 104 + ghc/lib/prelude/PS_mr.hi | 104 + ghc/lib/prelude/PS_mt.hi | 104 + ghc/lib/prelude/PS_p.hi | 104 + ghc/lib/prelude/PS_t.hi | 104 + ghc/lib/prelude/Parallel.hi | 9 + ghc/lib/prelude/Parallel.lhs | 35 + ghc/lib/prelude/Parallel_mc.hi | 9 + ghc/lib/prelude/Parallel_mg.hi | 9 + ghc/lib/prelude/Parallel_mp.hi | 9 + ghc/lib/prelude/Parallel_p.hi | 9 + ghc/lib/prelude/Parallel_t.hi | 9 + ghc/lib/prelude/Prel.hi | 87 + ghc/lib/prelude/Prel.hs | 410 ++ ghc/lib/prelude/Prel13.hi | 509 ++ ghc/lib/prelude/Prel13.hs | 191 + ghc/lib/prelude/Prel13_mc.hi | 509 ++ ghc/lib/prelude/Prel13_mg.hi | 509 ++ ghc/lib/prelude/Prel13_mp.hi | 509 ++ ghc/lib/prelude/Prel13_mr.hi | 509 ++ ghc/lib/prelude/Prel13_mt.hi | 509 ++ ghc/lib/prelude/Prel13_p.hi | 509 ++ ghc/lib/prelude/Prel13_t.hi | 509 ++ ghc/lib/prelude/PrelCore13.hi | 994 ++++ ghc/lib/prelude/PrelCore13.hs | 69 + ghc/lib/prelude/PrelCore13_mc.hi | 994 ++++ ghc/lib/prelude/PrelCore13_mg.hi | 994 ++++ ghc/lib/prelude/PrelCore13_mp.hi | 990 ++++ ghc/lib/prelude/PrelCore13_mr.hi | 994 ++++ ghc/lib/prelude/PrelCore13_mt.hi | 994 ++++ ghc/lib/prelude/PrelCore13_p.hi | 994 ++++ ghc/lib/prelude/PrelCore13_t.hi | 994 ++++ ghc/lib/prelude/PrelCoreHi.hs | 57 + ghc/lib/prelude/Prel_mc.hi | 87 + ghc/lib/prelude/Prel_mg.hi | 87 + ghc/lib/prelude/Prel_mp.hi | 87 + ghc/lib/prelude/Prel_mr.hi | 87 + ghc/lib/prelude/Prel_mt.hi | 87 + ghc/lib/prelude/Prel_p.hi | 87 + ghc/lib/prelude/Prel_t.hi | 87 + ghc/lib/prelude/Prelude.hi | 463 ++ ghc/lib/prelude/PreludeCore.hi | 971 ++++ ghc/lib/prelude/PreludeCore_mc.hi | 971 ++++ ghc/lib/prelude/PreludeCore_mg.hi | 971 ++++ ghc/lib/prelude/PreludeCore_mp.hi | 967 ++++ ghc/lib/prelude/PreludeCore_mr.hi | 971 ++++ ghc/lib/prelude/PreludeCore_mt.hi | 971 ++++ ghc/lib/prelude/PreludeCore_p.hi | 971 ++++ ghc/lib/prelude/PreludeCore_t.hi | 971 ++++ ghc/lib/prelude/PreludeHi.hs | 97 + ghc/lib/prelude/PreludeIO.hi | 137 + ghc/lib/prelude/PreludeIO.lhs | 100 + ghc/lib/prelude/PreludeIOError.hi | 14 + ghc/lib/prelude/PreludeIOError.lhs | 107 + ghc/lib/prelude/PreludeIOError_mc.hi | 14 + ghc/lib/prelude/PreludeIOError_mg.hi | 14 + ghc/lib/prelude/PreludeIOError_mp.hi | 14 + ghc/lib/prelude/PreludeIOError_mr.hi | 14 + ghc/lib/prelude/PreludeIOError_mt.hi | 14 + ghc/lib/prelude/PreludeIOError_p.hi | 14 + ghc/lib/prelude/PreludeIOError_t.hi | 14 + ghc/lib/prelude/PreludeIO_mc.hi | 137 + ghc/lib/prelude/PreludeIO_mg.hi | 137 + ghc/lib/prelude/PreludeIO_mp.hi | 137 + ghc/lib/prelude/PreludeIO_mr.hi | 137 + ghc/lib/prelude/PreludeIO_mt.hi | 137 + ghc/lib/prelude/PreludeIO_p.hi | 137 + ghc/lib/prelude/PreludeIO_t.hi | 137 + ghc/lib/prelude/PreludeMonadicIO.hi | 36 + ghc/lib/prelude/PreludeMonadicIO.lhs | 204 + ghc/lib/prelude/PreludeMonadicIO_mc.hi | 36 + ghc/lib/prelude/PreludeMonadicIO_mg.hi | 36 + ghc/lib/prelude/PreludeMonadicIO_mp.hi | 36 + ghc/lib/prelude/PreludeMonadicIO_mr.hi | 36 + ghc/lib/prelude/PreludeMonadicIO_mt.hi | 36 + ghc/lib/prelude/PreludeMonadicIO_p.hi | 36 + ghc/lib/prelude/PreludeMonadicIO_t.hi | 36 + ghc/lib/prelude/PreludeNull_.hi | 4 + ghc/lib/prelude/PreludeNull__1s.hi | 4 + ghc/lib/prelude/PreludeNull__2s.hi | 4 + ghc/lib/prelude/PreludeNull__du.hi | 4 + ghc/lib/prelude/PreludeNull__i.hi | 4 + ghc/lib/prelude/PreludeNull__j.hi | 4 + ghc/lib/prelude/PreludeNull__k.hi | 4 + ghc/lib/prelude/PreludeNull__l.hi | 4 + ghc/lib/prelude/PreludeNull__m.hi | 4 + ghc/lib/prelude/PreludeNull__mc.hi | 4 + ghc/lib/prelude/PreludeNull__mg.hi | 4 + ghc/lib/prelude/PreludeNull__mp.hi | 4 + ghc/lib/prelude/PreludeNull__mr.hi | 4 + ghc/lib/prelude/PreludeNull__mt.hi | 4 + ghc/lib/prelude/PreludeNull__n.hi | 4 + ghc/lib/prelude/PreludeNull__o.hi | 4 + ghc/lib/prelude/PreludeNull__p.hi | 4 + ghc/lib/prelude/PreludeNull__t.hi | 4 + ghc/lib/prelude/PreludeReadTextIO.hi | 21 + ghc/lib/prelude/PreludeReadTextIO.lhs | 311 ++ ghc/lib/prelude/PreludeReadTextIO_mc.hi | 21 + ghc/lib/prelude/PreludeReadTextIO_mg.hi | 21 + ghc/lib/prelude/PreludeReadTextIO_mp.hi | 21 + ghc/lib/prelude/PreludeReadTextIO_mr.hi | 21 + ghc/lib/prelude/PreludeReadTextIO_mt.hi | 21 + ghc/lib/prelude/PreludeReadTextIO_p.hi | 21 + ghc/lib/prelude/PreludeReadTextIO_t.hi | 21 + ghc/lib/prelude/PreludeStdIO.hi | 72 + ghc/lib/prelude/PreludeStdIO.lhs | 918 ++++ ghc/lib/prelude/PreludeStdIO_mc.hi | 72 + ghc/lib/prelude/PreludeStdIO_mg.hi | 72 + ghc/lib/prelude/PreludeStdIO_mp.hi | 72 + ghc/lib/prelude/PreludeStdIO_mr.hi | 72 + ghc/lib/prelude/PreludeStdIO_mt.hi | 72 + ghc/lib/prelude/PreludeStdIO_p.hi | 72 + ghc/lib/prelude/PreludeStdIO_t.hi | 72 + ghc/lib/prelude/PreludeWriteTextIO.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO.lhs | 190 + ghc/lib/prelude/PreludeWriteTextIO_mc.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO_mg.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO_mp.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO_mr.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO_mt.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO_p.hi | 27 + ghc/lib/prelude/PreludeWriteTextIO_t.hi | 27 + ghc/lib/prelude/Prelude_mc.hi | 463 ++ ghc/lib/prelude/Prelude_mg.hi | 463 ++ ghc/lib/prelude/Prelude_mp.hi | 463 ++ ghc/lib/prelude/Prelude_mr.hi | 463 ++ ghc/lib/prelude/Prelude_mt.hi | 463 ++ ghc/lib/prelude/Prelude_p.hi | 463 ++ ghc/lib/prelude/Prelude_t.hi | 463 ++ ghc/lib/prelude/SampleVar.hi | 15 + ghc/lib/prelude/SampleVar.lhs | 95 + ghc/lib/prelude/SampleVar_mc.hi | 15 + ghc/lib/prelude/SampleVar_mg.hi | 15 + ghc/lib/prelude/SampleVar_mp.hi | 15 + ghc/lib/prelude/SampleVar_p.hi | 15 + ghc/lib/prelude/SampleVar_t.hi | 15 + ghc/lib/prelude/Semaphore.hi | 20 + ghc/lib/prelude/Semaphore.lhs | 122 + ghc/lib/prelude/Semaphore_mc.hi | 20 + ghc/lib/prelude/Semaphore_mg.hi | 20 + ghc/lib/prelude/Semaphore_mp.hi | 20 + ghc/lib/prelude/Semaphore_p.hi | 20 + ghc/lib/prelude/Semaphore_t.hi | 20 + ghc/lib/prelude/Text.hi | 56 + ghc/lib/prelude/Text.hs | 461 ++ ghc/lib/prelude/Text_mc.hi | 56 + ghc/lib/prelude/Text_mg.hi | 56 + ghc/lib/prelude/Text_mp.hi | 56 + ghc/lib/prelude/Text_mr.hi | 56 + ghc/lib/prelude/Text_mt.hi | 56 + ghc/lib/prelude/Text_p.hi | 56 + ghc/lib/prelude/Text_t.hi | 56 + ghc/lib/prelude/TyArray.hi | 10 + ghc/lib/prelude/TyArray.hs | 27 + ghc/lib/prelude/TyArray_mc.hi | 10 + ghc/lib/prelude/TyArray_mg.hi | 10 + ghc/lib/prelude/TyArray_mp.hi | 10 + ghc/lib/prelude/TyArray_mr.hi | 10 + ghc/lib/prelude/TyArray_mt.hi | 10 + ghc/lib/prelude/TyArray_p.hi | 10 + ghc/lib/prelude/TyArray_t.hi | 10 + ghc/lib/prelude/TyBool.hs | 5 + ghc/lib/prelude/TyComplex.hi | 4 + ghc/lib/prelude/TyComplex.hs | 10 + ghc/lib/prelude/TyComplex_mc.hi | 4 + ghc/lib/prelude/TyComplex_mg.hi | 4 + ghc/lib/prelude/TyComplex_mp.hi | 4 + ghc/lib/prelude/TyComplex_mr.hi | 4 + ghc/lib/prelude/TyComplex_mt.hi | 4 + ghc/lib/prelude/TyComplex_p.hi | 4 + ghc/lib/prelude/TyComplex_t.hi | 4 + ghc/lib/prelude/TyIO.hi | 15 + ghc/lib/prelude/TyIO.hs | 63 + ghc/lib/prelude/TyIO_mc.hi | 15 + ghc/lib/prelude/TyIO_mg.hi | 15 + ghc/lib/prelude/TyIO_mp.hi | 15 + ghc/lib/prelude/TyIO_mr.hi | 15 + ghc/lib/prelude/TyIO_mt.hi | 15 + ghc/lib/prelude/TyIO_p.hi | 15 + ghc/lib/prelude/TyIO_t.hi | 15 + ghc/lib/prelude/TyRatio.hs | 10 + ghc/lib/prelude/TysBasic.hs | 204 + ghc/lib/prelude/UTypes.hi | 9 + ghc/lib/prelude/UTypes_1s.hi | 9 + ghc/lib/prelude/UTypes_2s.hi | 9 + ghc/lib/prelude/UTypes_du.hi | 9 + ghc/lib/prelude/UTypes_i.hi | 9 + ghc/lib/prelude/UTypes_j.hi | 9 + ghc/lib/prelude/UTypes_k.hi | 9 + ghc/lib/prelude/UTypes_l.hi | 9 + ghc/lib/prelude/UTypes_m.hi | 9 + ghc/lib/prelude/UTypes_mc.hi | 9 + ghc/lib/prelude/UTypes_mg.hi | 9 + ghc/lib/prelude/UTypes_mp.hi | 9 + ghc/lib/prelude/UTypes_mr.hi | 9 + ghc/lib/prelude/UTypes_mt.hi | 9 + ghc/lib/prelude/UTypes_n.hi | 9 + ghc/lib/prelude/UTypes_o.hi | 9 + ghc/lib/prelude/UTypes_p.hi | 9 + ghc/lib/prelude/UTypes_t.hi | 9 + ghc/misc/examples/cats/ccat4.c | 18 + ghc/misc/examples/cats/ccat5.c | 16 + ghc/misc/examples/cats/hcat1.hs | 4 + ghc/misc/examples/cats/hcat2.hs | 10 + ghc/misc/examples/cats/hcat3.hs | 17 + ghc/misc/examples/cats/hcat4.hs | 20 + ghc/misc/examples/cats/hcat5.hs | 19 + ghc/misc/examples/cats/hcat6.hs | 18 + ghc/misc/examples/cats/mangle_times | 23 + ghc/misc/examples/hsh/Hsh.hs | 284 ++ ghc/misc/examples/io/io001/Main.hs | 1 + ghc/misc/examples/io/io002/Main.hs | 12 + ghc/misc/examples/io/io003/Main.hs | 9 + ghc/misc/examples/io/io004/Main.hs | 3 + ghc/misc/examples/io/io005/Main.hs | 11 + ghc/misc/examples/io/io006/Main.hs | 4 + ghc/misc/examples/io/io007/Main.hs | 6 + ghc/misc/examples/io/io008/Main.hs | 18 + ghc/misc/examples/io/io009/Main.hs | 7 + ghc/misc/examples/io/io010/Main.hs | 20 + ghc/misc/examples/io/io011/Main.hs | 15 + ghc/misc/examples/io/io012/Main.hs | 16 + ghc/misc/examples/io/io013/Main.hs | 17 + ghc/misc/examples/io/io014/Main.hs | 22 + ghc/misc/examples/io/io015/Main.hs | 8 + ghc/misc/examples/io/io016/Main.hs | 18 + ghc/misc/examples/io/io017/Main.hs | 17 + ghc/misc/examples/io/io018/Main.hs | 23 + ghc/misc/examples/io/io019/Main.hs | 23 + ghc/misc/examples/io/io020/Main.hs | 13 + ghc/misc/examples/io/io021/Main.hs | 4 + ghc/misc/examples/net001/Main.hs | 55 + ghc/misc/examples/net002/Main.hs | 42 + ghc/misc/examples/net003/Main.hs | 43 + ghc/misc/examples/net004/Main.hs | 33 + ghc/misc/examples/net005/Main.hs | 37 + ghc/misc/examples/net006/Main.hs | 27 + ghc/misc/examples/net007/Main.hs | 44 + ghc/misc/examples/net008/Main.hs | 22 + ghc/misc/examples/nfib/nfibD.hs | 10 + ghc/misc/examples/nfib/nfibF.hs | 10 + ghc/misc/examples/nfib/nfibI.hs | 10 + ghc/misc/examples/nfib/nfibJ.hs | 10 + ghc/misc/examples/nfib/nfibO.hs | 10 + ghc/misc/examples/nfib/nfibR.hs | 10 + ghc/misc/examples/posix/po001/Main.hs | 23 + ghc/misc/examples/posix/po002/Main.hs | 4 + ghc/misc/examples/posix/po003/Main.hs | 5 + ghc/misc/examples/posix/po004/Main.hs | 58 + ghc/misc/examples/posix/po005/Main.hs | 30 + ghc/misc/examples/posix/po006/Main.hs | 14 + ghc/misc/examples/posix/po007/Main.hs | 31 + ghc/misc/examples/posix/po008/Main.hs | 12 + ghc/misc/examples/posix/po009/Main.hs | 14 + ghc/misc/examples/posix/po010/Main.hs | 24 + ghc/misc/examples/posix/po011/Main.hs | 22 + ghc/misc/examples/posix/po012/Main.hs | 52 + ghc/misc/spat-analysers/README | 22 + ghc/misc/spat-analysers/REGSTATS | 18 + ghc/misc/spat-analysers/StgRegAddrs.h | 19 + ghc/misc/spat-analysers/icount.c | 91 + ghc/misc/spat-analysers/icount_by_activity.c | 396 ++ ghc/misc/spat-analysers/makefile | 19 + ghc/misc/spat-analysers/show_icounts | 354 ++ ghc/misc/spat-analysers/spatmain.c | 243 + ghc/misc/spat-analysers/stgregs.c | 121 + ghc/misc/test-arch.c | 37 + ghc/mkworld/GHC_OPTS | 32 + ghc/mkworld/install-ghc.ljm | 7 + ghc/mkworld/macros-ghc.ljm | 31 + ghc/mkworld/only4-ghc.ljm | 367 ++ ghc/mkworld/root.lit | 10 + ghc/mkworld/site-ghc.jm.in | 458 ++ ghc/mkworld/suffixes-ghc.ljm | 14 + ghc/mkworld/utils-ghc.ljm | 144 + ghc/runtime/Jmakefile | 532 ++ ghc/runtime/c-as-asm/CallWrap_C.lc | 246 + ghc/runtime/c-as-asm/FreeMallocPtr.lc | 21 + ghc/runtime/c-as-asm/HpOverflow.lc | 679 +++ ghc/runtime/c-as-asm/PerformIO.lhc | 244 + ghc/runtime/c-as-asm/StablePtr.lc | 234 + ghc/runtime/c-as-asm/StablePtrOps.lc | 144 + ghc/runtime/c-as-asm/StgDebug.lc | 1677 ++++++ ghc/runtime/c-as-asm/StgMiniInt.lc | 244 + ghc/runtime/gmp/COPYING | 339 ++ ghc/runtime/gmp/ChangeLog | 1347 +++++ ghc/runtime/gmp/INSTALL | 34 + ghc/runtime/gmp/Jmakefile | 108 + ghc/runtime/gmp/Makefile.original | 289 ++ ghc/runtime/gmp/README | 61 + ghc/runtime/gmp/TODO | 184 + ghc/runtime/gmp/VERSION | 1 + ghc/runtime/gmp/_mpz_get_str.c | 309 ++ ghc/runtime/gmp/_mpz_set_str.c | 258 + ghc/runtime/gmp/alloca.c | 467 ++ ghc/runtime/gmp/cre-conv-tab.c | 141 + ghc/runtime/gmp/cre-mparam.c | 118 + ghc/runtime/gmp/cre-stddefh.c | 42 + ghc/runtime/gmp/gmp-impl.h | 126 + ghc/runtime/gmp/gmp.h | 302 ++ ghc/runtime/gmp/gmp.texi | 1291 +++++ ghc/runtime/gmp/itom.c | 53 + ghc/runtime/gmp/longlong.h | 1027 ++++ ghc/runtime/gmp/mdiv.c | 38 + ghc/runtime/gmp/memory.c | 96 + ghc/runtime/gmp/mfree.c | 35 + ghc/runtime/gmp/min.c | 64 + ghc/runtime/gmp/mout.c | 42 + ghc/runtime/gmp/move.c | 45 + ghc/runtime/gmp/mp.h | 103 + ghc/runtime/gmp/mp_clz_tab.c | 36 + ghc/runtime/gmp/mp_set_fns.c | 47 + ghc/runtime/gmp/mpn_add.c | 141 + ghc/runtime/gmp/mpn_cmp.c | 52 + ghc/runtime/gmp/mpn_div.c | 321 ++ ghc/runtime/gmp/mpn_dm_1.c | 185 + ghc/runtime/gmp/mpn_lshift.c | 83 + ghc/runtime/gmp/mpn_mod_1.c | 104 + ghc/runtime/gmp/mpn_mul.c | 414 ++ ghc/runtime/gmp/mpn_mul_classic.c-EXTRA | 125 + ghc/runtime/gmp/mpn_rshift.c | 97 + ghc/runtime/gmp/mpn_rshiftci.c | 86 + ghc/runtime/gmp/mpn_sqrt.c | 479 ++ ghc/runtime/gmp/mpn_sub.c | 162 + ghc/runtime/gmp/mpq_add.c | 85 + ghc/runtime/gmp/mpq_clear.c | 34 + ghc/runtime/gmp/mpq_cmp.c | 76 + ghc/runtime/gmp/mpq_div.c | 92 + ghc/runtime/gmp/mpq_get_den.c | 40 + ghc/runtime/gmp/mpq_get_num.c | 41 + ghc/runtime/gmp/mpq_init.c | 39 + ghc/runtime/gmp/mpq_inv.c | 74 + ghc/runtime/gmp/mpq_mul.c | 78 + ghc/runtime/gmp/mpq_neg.c | 35 + ghc/runtime/gmp/mpq_set.c | 48 + ghc/runtime/gmp/mpq_set_den.c | 46 + ghc/runtime/gmp/mpq_set_num.c | 41 + ghc/runtime/gmp/mpq_set_si.c | 76 + ghc/runtime/gmp/mpq_set_ui.c | 73 + ghc/runtime/gmp/mpq_sub.c | 85 + ghc/runtime/gmp/mpz_abs.c | 44 + ghc/runtime/gmp/mpz_add.c | 121 + ghc/runtime/gmp/mpz_add_ui.c | 84 + ghc/runtime/gmp/mpz_and.c | 267 + ghc/runtime/gmp/mpz_clear.c | 34 + ghc/runtime/gmp/mpz_clrbit.c | 124 + ghc/runtime/gmp/mpz_cmp.c | 84 + ghc/runtime/gmp/mpz_cmp_si.c | 62 + ghc/runtime/gmp/mpz_cmp_ui.c | 52 + ghc/runtime/gmp/mpz_com.c | 96 + ghc/runtime/gmp/mpz_div.c | 117 + ghc/runtime/gmp/mpz_div_2exp.c | 53 + ghc/runtime/gmp/mpz_div_ui.c | 65 + ghc/runtime/gmp/mpz_dm.c | 38 + ghc/runtime/gmp/mpz_dm_ui.c | 81 + ghc/runtime/gmp/mpz_dmincl.c | 172 + ghc/runtime/gmp/mpz_fac_ui.c | 156 + ghc/runtime/gmp/mpz_gcd.c | 169 + ghc/runtime/gmp/mpz_gcdext.c | 80 + ghc/runtime/gmp/mpz_get_si.c | 40 + ghc/runtime/gmp/mpz_get_str.c | 39 + ghc/runtime/gmp/mpz_get_ui.c | 36 + ghc/runtime/gmp/mpz_init.c | 35 + ghc/runtime/gmp/mpz_inp_raw.c | 72 + ghc/runtime/gmp/mpz_inp_str.c | 105 + ghc/runtime/gmp/mpz_ior.c | 242 + ghc/runtime/gmp/mpz_iset.c | 45 + ghc/runtime/gmp/mpz_iset_si.c | 48 + ghc/runtime/gmp/mpz_iset_str.c | 42 + ghc/runtime/gmp/mpz_iset_ui.c | 43 + ghc/runtime/gmp/mpz_mdiv.c | 52 + ghc/runtime/gmp/mpz_mdiv_ui.c | 43 + ghc/runtime/gmp/mpz_mdm.c | 64 + ghc/runtime/gmp/mpz_mdm_ui.c | 58 + ghc/runtime/gmp/mpz_mmod.c | 60 + ghc/runtime/gmp/mpz_mmod_ui.c | 52 + ghc/runtime/gmp/mpz_mod.c | 36 + ghc/runtime/gmp/mpz_mod_2exp.c | 82 + ghc/runtime/gmp/mpz_mod_ui.c | 65 + ghc/runtime/gmp/mpz_mul.c | 114 + ghc/runtime/gmp/mpz_mul_2exp.c | 68 + ghc/runtime/gmp/mpz_mul_ui.c | 78 + ghc/runtime/gmp/mpz_neg.c | 46 + ghc/runtime/gmp/mpz_out_raw.c | 55 + ghc/runtime/gmp/mpz_out_str.c | 45 + ghc/runtime/gmp/mpz_perfsqr.c | 118 + ghc/runtime/gmp/mpz_pow_ui.c | 110 + ghc/runtime/gmp/mpz_powm.c | 251 + ghc/runtime/gmp/mpz_powm_ui.c | 219 + ghc/runtime/gmp/mpz_pprime_p.c | 108 + ghc/runtime/gmp/mpz_random.c | 72 + ghc/runtime/gmp/mpz_random2.c | 92 + ghc/runtime/gmp/mpz_realloc.c | 50 + ghc/runtime/gmp/mpz_set.c | 45 + ghc/runtime/gmp/mpz_set_si.c | 47 + ghc/runtime/gmp/mpz_set_str.c | 41 + ghc/runtime/gmp/mpz_set_ui.c | 42 + ghc/runtime/gmp/mpz_size.c | 34 + ghc/runtime/gmp/mpz_sizeinb.c | 59 + ghc/runtime/gmp/mpz_sqrt.c | 87 + ghc/runtime/gmp/mpz_sqrtrem.c | 105 + ghc/runtime/gmp/mpz_sub.c | 117 + ghc/runtime/gmp/mpz_sub_ui.c | 84 + ghc/runtime/gmp/mtox.c | 37 + ghc/runtime/gmp/sdiv.c | 76 + ghc/runtime/gmp/test-stddefh.c | 2 + ghc/runtime/gmp/xtom.c | 41 + ghc/runtime/griproot.lit | 57 + ghc/runtime/gum/FetchMe.lhc | 144 + ghc/runtime/gum/GlobAddr.lc | 362 ++ ghc/runtime/gum/HLComms.lc | 1150 +++++ ghc/runtime/gum/Hash.lc | 369 ++ ghc/runtime/gum/LLComms.lc | 438 ++ ghc/runtime/gum/Pack.lc | 896 ++++ ghc/runtime/gum/ParInit.lc | 171 + ghc/runtime/gum/RBH.lc | 157 + ghc/runtime/gum/Sparks.lc | 127 + ghc/runtime/gum/SysMan.lc | 252 + ghc/runtime/gum/Unpack.lc | 280 + ghc/runtime/hooks/ErrorHdr.lc | 10 + ghc/runtime/hooks/OutOfHeap.lc | 13 + ghc/runtime/hooks/OutOfStk.lc | 10 + ghc/runtime/hooks/OutOfVM.lc | 10 + ghc/runtime/hooks/PatErrorHdr.lc | 10 + ghc/runtime/hooks/TraceHooks.lc | 17 + ghc/runtime/io/closeFile.lc | 32 + ghc/runtime/io/createDirectory.lc | 58 + ghc/runtime/io/env.lc | 166 + ghc/runtime/io/errno.lc | 925 ++++ ghc/runtime/io/execvpe.lc | 154 + ghc/runtime/io/fileEOF.lc | 23 + ghc/runtime/io/fileGetc.lc | 38 + ghc/runtime/io/fileLookAhead.lc | 27 + ghc/runtime/io/filePosn.lc | 48 + ghc/runtime/io/filePutc.lc | 32 + ghc/runtime/io/fileSize.lc | 45 + ghc/runtime/io/flushFile.lc | 30 + ghc/runtime/io/getBufferMode.lc | 52 + ghc/runtime/io/getCPUTime.lc | 90 + ghc/runtime/io/getClockTime.lc | 77 + ghc/runtime/io/getCurrentDirectory.lc | 48 + ghc/runtime/io/getDirectoryContents.lc | 126 + ghc/runtime/io/getLock.lc | 138 + ghc/runtime/io/ghcReadline.lc | 44 + ghc/runtime/io/inputReady.lc | 87 + ghc/runtime/io/openFile.lc | 209 + ghc/runtime/io/posix.c | 55 + ghc/runtime/io/readFile.lc | 102 + ghc/runtime/io/removeDirectory.lc | 57 + ghc/runtime/io/removeFile.lc | 48 + ghc/runtime/io/renameDirectory.lc | 48 + ghc/runtime/io/renameFile.lc | 132 + ghc/runtime/io/seekFile.lc | 135 + ghc/runtime/io/setBuffering.lc | 123 + ghc/runtime/io/setCurrentDirectory.lc | 25 + ghc/runtime/io/showTime.lc | 47 + ghc/runtime/io/system.lc | 65 + ghc/runtime/io/toClockSec.lc | 48 + ghc/runtime/io/toLocalTime.lc | 47 + ghc/runtime/io/toUTCTime.lc | 47 + ghc/runtime/io/writeFile.lc | 38 + ghc/runtime/main/GranSim.lc | 595 +++ ghc/runtime/main/Itimer.lc | 84 + ghc/runtime/main/RednCounts.lc | 682 +++ ghc/runtime/main/SMRep.lc | 204 + ghc/runtime/main/Select.lc | 123 + ghc/runtime/main/Signals.lc | 588 +++ ghc/runtime/main/StgOverflow.lc | 450 ++ ghc/runtime/main/StgStartup.lhc | 662 +++ ghc/runtime/main/StgThreads.lhc | 496 ++ ghc/runtime/main/StgTrace.lc | 74 + ghc/runtime/main/StgUpdate.lhc | 730 +++ ghc/runtime/main/Threads.lc | 3749 ++++++++++++++ ghc/runtime/main/TopClosure.lc | 8 + ghc/runtime/main/TopClosure13.lc | 8 + ghc/runtime/main/main.lc | 1355 +++++ ghc/runtime/prims/ByteOps.lc | 140 + ghc/runtime/prims/PrimArith.lc | 461 ++ ghc/runtime/prims/PrimMisc.lc | 97 + ghc/runtime/prims/test-float.c | 66 + ghc/runtime/profiling/CHANGES-REQD | 201 + ghc/runtime/profiling/CostCentre.lc | 653 +++ ghc/runtime/profiling/Hashing.lc | 87 + ghc/runtime/profiling/HeapProfile.lc | 906 ++++ ghc/runtime/profiling/Indexing.lc | 301 ++ ghc/runtime/profiling/LifeProfile.lc | 299 ++ ghc/runtime/profiling/Timer.lc | 111 + ghc/runtime/regex/AUTHORS | 10 + ghc/runtime/regex/COPYING | 339 ++ ghc/runtime/regex/ChangeLog | 3041 +++++++++++ ghc/runtime/regex/INSTALL | 117 + ghc/runtime/regex/Jmakefile | 19 + ghc/runtime/regex/Jmakefile-original | 30 + ghc/runtime/regex/Makefile.in | 101 + ghc/runtime/regex/Makefile.reg | 102 + ghc/runtime/regex/Makefile.regex | 99 + ghc/runtime/regex/NEWS | 62 + ghc/runtime/regex/PerlSyntaxCaveats | 40 + ghc/runtime/regex/README | 60 + ghc/runtime/regex/VERSION | 8 + ghc/runtime/regex/configure | 462 ++ ghc/runtime/regex/configure.in | 23 + ghc/runtime/regex/doc/Makefile.in | 92 + ghc/runtime/regex/doc/include.awk | 19 + ghc/runtime/regex/doc/regex.texi | 3138 ++++++++++++ ghc/runtime/regex/doc/xregex.texi | 3021 +++++++++++ ghc/runtime/regex/regex.c | 5341 ++++++++++++++++++++ ghc/runtime/regex/test.hs | 58 + ghc/runtime/regex/test/ChangeLog | 77 + ghc/runtime/regex/test/Makefile.in | 168 + ghc/runtime/regex/test/alloca.c | 194 + ghc/runtime/regex/test/bsd-interf.c | 38 + ghc/runtime/regex/test/debugmalloc.c | 273 + ghc/runtime/regex/test/emacsmalloc.c | 844 ++++ ghc/runtime/regex/test/fileregex.c | 77 + ghc/runtime/regex/test/g++malloc.c | 1288 +++++ ghc/runtime/regex/test/getpagesize.h | 25 + ghc/runtime/regex/test/iregex.c | 164 + ghc/runtime/regex/test/main.c | 49 + ghc/runtime/regex/test/malloc-test.c | 47 + ghc/runtime/regex/test/other.c | 503 ++ ghc/runtime/regex/test/printchar.c | 14 + ghc/runtime/regex/test/psx-basic.c | 253 + ghc/runtime/regex/test/psx-extend.c | 1244 +++++ ghc/runtime/regex/test/psx-generic.c | 336 ++ ghc/runtime/regex/test/psx-group.c | 440 ++ ghc/runtime/regex/test/psx-interf.c | 624 +++ ghc/runtime/regex/test/psx-interv.c | 140 + ghc/runtime/regex/test/regexcpp.sed | 8 + ghc/runtime/regex/test/syntax.skel | 74 + ghc/runtime/regex/test/test.c | 782 +++ ghc/runtime/regex/test/test.h | 141 + ghc/runtime/regex/test/tregress.c | 464 ++ ghc/runtime/regex/test/upcase.c | 39 + ghc/runtime/regex/test/xmalloc.c | 21 + ghc/runtime/storage/Force_GC.lc | 50 + ghc/runtime/storage/SM1s.lc | 197 + ghc/runtime/storage/SM2s.lc | 291 ++ ghc/runtime/storage/SMalloc.lc | 37 + ghc/runtime/storage/SMap.lc | 888 ++++ ghc/runtime/storage/SMcheck.lc | 127 + ghc/runtime/storage/SMcompacting.h | 7 + ghc/runtime/storage/SMcompacting.lc | 234 + ghc/runtime/storage/SMcompacting.lh | 11 + ghc/runtime/storage/SMcopying.lc | 363 ++ ghc/runtime/storage/SMcopying.lh | 15 + ghc/runtime/storage/SMdu.lc | 291 ++ ghc/runtime/storage/SMevac.lc | 1203 +++++ ghc/runtime/storage/SMextn.lc | 367 ++ ghc/runtime/storage/SMextn.lh | 40 + ghc/runtime/storage/SMgen.lc | 832 +++ ghc/runtime/storage/SMinit.lc | 185 + ghc/runtime/storage/SMinternal.lh | 525 ++ ghc/runtime/storage/SMmark.lhc | 1628 ++++++ ghc/runtime/storage/SMmarkDefs.lh | 322 ++ ghc/runtime/storage/SMmarking.lc | 267 + ghc/runtime/storage/SMscan.lc | 1695 +++++++ ghc/runtime/storage/SMscav.lc | 1031 ++++ ghc/runtime/storage/SMstacks.lc | 57 + ghc/runtime/storage/SMstatic.lc | 322 ++ ghc/runtime/storage/SMstats.lc | 468 ++ ghc/runtime/storage/mprotect.lc | 78 + ghc/runtime/threadroot.lit | 24 + ghc/utils/Jmakefile | 10 + ghc/utils/hp2ps/AreaBelow.c | 63 + ghc/utils/hp2ps/AreaBelow.h | 6 + ghc/utils/hp2ps/AuxFile.c | 168 + ghc/utils/hp2ps/AuxFile.h | 7 + ghc/utils/hp2ps/Axes.c | 241 + ghc/utils/hp2ps/Axes.h | 6 + ghc/utils/hp2ps/CHANGES | 37 + ghc/utils/hp2ps/Curves.c | 164 + ghc/utils/hp2ps/Curves.h | 10 + ghc/utils/hp2ps/Defines.h | 61 + ghc/utils/hp2ps/Deviation.c | 140 + ghc/utils/hp2ps/Deviation.h | 7 + ghc/utils/hp2ps/Dimensions.c | 203 + ghc/utils/hp2ps/Dimensions.h | 22 + ghc/utils/hp2ps/Error.c | 54 + ghc/utils/hp2ps/Error.h | 8 + ghc/utils/hp2ps/HpFile.c | 587 +++ ghc/utils/hp2ps/HpFile.h | 77 + ghc/utils/hp2ps/Jmakefile | 50 + ghc/utils/hp2ps/Key.c | 63 + ghc/utils/hp2ps/Key.h | 6 + ghc/utils/hp2ps/Main.c | 252 + ghc/utils/hp2ps/Main.h | 65 + ghc/utils/hp2ps/Marks.c | 43 + ghc/utils/hp2ps/Marks.h | 6 + ghc/utils/hp2ps/PsFile.c | 289 ++ ghc/utils/hp2ps/PsFile.h | 6 + ghc/utils/hp2ps/README.GHC | 4 + ghc/utils/hp2ps/Reorder.c | 89 + ghc/utils/hp2ps/Reorder.h | 8 + ghc/utils/hp2ps/Scale.c | 87 + ghc/utils/hp2ps/Scale.h | 7 + ghc/utils/hp2ps/Shade.c | 92 + ghc/utils/hp2ps/Shade.h | 7 + ghc/utils/hp2ps/TopTwenty.c | 73 + ghc/utils/hp2ps/TopTwenty.h | 6 + ghc/utils/hp2ps/TraceElement.c | 97 + ghc/utils/hp2ps/TraceElement.h | 6 + ghc/utils/hp2ps/Utilities.c | 132 + ghc/utils/hp2ps/Utilities.h | 13 + ghc/utils/hp2ps/hp2ps.1 | 143 + ghc/utils/hp2ps/makefile.original | 42 + ghc/utils/hscpp/Jmakefile | 30 + ghc/utils/hscpp/hscpp.prl | 186 + ghc/utils/hstags/Jmakefile | 20 + ghc/utils/hstags/README | 10 + ghc/utils/hstags/hstags-help.c | 59 + ghc/utils/hstags/hstags.prl | 100 + ghc/utils/mkdependHS/Jmakefile | 16 + ghc/utils/mkdependHS/mkdependHS.prl | 430 ++ ghc/utils/parallel/Jmakefile | 37 + ghc/utils/parallel/ghc-fool-sort.pl | 23 + ghc/utils/parallel/ghc-unfool-sort.pl | 16 + ghc/utils/parallel/gr2ps.bash | 136 + ghc/utils/parallel/gr2qp.pl | 45 + ghc/utils/parallel/grs2gr.pl | 43 + ghc/utils/parallel/qp2ps.pl | 813 +++ ghc/utils/pvm/README | 7 + ghc/utils/pvm/debugger.emacs | 37 + ghc/utils/pvm/debugger2 | 48 + ghc/utils/stat2resid/Jmakefile | 26 + ghc/utils/stat2resid/parse-gcstats.prl | 230 + ghc/utils/stat2resid/process-gcstats.prl | 46 + ghc/utils/stat2resid/stat2resid.prl | 73 + ghc/utils/ugen/Jmakefile | 26 + ghc/utils/ugen/funs.h | 28 + ghc/utils/ugen/gen.c | 494 ++ ghc/utils/ugen/id.c | 49 + ghc/utils/ugen/id.h | 1 + ghc/utils/ugen/lex.l | 51 + ghc/utils/ugen/main.c | 87 + ghc/utils/ugen/manual.mm | 226 + ghc/utils/ugen/syntax.y | 50 + ghc/utils/ugen/tree.ugn | 27 + ghc/utils/ugen/yyerror.c | 24 + ghc/utils/unlit/Jmakefile | 10 + ghc/utils/unlit/README | 8 + ghc/utils/unlit/unlit.c | 327 ++ glafp-utils/Jmakefile | 6 + glafp-utils/Makefile.BOOT | 58 + glafp-utils/PATCHLEVEL | 1 + glafp-utils/README | 44 + glafp-utils/etags/Jmakefile | 5 + glafp-utils/etags/README | 2 + glafp-utils/etags/etags.c | 1762 +++++++ glafp-utils/etags/jbw-fixes | 568 +++ glafp-utils/etags/wells-fixes | 545 ++ glafp-utils/msub/Jmakefile | 7 + glafp-utils/msub/msub.c | 520 ++ glafp-utils/msub/msub.man | 274 + glafp-utils/msub/msub.ms | 128 + glafp-utils/msub/test.makefile | 18 + glafp-utils/msub/test.stdout | 11 + glafp-utils/msub/testfile | 13 + glafp-utils/perl-4.035-fixes | 180 + glafp-utils/scripts/Jmakefile | 72 + glafp-utils/scripts/fastmake.prl | 126 + glafp-utils/scripts/lndir-Xos.h | 152 + glafp-utils/scripts/lndir-Xosdefs.h | 99 + glafp-utils/scripts/lndir.c | 221 + glafp-utils/scripts/lndir.c-X11R5 | 217 + glafp-utils/scripts/lndir.man | 61 + glafp-utils/scripts/lndir.sh | 85 + glafp-utils/scripts/ltx.prl | 215 + glafp-utils/scripts/mkdependC.prl | 189 + glafp-utils/scripts/mkdirhier.man | 15 + glafp-utils/scripts/mkdirhier.sh | 24 + glafp-utils/scripts/perltags.prl | 69 + glafp-utils/scripts/runstdtest.prl | 409 ++ glafp-utils/scripts/zap-if-same.prl | 50 + glafp-utils/verbatim/Jmakefile | 4 + glafp-utils/verbatim/verbatim.c | 540 ++ glafp-utils/verbatim/verbatim.lex | 63 + install-sh | 238 + 2703 files changed, 411780 insertions(+) create mode 100644 ANNOUNCE-0.26 create mode 100644 Makefile.config create mode 100644 Makefile.in create mode 100644 README create mode 100644 STARTUP.in create mode 100644 config.guess create mode 100644 config.sub create mode 100644 configure.in create mode 100644 ghc/.gdbinit create mode 100644 ghc/CONTRIB/README create mode 100644 ghc/CONTRIB/fptags create mode 100644 ghc/CONTRIB/haskel.gif create mode 100644 ghc/CONTRIB/haskell.el create mode 100644 ghc/CONTRIB/haskell_poem create mode 100644 ghc/CONTRIB/mira2hs create mode 100644 ghc/CONTRIB/pphs/Jmakefile create mode 100644 ghc/CONTRIB/pphs/README create mode 100644 ghc/CONTRIB/pphs/docs/Code.tex create mode 100644 ghc/CONTRIB/pphs/docs/Error_Messages.tex create mode 100644 ghc/CONTRIB/pphs/docs/External_Specification.tex create mode 100644 ghc/CONTRIB/pphs/docs/Faults.tex create mode 100644 ghc/CONTRIB/pphs/docs/Future_Work.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_char.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_math.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_simple.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_string1.tex create mode 100644 ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex create mode 100644 ghc/CONTRIB/pphs/docs/How.tex create mode 100644 ghc/CONTRIB/pphs/docs/Introduction.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_char.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_comment.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_math.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_simple.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_string1.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_string2.tex create mode 100644 ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex create mode 100644 ghc/CONTRIB/pphs/docs/Problem_Definition.tex create mode 100644 ghc/CONTRIB/pphs/docs/Project_Documents.tex create mode 100644 ghc/CONTRIB/pphs/docs/Report.tex create mode 100644 ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex create mode 100644 ghc/CONTRIB/pphs/docs/Title.tex create mode 100644 ghc/CONTRIB/pphs/docs/UserGuide.tex create mode 100644 ghc/CONTRIB/pphs/docs/UserGuide_Text.tex create mode 100644 ghc/CONTRIB/pphs/docs/User_Documents.tex create mode 100644 ghc/CONTRIB/pphs/docs/Uses.tex create mode 100644 ghc/CONTRIB/pphs/docs/What.tex create mode 100644 ghc/CONTRIB/pphs/docs/Wrapper.tex create mode 100644 ghc/CONTRIB/pphs/docs/char.hs create mode 100644 ghc/CONTRIB/pphs/docs/comment.hs create mode 100644 ghc/CONTRIB/pphs/docs/internalalign1.hs create mode 100644 ghc/CONTRIB/pphs/docs/leftindent1.hs create mode 100644 ghc/CONTRIB/pphs/docs/leftindent2.hs create mode 100644 ghc/CONTRIB/pphs/docs/math.hs create mode 100644 ghc/CONTRIB/pphs/docs/pphs.sty create mode 100644 ghc/CONTRIB/pphs/docs/rep.sty create mode 100644 ghc/CONTRIB/pphs/docs/simple.hs create mode 100644 ghc/CONTRIB/pphs/docs/string1.hs create mode 100644 ghc/CONTRIB/pphs/docs/string2.hs create mode 100644 ghc/CONTRIB/pphs/pphs.c create mode 100644 ghc/Jmakefile create mode 100644 ghc/Makefile.BOOT create mode 100644 ghc/PATCHLEVEL create mode 100644 ghc/README create mode 100644 ghc/compiler/HsVersions.h create mode 100644 ghc/compiler/Jmakefile create mode 100644 ghc/compiler/README create mode 100644 ghc/compiler/absCSyn/AbsCFuns.hi create mode 100644 ghc/compiler/absCSyn/AbsCFuns.lhs create mode 100644 ghc/compiler/absCSyn/AbsCSyn.hi create mode 100644 ghc/compiler/absCSyn/AbsCSyn.lhs create mode 100644 ghc/compiler/absCSyn/Costs.hi create mode 100644 ghc/compiler/absCSyn/Costs.lhs create mode 100644 ghc/compiler/absCSyn/HeapOffs.hi create mode 100644 ghc/compiler/absCSyn/HeapOffs.lhs create mode 100644 ghc/compiler/absCSyn/PprAbsC.hi create mode 100644 ghc/compiler/absCSyn/PprAbsC.lhs create mode 100644 ghc/compiler/abstractSyn/AbsSyn.hi create mode 100644 ghc/compiler/abstractSyn/AbsSyn.lhs create mode 100644 ghc/compiler/abstractSyn/AbsSynFuns.hi create mode 100644 ghc/compiler/abstractSyn/AbsSynFuns.lhs create mode 100644 ghc/compiler/abstractSyn/HsBinds.hi create mode 100644 ghc/compiler/abstractSyn/HsBinds.lhs create mode 100644 ghc/compiler/abstractSyn/HsCore.hi create mode 100644 ghc/compiler/abstractSyn/HsCore.lhs create mode 100644 ghc/compiler/abstractSyn/HsDecls.hi create mode 100644 ghc/compiler/abstractSyn/HsDecls.lhs create mode 100644 ghc/compiler/abstractSyn/HsExpr.hi create mode 100644 ghc/compiler/abstractSyn/HsExpr.lhs create mode 100644 ghc/compiler/abstractSyn/HsImpExp.hi create mode 100644 ghc/compiler/abstractSyn/HsImpExp.lhs create mode 100644 ghc/compiler/abstractSyn/HsLit.hi create mode 100644 ghc/compiler/abstractSyn/HsLit.lhs create mode 100644 ghc/compiler/abstractSyn/HsMatches.hi create mode 100644 ghc/compiler/abstractSyn/HsMatches.lhs create mode 100644 ghc/compiler/abstractSyn/HsPat.hi create mode 100644 ghc/compiler/abstractSyn/HsPat.lhs create mode 100644 ghc/compiler/abstractSyn/HsPragmas.hi create mode 100644 ghc/compiler/abstractSyn/HsPragmas.lhs create mode 100644 ghc/compiler/abstractSyn/HsTypes.hi create mode 100644 ghc/compiler/abstractSyn/HsTypes.lhs create mode 100644 ghc/compiler/abstractSyn/Name.hi create mode 100644 ghc/compiler/abstractSyn/Name.lhs create mode 100644 ghc/compiler/basicTypes/BasicLit.hi create mode 100644 ghc/compiler/basicTypes/BasicLit.lhs create mode 100644 ghc/compiler/basicTypes/CLabelInfo.hi create mode 100644 ghc/compiler/basicTypes/CLabelInfo.lhs create mode 100644 ghc/compiler/basicTypes/Id.hi create mode 100644 ghc/compiler/basicTypes/Id.lhs create mode 100644 ghc/compiler/basicTypes/IdInfo.hi create mode 100644 ghc/compiler/basicTypes/IdInfo.lhs create mode 100644 ghc/compiler/basicTypes/Inst.hi create mode 100644 ghc/compiler/basicTypes/Inst.lhs create mode 100644 ghc/compiler/basicTypes/Jmakefile create mode 100644 ghc/compiler/basicTypes/NameTypes.hi create mode 100644 ghc/compiler/basicTypes/NameTypes.lhs create mode 100644 ghc/compiler/basicTypes/OrdList.hi create mode 100644 ghc/compiler/basicTypes/OrdList.lhs create mode 100644 ghc/compiler/basicTypes/ProtoName.hi create mode 100644 ghc/compiler/basicTypes/ProtoName.lhs create mode 100644 ghc/compiler/basicTypes/SplitUniq.hi create mode 100644 ghc/compiler/basicTypes/SplitUniq.lhs create mode 100644 ghc/compiler/basicTypes/SrcLoc.hi create mode 100644 ghc/compiler/basicTypes/SrcLoc.lhs create mode 100644 ghc/compiler/basicTypes/Unique.hi create mode 100644 ghc/compiler/basicTypes/Unique.lhs create mode 100644 ghc/compiler/basicTypes/basicTypes.lit create mode 100644 ghc/compiler/codeGen/CgBindery.hi create mode 100644 ghc/compiler/codeGen/CgBindery.lhs create mode 100644 ghc/compiler/codeGen/CgCase.hi create mode 100644 ghc/compiler/codeGen/CgCase.lhs create mode 100644 ghc/compiler/codeGen/CgClosure.hi create mode 100644 ghc/compiler/codeGen/CgClosure.lhs create mode 100644 ghc/compiler/codeGen/CgCompInfo.hi create mode 100644 ghc/compiler/codeGen/CgCompInfo.lhs create mode 100644 ghc/compiler/codeGen/CgCon.hi create mode 100644 ghc/compiler/codeGen/CgCon.lhs create mode 100644 ghc/compiler/codeGen/CgConTbls.hi create mode 100644 ghc/compiler/codeGen/CgConTbls.lhs create mode 100644 ghc/compiler/codeGen/CgExpr.hi create mode 100644 ghc/compiler/codeGen/CgExpr.lhs create mode 100644 ghc/compiler/codeGen/CgHeapery.hi create mode 100644 ghc/compiler/codeGen/CgHeapery.lhs create mode 100644 ghc/compiler/codeGen/CgLetNoEscape.hi create mode 100644 ghc/compiler/codeGen/CgLetNoEscape.lhs create mode 100644 ghc/compiler/codeGen/CgMonad.hi create mode 100644 ghc/compiler/codeGen/CgMonad.lhs create mode 100644 ghc/compiler/codeGen/CgRetConv.hi create mode 100644 ghc/compiler/codeGen/CgRetConv.lhs create mode 100644 ghc/compiler/codeGen/CgStackery.hi create mode 100644 ghc/compiler/codeGen/CgStackery.lhs create mode 100644 ghc/compiler/codeGen/CgTailCall.hi create mode 100644 ghc/compiler/codeGen/CgTailCall.lhs create mode 100644 ghc/compiler/codeGen/CgUpdate.hi create mode 100644 ghc/compiler/codeGen/CgUpdate.lhs create mode 100644 ghc/compiler/codeGen/CgUsages.hi create mode 100644 ghc/compiler/codeGen/CgUsages.lhs create mode 100644 ghc/compiler/codeGen/ClosureInfo.hi create mode 100644 ghc/compiler/codeGen/ClosureInfo.lhs create mode 100644 ghc/compiler/codeGen/CodeGen.hi create mode 100644 ghc/compiler/codeGen/CodeGen.lhs create mode 100644 ghc/compiler/codeGen/Jmakefile create mode 100644 ghc/compiler/codeGen/SMRep.hi create mode 100644 ghc/compiler/codeGen/SMRep.lhs create mode 100644 ghc/compiler/codeGen/cgintro.lit create mode 100644 ghc/compiler/coreSyn/AnnCoreSyn.hi create mode 100644 ghc/compiler/coreSyn/AnnCoreSyn.lhs create mode 100644 ghc/compiler/coreSyn/CoreFuns.hi create mode 100644 ghc/compiler/coreSyn/CoreFuns.lhs create mode 100644 ghc/compiler/coreSyn/CoreLift.hi create mode 100644 ghc/compiler/coreSyn/CoreLift.lhs create mode 100644 ghc/compiler/coreSyn/CoreLint.hi create mode 100644 ghc/compiler/coreSyn/CoreLint.lhs create mode 100644 ghc/compiler/coreSyn/CoreSyn.hi create mode 100644 ghc/compiler/coreSyn/CoreSyn.lhs create mode 100644 ghc/compiler/coreSyn/CoreUnfold.hi create mode 100644 ghc/compiler/coreSyn/CoreUnfold.lhs create mode 100644 ghc/compiler/coreSyn/FreeVars.hi create mode 100644 ghc/compiler/coreSyn/FreeVars.lhs create mode 100644 ghc/compiler/coreSyn/Jmakefile create mode 100644 ghc/compiler/coreSyn/PlainCore.hi create mode 100644 ghc/compiler/coreSyn/PlainCore.lhs create mode 100644 ghc/compiler/coreSyn/TaggedCore.hi create mode 100644 ghc/compiler/coreSyn/TaggedCore.lhs create mode 100644 ghc/compiler/coreSyn/root.lit create mode 100644 ghc/compiler/count_bytes create mode 100644 ghc/compiler/count_lines create mode 100644 ghc/compiler/deSugar/Desugar.hi create mode 100644 ghc/compiler/deSugar/Desugar.lhs create mode 100644 ghc/compiler/deSugar/DsBinds.hi create mode 100644 ghc/compiler/deSugar/DsBinds.lhs create mode 100644 ghc/compiler/deSugar/DsCCall.hi create mode 100644 ghc/compiler/deSugar/DsCCall.lhs create mode 100644 ghc/compiler/deSugar/DsExpr.hi create mode 100644 ghc/compiler/deSugar/DsExpr.lhs create mode 100644 ghc/compiler/deSugar/DsGRHSs.hi create mode 100644 ghc/compiler/deSugar/DsGRHSs.lhs create mode 100644 ghc/compiler/deSugar/DsListComp.hi create mode 100644 ghc/compiler/deSugar/DsListComp.lhs create mode 100644 ghc/compiler/deSugar/DsMonad.hi create mode 100644 ghc/compiler/deSugar/DsMonad.lhs create mode 100644 ghc/compiler/deSugar/DsParZF.lhs create mode 100644 ghc/compiler/deSugar/DsUtils.hi create mode 100644 ghc/compiler/deSugar/DsUtils.lhs create mode 100644 ghc/compiler/deSugar/Jmakefile create mode 100644 ghc/compiler/deSugar/Match.hi create mode 100644 ghc/compiler/deSugar/Match.lhs create mode 100644 ghc/compiler/deSugar/MatchCon.hi create mode 100644 ghc/compiler/deSugar/MatchCon.lhs create mode 100644 ghc/compiler/deSugar/MatchLit.hi create mode 100644 ghc/compiler/deSugar/MatchLit.lhs create mode 100644 ghc/compiler/deSugar/MatchProc.lhs create mode 100644 ghc/compiler/deSugar/intro.lit create mode 100644 ghc/compiler/deSugar/root.lit create mode 100644 ghc/compiler/deforest/Core2Def.hi create mode 100644 ghc/compiler/deforest/Core2Def.lhs create mode 100644 ghc/compiler/deforest/Cyclic.hi create mode 100644 ghc/compiler/deforest/Cyclic.lhs create mode 100644 ghc/compiler/deforest/Def2Core.hi create mode 100644 ghc/compiler/deforest/Def2Core.lhs create mode 100644 ghc/compiler/deforest/DefExpr.hi create mode 100644 ghc/compiler/deforest/DefExpr.lhs create mode 100644 ghc/compiler/deforest/DefSyn.hi create mode 100644 ghc/compiler/deforest/DefSyn.lhs create mode 100644 ghc/compiler/deforest/DefUtils.hi create mode 100644 ghc/compiler/deforest/DefUtils.lhs create mode 100644 ghc/compiler/deforest/Deforest.hi create mode 100644 ghc/compiler/deforest/Deforest.lhs create mode 100644 ghc/compiler/deforest/TreelessForm.hi create mode 100644 ghc/compiler/deforest/TreelessForm.lhs create mode 100644 ghc/compiler/envs/CE.hi create mode 100644 ghc/compiler/envs/CE.lhs create mode 100644 ghc/compiler/envs/E.hi create mode 100644 ghc/compiler/envs/E.lhs create mode 100644 ghc/compiler/envs/IdEnv.hi create mode 100644 ghc/compiler/envs/IdEnv.lhs create mode 100644 ghc/compiler/envs/InstEnv.hi create mode 100644 ghc/compiler/envs/InstEnv.lhs create mode 100644 ghc/compiler/envs/LIE.hi create mode 100644 ghc/compiler/envs/LIE.lhs create mode 100644 ghc/compiler/envs/TCE.hi create mode 100644 ghc/compiler/envs/TCE.lhs create mode 100644 ghc/compiler/envs/TVE.hi create mode 100644 ghc/compiler/envs/TVE.lhs create mode 100644 ghc/compiler/envs/TyVarEnv.hi create mode 100644 ghc/compiler/envs/TyVarEnv.lhs create mode 100644 ghc/compiler/main/CmdLineOpts.hi create mode 100644 ghc/compiler/main/CmdLineOpts.lhs create mode 100644 ghc/compiler/main/ErrUtils.hi create mode 100644 ghc/compiler/main/ErrUtils.lhs create mode 100644 ghc/compiler/main/Errors.hi create mode 100644 ghc/compiler/main/Errors.lhs create mode 100644 ghc/compiler/main/ErrsRn.hi create mode 100644 ghc/compiler/main/ErrsRn.lhs create mode 100644 ghc/compiler/main/ErrsTc.hi create mode 100644 ghc/compiler/main/ErrsTc.lhs create mode 100644 ghc/compiler/main/Main.hi create mode 100644 ghc/compiler/main/Main.lhs create mode 100644 ghc/compiler/main/MainMonad.hi create mode 100644 ghc/compiler/main/MainMonad.lhs create mode 100644 ghc/compiler/main/MkIface.hi create mode 100644 ghc/compiler/main/MkIface.lhs create mode 100644 ghc/compiler/nativeGen/AbsCStixGen.hi create mode 100644 ghc/compiler/nativeGen/AbsCStixGen.lhs create mode 100644 ghc/compiler/nativeGen/AlphaCode.hi create mode 100644 ghc/compiler/nativeGen/AlphaCode.lhs create mode 100644 ghc/compiler/nativeGen/AlphaDesc.hi create mode 100644 ghc/compiler/nativeGen/AlphaDesc.lhs create mode 100644 ghc/compiler/nativeGen/AlphaGen.hi create mode 100644 ghc/compiler/nativeGen/AlphaGen.lhs create mode 100644 ghc/compiler/nativeGen/AsmCodeGen.hi create mode 100644 ghc/compiler/nativeGen/AsmCodeGen.lhs create mode 100644 ghc/compiler/nativeGen/AsmRegAlloc.hi create mode 100644 ghc/compiler/nativeGen/AsmRegAlloc.lhs create mode 100644 ghc/compiler/nativeGen/Jmakefile create mode 100644 ghc/compiler/nativeGen/MachDesc.hi create mode 100644 ghc/compiler/nativeGen/MachDesc.lhs create mode 100644 ghc/compiler/nativeGen/SparcCode.hi create mode 100644 ghc/compiler/nativeGen/SparcCode.lhs create mode 100644 ghc/compiler/nativeGen/SparcDesc.hi create mode 100644 ghc/compiler/nativeGen/SparcDesc.lhs create mode 100644 ghc/compiler/nativeGen/SparcGen.hi create mode 100644 ghc/compiler/nativeGen/SparcGen.lhs create mode 100644 ghc/compiler/nativeGen/Stix.hi create mode 100644 ghc/compiler/nativeGen/Stix.lhs create mode 100644 ghc/compiler/nativeGen/StixInfo.hi create mode 100644 ghc/compiler/nativeGen/StixInfo.lhs create mode 100644 ghc/compiler/nativeGen/StixInteger.hi create mode 100644 ghc/compiler/nativeGen/StixInteger.lhs create mode 100644 ghc/compiler/nativeGen/StixMacro.hi create mode 100644 ghc/compiler/nativeGen/StixMacro.lhs create mode 100644 ghc/compiler/nativeGen/StixPrim.hi create mode 100644 ghc/compiler/nativeGen/StixPrim.lhs create mode 100644 ghc/compiler/nativeGen/root.lit create mode 100644 ghc/compiler/prelude/AbsPrel.hi create mode 100644 ghc/compiler/prelude/AbsPrel.lhs create mode 100644 ghc/compiler/prelude/Jmakefile create mode 100644 ghc/compiler/prelude/Makefile-fig create mode 100644 ghc/compiler/prelude/PrelFuns.hi create mode 100644 ghc/compiler/prelude/PrelFuns.lhs create mode 100644 ghc/compiler/prelude/PrelVals.hi create mode 100644 ghc/compiler/prelude/PrelVals.lhs create mode 100644 ghc/compiler/prelude/PrimKind.hi create mode 100644 ghc/compiler/prelude/PrimKind.lhs create mode 100644 ghc/compiler/prelude/PrimOps.hi create mode 100644 ghc/compiler/prelude/PrimOps.lhs create mode 100644 ghc/compiler/prelude/TyPod.lhs create mode 100644 ghc/compiler/prelude/TyProcs.lhs create mode 100644 ghc/compiler/prelude/TysPrim.hi create mode 100644 ghc/compiler/prelude/TysPrim.lhs create mode 100644 ghc/compiler/prelude/TysWiredIn.hi create mode 100644 ghc/compiler/prelude/TysWiredIn.lhs create mode 100644 ghc/compiler/prelude/prelude-structure.fig create mode 100644 ghc/compiler/prelude/prelude-structure.tex create mode 100644 ghc/compiler/prelude/prelude.lit create mode 100644 ghc/compiler/profiling/CostCentre.hi create mode 100644 ghc/compiler/profiling/CostCentre.lhs create mode 100644 ghc/compiler/profiling/NOTES create mode 100644 ghc/compiler/profiling/SCCauto.hi create mode 100644 ghc/compiler/profiling/SCCauto.lhs create mode 100644 ghc/compiler/profiling/SCCfinal.hi create mode 100644 ghc/compiler/profiling/SCCfinal.lhs create mode 100644 ghc/compiler/reader/Jmakefile create mode 100644 ghc/compiler/reader/PrefixSyn.hi create mode 100644 ghc/compiler/reader/PrefixSyn.lhs create mode 100644 ghc/compiler/reader/PrefixToHs.hi create mode 100644 ghc/compiler/reader/PrefixToHs.lhs create mode 100644 ghc/compiler/reader/ReadPragmas.hi create mode 100644 ghc/compiler/reader/ReadPragmas.lhs create mode 100644 ghc/compiler/reader/ReadPragmas2.hi create mode 100644 ghc/compiler/reader/ReadPragmas2.lhs create mode 100644 ghc/compiler/reader/ReadPrefix.hi create mode 100644 ghc/compiler/reader/ReadPrefix.lhs create mode 100644 ghc/compiler/reader/ReadPrefix2.hi create mode 100644 ghc/compiler/reader/ReadPrefix2.lhs create mode 100644 ghc/compiler/reader/reader.lit create mode 100644 ghc/compiler/rename/Rename.hi create mode 100644 ghc/compiler/rename/Rename.lhs create mode 100644 ghc/compiler/rename/Rename1.hi create mode 100644 ghc/compiler/rename/Rename1.lhs create mode 100644 ghc/compiler/rename/Rename2.hi create mode 100644 ghc/compiler/rename/Rename2.lhs create mode 100644 ghc/compiler/rename/Rename3.hi create mode 100644 ghc/compiler/rename/Rename3.lhs create mode 100644 ghc/compiler/rename/Rename4.hi create mode 100644 ghc/compiler/rename/Rename4.lhs create mode 100644 ghc/compiler/rename/RenameAuxFuns.hi create mode 100644 ghc/compiler/rename/RenameAuxFuns.lhs create mode 100644 ghc/compiler/rename/RenameBinds4.hi create mode 100644 ghc/compiler/rename/RenameBinds4.lhs create mode 100644 ghc/compiler/rename/RenameExpr4.hi create mode 100644 ghc/compiler/rename/RenameExpr4.lhs create mode 100644 ghc/compiler/rename/RenameMonad12.hi create mode 100644 ghc/compiler/rename/RenameMonad12.lhs create mode 100644 ghc/compiler/rename/RenameMonad3.hi create mode 100644 ghc/compiler/rename/RenameMonad3.lhs create mode 100644 ghc/compiler/rename/RenameMonad4.hi create mode 100644 ghc/compiler/rename/RenameMonad4.lhs create mode 100644 ghc/compiler/root.lit create mode 100644 ghc/compiler/simplCore/AnalFBWW.hi create mode 100644 ghc/compiler/simplCore/AnalFBWW.lhs create mode 100644 ghc/compiler/simplCore/BinderInfo.hi create mode 100644 ghc/compiler/simplCore/BinderInfo.lhs create mode 100644 ghc/compiler/simplCore/ConFold.hi create mode 100644 ghc/compiler/simplCore/ConFold.lhs create mode 100644 ghc/compiler/simplCore/FloatIn.hi create mode 100644 ghc/compiler/simplCore/FloatIn.lhs create mode 100644 ghc/compiler/simplCore/FloatOut.hi create mode 100644 ghc/compiler/simplCore/FloatOut.lhs create mode 100644 ghc/compiler/simplCore/FoldrBuildWW.hi create mode 100644 ghc/compiler/simplCore/FoldrBuildWW.lhs create mode 100644 ghc/compiler/simplCore/LiberateCase.hi create mode 100644 ghc/compiler/simplCore/LiberateCase.lhs create mode 100644 ghc/compiler/simplCore/MagicUFs.hi create mode 100644 ghc/compiler/simplCore/MagicUFs.lhs create mode 100644 ghc/compiler/simplCore/NewOccurAnal.hi create mode 100644 ghc/compiler/simplCore/NewOccurAnal.lhs create mode 100644 ghc/compiler/simplCore/OccurAnal.hi create mode 100644 ghc/compiler/simplCore/OccurAnal.lhs create mode 100644 ghc/compiler/simplCore/SAT.hi create mode 100644 ghc/compiler/simplCore/SAT.lhs create mode 100644 ghc/compiler/simplCore/SATMonad.hi create mode 100644 ghc/compiler/simplCore/SATMonad.lhs create mode 100644 ghc/compiler/simplCore/SetLevels.hi create mode 100644 ghc/compiler/simplCore/SetLevels.lhs create mode 100644 ghc/compiler/simplCore/SimplCase.hi create mode 100644 ghc/compiler/simplCore/SimplCase.lhs create mode 100644 ghc/compiler/simplCore/SimplCore.hi create mode 100644 ghc/compiler/simplCore/SimplCore.lhs create mode 100644 ghc/compiler/simplCore/SimplEnv.hi create mode 100644 ghc/compiler/simplCore/SimplEnv.lhs create mode 100644 ghc/compiler/simplCore/SimplHaskell.lhs create mode 100644 ghc/compiler/simplCore/SimplMonad.hi create mode 100644 ghc/compiler/simplCore/SimplMonad.lhs create mode 100644 ghc/compiler/simplCore/SimplPgm.hi create mode 100644 ghc/compiler/simplCore/SimplPgm.lhs create mode 100644 ghc/compiler/simplCore/SimplUtils.hi create mode 100644 ghc/compiler/simplCore/SimplUtils.lhs create mode 100644 ghc/compiler/simplCore/SimplVar.hi create mode 100644 ghc/compiler/simplCore/SimplVar.lhs create mode 100644 ghc/compiler/simplCore/Simplify.hi create mode 100644 ghc/compiler/simplCore/Simplify.lhs create mode 100644 ghc/compiler/simplCore/simplifier.tib create mode 100644 ghc/compiler/simplStg/LambdaLift.hi create mode 100644 ghc/compiler/simplStg/LambdaLift.lhs create mode 100644 ghc/compiler/simplStg/SatStgRhs.hi create mode 100644 ghc/compiler/simplStg/SatStgRhs.lhs create mode 100644 ghc/compiler/simplStg/SimplStg.hi create mode 100644 ghc/compiler/simplStg/SimplStg.lhs create mode 100644 ghc/compiler/simplStg/StgSAT.hi create mode 100644 ghc/compiler/simplStg/StgSAT.lhs create mode 100644 ghc/compiler/simplStg/StgSATMonad.hi create mode 100644 ghc/compiler/simplStg/StgSATMonad.lhs create mode 100644 ghc/compiler/simplStg/StgStats.hi create mode 100644 ghc/compiler/simplStg/StgStats.lhs create mode 100644 ghc/compiler/simplStg/StgVarInfo.hi create mode 100644 ghc/compiler/simplStg/StgVarInfo.lhs create mode 100644 ghc/compiler/simplStg/UpdAnal.hi create mode 100644 ghc/compiler/simplStg/UpdAnal.lhs create mode 100644 ghc/compiler/specialise/SpecTyFuns.hi create mode 100644 ghc/compiler/specialise/SpecTyFuns.lhs create mode 100644 ghc/compiler/specialise/Specialise.hi create mode 100644 ghc/compiler/specialise/Specialise.lhs create mode 100644 ghc/compiler/stgSyn/CoreToStg.hi create mode 100644 ghc/compiler/stgSyn/CoreToStg.lhs create mode 100644 ghc/compiler/stgSyn/Jmakefile create mode 100644 ghc/compiler/stgSyn/StgFuns.hi create mode 100644 ghc/compiler/stgSyn/StgFuns.lhs create mode 100644 ghc/compiler/stgSyn/StgLint.hi create mode 100644 ghc/compiler/stgSyn/StgLint.lhs create mode 100644 ghc/compiler/stgSyn/StgSyn.hi create mode 100644 ghc/compiler/stgSyn/StgSyn.lhs create mode 100644 ghc/compiler/stgSyn/root.lit create mode 100644 ghc/compiler/stranal/SaAbsInt.hi create mode 100644 ghc/compiler/stranal/SaAbsInt.lhs create mode 100644 ghc/compiler/stranal/SaLib.hi create mode 100644 ghc/compiler/stranal/SaLib.lhs create mode 100644 ghc/compiler/stranal/StrictAnal.hi create mode 100644 ghc/compiler/stranal/StrictAnal.lhs create mode 100644 ghc/compiler/stranal/WorkWrap.hi create mode 100644 ghc/compiler/stranal/WorkWrap.lhs create mode 100644 ghc/compiler/stranal/WwLib.hi create mode 100644 ghc/compiler/stranal/WwLib.lhs create mode 100644 ghc/compiler/tests/Jmakefile create mode 100644 ghc/compiler/tests/README create mode 100644 ghc/compiler/tests/TIMING/HelpMicroPrel.hi create mode 100644 ghc/compiler/tests/ccall/Jmakefile create mode 100644 ghc/compiler/tests/ccall/cc001.hs create mode 100644 ghc/compiler/tests/ccall/cc001.stderr create mode 100644 ghc/compiler/tests/ccall/cc002.hs create mode 100644 ghc/compiler/tests/ccall/cc002.stderr create mode 100644 ghc/compiler/tests/ccall/cc003.hs create mode 100644 ghc/compiler/tests/ccall/cc003.stderr create mode 100644 ghc/compiler/tests/ccall/cc004.hs create mode 100644 ghc/compiler/tests/ccall/cc004.stderr create mode 100644 ghc/compiler/tests/deSugar/Jmakefile create mode 100644 ghc/compiler/tests/deSugar/cvh-ds-unboxed/Jmakefile create mode 100644 ghc/compiler/tests/deSugar/cvh-ds-unboxed/Life2.lhs create mode 100644 ghc/compiler/tests/deSugar/cvh-ds-unboxed/UCopy.hi create mode 100644 ghc/compiler/tests/deSugar/cvh-ds-unboxed/UTypes.hi create mode 100644 ghc/compiler/tests/deSugar/cvh-ds-unboxed/cvh-unbox1.stderr create mode 100644 ghc/compiler/tests/deSugar/ds-wildcard.hs create mode 100644 ghc/compiler/tests/deSugar/ds001.hs create mode 100644 ghc/compiler/tests/deSugar/ds001.stderr create mode 100644 ghc/compiler/tests/deSugar/ds002.hs create mode 100644 ghc/compiler/tests/deSugar/ds002.stderr create mode 100644 ghc/compiler/tests/deSugar/ds003.hs create mode 100644 ghc/compiler/tests/deSugar/ds003.stderr create mode 100644 ghc/compiler/tests/deSugar/ds004.hs create mode 100644 ghc/compiler/tests/deSugar/ds004.stderr create mode 100644 ghc/compiler/tests/deSugar/ds005.hs create mode 100644 ghc/compiler/tests/deSugar/ds005.stderr create mode 100644 ghc/compiler/tests/deSugar/ds006.hs create mode 100644 ghc/compiler/tests/deSugar/ds006.stderr create mode 100644 ghc/compiler/tests/deSugar/ds007.hs create mode 100644 ghc/compiler/tests/deSugar/ds007.stderr create mode 100644 ghc/compiler/tests/deSugar/ds008.hs create mode 100644 ghc/compiler/tests/deSugar/ds008.stderr create mode 100644 ghc/compiler/tests/deSugar/ds009.hs create mode 100644 ghc/compiler/tests/deSugar/ds009.stderr create mode 100644 ghc/compiler/tests/deSugar/ds010.hs create mode 100644 ghc/compiler/tests/deSugar/ds010.stderr create mode 100644 ghc/compiler/tests/deSugar/ds011.hs create mode 100644 ghc/compiler/tests/deSugar/ds011.stderr create mode 100644 ghc/compiler/tests/deSugar/ds012.hs create mode 100644 ghc/compiler/tests/deSugar/ds012.stderr create mode 100644 ghc/compiler/tests/deSugar/ds013.hs create mode 100644 ghc/compiler/tests/deSugar/ds013.stderr create mode 100644 ghc/compiler/tests/deSugar/ds014.hs create mode 100644 ghc/compiler/tests/deSugar/ds014.stderr create mode 100644 ghc/compiler/tests/deSugar/ds014a.hs create mode 100644 ghc/compiler/tests/deSugar/ds015.hs create mode 100644 ghc/compiler/tests/deSugar/ds015.stderr create mode 100644 ghc/compiler/tests/deSugar/ds016.hs create mode 100644 ghc/compiler/tests/deSugar/ds016.stderr create mode 100644 ghc/compiler/tests/deSugar/ds017.hs create mode 100644 ghc/compiler/tests/deSugar/ds017.stderr create mode 100644 ghc/compiler/tests/deSugar/ds018.hs create mode 100644 ghc/compiler/tests/deSugar/ds018.stderr create mode 100644 ghc/compiler/tests/deSugar/ds019.hs create mode 100644 ghc/compiler/tests/deSugar/ds019.stderr create mode 100644 ghc/compiler/tests/deSugar/ds020.hs create mode 100644 ghc/compiler/tests/deSugar/ds020.stderr create mode 100644 ghc/compiler/tests/deSugar/ds021.hs create mode 100644 ghc/compiler/tests/deSugar/ds021.stderr create mode 100644 ghc/compiler/tests/deSugar/ds022.hs create mode 100644 ghc/compiler/tests/deSugar/ds022.stderr create mode 100644 ghc/compiler/tests/deSugar/ds023.hs create mode 100644 ghc/compiler/tests/deSugar/ds023.stderr create mode 100644 ghc/compiler/tests/deSugar/ds024.hs create mode 100644 ghc/compiler/tests/deSugar/ds024.stderr create mode 100644 ghc/compiler/tests/deSugar/ds025.hs create mode 100644 ghc/compiler/tests/deSugar/ds025.stderr create mode 100644 ghc/compiler/tests/deSugar/ds026.hs create mode 100644 ghc/compiler/tests/deSugar/ds026.stderr create mode 100644 ghc/compiler/tests/deSugar/ds027.hs create mode 100644 ghc/compiler/tests/deSugar/ds027.stderr create mode 100644 ghc/compiler/tests/deSugar/ds028.hs create mode 100644 ghc/compiler/tests/deSugar/ds028.stderr create mode 100644 ghc/compiler/tests/deSugar/ds029.hs create mode 100644 ghc/compiler/tests/deSugar/ds029.stderr create mode 100644 ghc/compiler/tests/deSugar/ds030.hs create mode 100644 ghc/compiler/tests/deSugar/ds030.stderr create mode 100644 ghc/compiler/tests/deSugar/ds031.hs create mode 100644 ghc/compiler/tests/deSugar/ds031.stderr create mode 100644 ghc/compiler/tests/deSugar/ds032.hs create mode 100644 ghc/compiler/tests/deSugar/ds032.stderr create mode 100644 ghc/compiler/tests/deSugar/ds033.hs create mode 100644 ghc/compiler/tests/deSugar/ds033.stderr create mode 100644 ghc/compiler/tests/deSugar/ds034.hs create mode 100644 ghc/compiler/tests/deSugar/ds034.stderr create mode 100644 ghc/compiler/tests/deSugar/ds035.hs create mode 100644 ghc/compiler/tests/deSugar/ds035.stderr create mode 100644 ghc/compiler/tests/deSugar/ds036.hs create mode 100644 ghc/compiler/tests/deSugar/ds036.stderr create mode 100644 ghc/compiler/tests/deSugar/ds037.hs create mode 100644 ghc/compiler/tests/deSugar/ds037.stderr create mode 100644 ghc/compiler/tests/deSugar/ds038.hs create mode 100644 ghc/compiler/tests/deSugar/ds038.stderr create mode 100644 ghc/compiler/tests/deSugar/ds039.hs create mode 100644 ghc/compiler/tests/deSugar/ds039.stderr create mode 100644 ghc/compiler/tests/deSugar/ds040.hs create mode 100644 ghc/compiler/tests/deSugar/ds040.stderr create mode 100644 ghc/compiler/tests/deriving/Jmakefile create mode 100644 ghc/compiler/tests/deriving/drv001.hs create mode 100644 ghc/compiler/tests/deriving/drv001.stderr create mode 100644 ghc/compiler/tests/deriving/drv002.hs create mode 100644 ghc/compiler/tests/deriving/drv002.stderr create mode 100644 ghc/compiler/tests/deriving/drv003.hs create mode 100644 ghc/compiler/tests/deriving/drv003.stderr create mode 100644 ghc/compiler/tests/deriving/drv004.hs create mode 100644 ghc/compiler/tests/deriving/drv004.stderr create mode 100644 ghc/compiler/tests/deriving/drv005.hs create mode 100644 ghc/compiler/tests/deriving/drv005.stderr create mode 100644 ghc/compiler/tests/deriving/drv006.hs create mode 100644 ghc/compiler/tests/deriving/drv006.stderr create mode 100644 ghc/compiler/tests/deriving/drv007.hs create mode 100644 ghc/compiler/tests/deriving/drv007.stderr create mode 100644 ghc/compiler/tests/printing/Jmakefile create mode 100644 ghc/compiler/tests/printing/Print001.hs create mode 100644 ghc/compiler/tests/printing/Print001.stderr create mode 100644 ghc/compiler/tests/printing/Print002.hs create mode 100644 ghc/compiler/tests/printing/Print002.stderr create mode 100644 ghc/compiler/tests/printing/Print003.hs create mode 100644 ghc/compiler/tests/printing/Print003.stderr create mode 100644 ghc/compiler/tests/printing/Print004.hs create mode 100644 ghc/compiler/tests/printing/Print004.stderr create mode 100644 ghc/compiler/tests/reader/Jmakefile create mode 100644 ghc/compiler/tests/reader/OneA.hi create mode 100644 ghc/compiler/tests/reader/OneB.hi create mode 100644 ghc/compiler/tests/reader/OneC.hi create mode 100644 ghc/compiler/tests/reader/expr001.hs create mode 100644 ghc/compiler/tests/reader/read001.hs create mode 100644 ghc/compiler/tests/reader/read001.stderr create mode 100644 ghc/compiler/tests/reader/read002.hs create mode 100644 ghc/compiler/tests/reader/read002.stderr create mode 100644 ghc/compiler/tests/reader/read003.hs create mode 100644 ghc/compiler/tests/reader/read004.hs create mode 100644 ghc/compiler/tests/reader/read004.stderr create mode 100644 ghc/compiler/tests/rename/Int10.hi create mode 100644 ghc/compiler/tests/rename/Jmakefile create mode 100644 ghc/compiler/tests/rename/Rn016.hi create mode 100644 ghc/compiler/tests/rename/Rn017.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Jmakefile create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Lexeme.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Lexer_Buffer.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Lexer_Combinators.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Lexer_Ops.lhs create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Lexer_State.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Lexer_Token.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Oberon_Id.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Oberon_Integer.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Oberon_Real.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Oberon_String.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Source_Position.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/Symbol.hi create mode 100644 ghc/compiler/tests/rename/bevan-bug-1/bevan-bug-1.stderr create mode 100644 ghc/compiler/tests/rename/rn001.hs create mode 100644 ghc/compiler/tests/rename/rn001.stderr create mode 100644 ghc/compiler/tests/rename/rn002.hs create mode 100644 ghc/compiler/tests/rename/rn002.stderr create mode 100644 ghc/compiler/tests/rename/rn003.hs create mode 100644 ghc/compiler/tests/rename/rn003.stderr create mode 100644 ghc/compiler/tests/rename/rn004.hs create mode 100644 ghc/compiler/tests/rename/rn004.stderr create mode 100644 ghc/compiler/tests/rename/rn005.hs create mode 100644 ghc/compiler/tests/rename/rn005.stderr create mode 100644 ghc/compiler/tests/rename/rn006.hs create mode 100644 ghc/compiler/tests/rename/rn006.stderr create mode 100644 ghc/compiler/tests/rename/rn007.hs create mode 100644 ghc/compiler/tests/rename/rn007.stderr create mode 100644 ghc/compiler/tests/rename/rn008.hs create mode 100644 ghc/compiler/tests/rename/rn008.stderr create mode 100644 ghc/compiler/tests/rename/rn009.hs create mode 100644 ghc/compiler/tests/rename/rn009.stderr create mode 100644 ghc/compiler/tests/rename/rn010.hs create mode 100644 ghc/compiler/tests/rename/rn010.stderr create mode 100644 ghc/compiler/tests/rename/rn011.hs create mode 100644 ghc/compiler/tests/rename/rn011.stderr create mode 100644 ghc/compiler/tests/rename/rn012.hs create mode 100644 ghc/compiler/tests/rename/rn012.stderr create mode 100644 ghc/compiler/tests/rename/rn013.hs create mode 100644 ghc/compiler/tests/rename/rn013.stderr create mode 100644 ghc/compiler/tests/rename/rn014.hs create mode 100644 ghc/compiler/tests/rename/rn014.stderr create mode 100644 ghc/compiler/tests/rename/rn015.hs create mode 100644 ghc/compiler/tests/rename/rn015.stderr create mode 100644 ghc/compiler/tests/rename/rn016.hs create mode 100644 ghc/compiler/tests/rename/rn016.stderr create mode 100644 ghc/compiler/tests/rename/rn017.hs create mode 100644 ghc/compiler/tests/rename/rn017.stderr create mode 100644 ghc/compiler/tests/rename/timing001.hs create mode 100644 ghc/compiler/tests/rename/timing002.hs create mode 100644 ghc/compiler/tests/rename/timing003.hs create mode 100644 ghc/compiler/tests/simplCore/Jmakefile create mode 100644 ghc/compiler/tests/simplCore/simpl001.hs create mode 100644 ghc/compiler/tests/simplCore/simpl001.stderr create mode 100644 ghc/compiler/tests/simplCore/simpl002.hs create mode 100644 ghc/compiler/tests/simplCore/simpl002.stderr create mode 100644 ghc/compiler/tests/stranal/default.lhs create mode 100644 ghc/compiler/tests/stranal/fact.lhs create mode 100644 ghc/compiler/tests/stranal/fun.lhs create mode 100644 ghc/compiler/tests/stranal/goo.lhs create mode 100644 ghc/compiler/tests/stranal/ins.lhs create mode 100644 ghc/compiler/tests/stranal/map.lhs create mode 100644 ghc/compiler/tests/stranal/moo.lhs create mode 100644 ghc/compiler/tests/stranal/sim.lhs create mode 100644 ghc/compiler/tests/stranal/syn.lhs create mode 100644 ghc/compiler/tests/stranal/test.lhs create mode 100644 ghc/compiler/tests/stranal/tst.lhs create mode 100644 ghc/compiler/tests/stranal/unu.lhs create mode 100644 ghc/compiler/tests/typecheck/Jmakefile create mode 100644 ghc/compiler/tests/typecheck/should_fail/Digraph.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/Digraph.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/Jmakefile create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail001.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail001.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail002.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail002.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail003.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail003.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail004.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail004.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail005.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail005.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail006.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail006.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail007.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail007.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail008.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail008.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail009.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail009.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail010.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail010.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail011.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail011.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail012.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail012.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail013.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail013.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail014.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail014.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail015.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail015.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail016.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail016.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail017.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail017.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail018.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail018.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail019.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail019.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail020.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail020.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail021.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail021.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail022.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail022.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail023.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail023.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail024.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail024.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail025.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail025.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail026.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail026.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail027.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail027.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail028.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail028.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail029.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail029.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail030.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail030.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail031.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail031.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail032.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail032.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail033.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail033.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail034.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail034.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail035.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail035.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail036.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail036.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail037.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail037.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail038.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail038.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail039.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail039.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail040.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail040.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail041.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail041.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail042.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail042.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail043.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail043.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail044.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail044.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail045.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail045.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail046.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail046.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail047.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail047.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail048.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail048.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail049.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail049.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail050.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail050.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail051.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail051.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail052.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail052.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail053.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail053.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail054.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail054.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail055.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail055.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail056.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail056.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail057.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail057.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail058.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail058.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail059.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail059.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail060.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail060.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail061.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail061.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail062.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail062.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail063.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail063.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail065.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail065.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail066.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail066.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail067.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail067.stderr create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail068.hs create mode 100644 ghc/compiler/tests/typecheck/should_fail/tcfail068.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/ClassFoo.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/Jmakefile create mode 100644 ghc/compiler/tests/typecheck/should_succeed/M.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/ShouldSucceed.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/TheUtils.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc001.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc001.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc002.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc002.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc003.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc003.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc004.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc004.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc005.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc005.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc006.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc006.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc007.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc007.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc008.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc008.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc009.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc009.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc010.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc010.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc011.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc011.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc012.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc012.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc013.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc013.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc014.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc014.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc015.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc015.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc016.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc016.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc017.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc017.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc018.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc018.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc019.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc019.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc020.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc020.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc021.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc021.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc022.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc022.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc023.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc023.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc024.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc024.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc025.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc025.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc026.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc026.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc027.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc027.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc028.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc028.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc029.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc029.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc030.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc030.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc031.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc031.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc032.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc032.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc033.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc033.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc034.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc034.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc035.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc035.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc036.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc036.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc037.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc037.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc037.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc038.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc038.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc039.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc039.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc040.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc040.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc040.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc041.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc041.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc042.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc042.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc043.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc043.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc044.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc044.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc045.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc045.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc046.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc046.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc047.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc047.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc048.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc048.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc049.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc049.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc050.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc050.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc051.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc051.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc052.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc052.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc053.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc053.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc054.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc054.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc055.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc055.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc056.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc056.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc057.hi create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc057.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc057.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc058.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc058.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc059.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc059.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc060.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc060.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc061.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc061.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc062.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc062.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc063.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc063.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc064.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc064.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc065.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc065.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc066.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc066.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc067.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc067.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc068.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc068.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc069.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc069.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc070.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc070.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc073.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc073.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc074.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc074.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc075.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc075.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc076.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc076.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc077.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc077.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc078.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc078.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc079.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc079.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc080.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc080.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc081.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc081.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc082.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc082.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc083.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc083.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc084.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc084.stderr create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc085.hs create mode 100644 ghc/compiler/tests/typecheck/should_succeed/tc085.stderr create mode 100644 ghc/compiler/tests/typecheck/stress/tcstress001.hs create mode 100644 ghc/compiler/tests/validation-misc/Echo.hs create mode 100644 ghc/compiler/tests/validation-misc/Jmakefile create mode 100644 ghc/compiler/tests/validation-misc/dotests create mode 100644 ghc/compiler/tests/validation-misc/naming001.hs create mode 100644 ghc/compiler/tests/validation-misc/naming002.hs create mode 100644 ghc/compiler/tests/validation-misc/naming003.hs create mode 100644 ghc/compiler/tests/validation-misc/naming004.hs create mode 100644 ghc/compiler/tests/validation-misc/naming005.hs create mode 100644 ghc/compiler/tests/validation-misc/testexpr.hs create mode 100644 ghc/compiler/tests/validation-misc/testgrhss.hs create mode 100644 ghc/compiler/tests/validation-misc/testmatches.hs create mode 100644 ghc/compiler/tests/validation-misc/testmonobinds.hs create mode 100644 ghc/compiler/tests/validation-misc/testmrule.hs create mode 100644 ghc/compiler/tests/validation-misc/testpats.hs create mode 100644 ghc/compiler/tests/wdp-array.hs create mode 100644 ghc/compiler/tests/wdp-otherwise.hs create mode 100644 ghc/compiler/tests/wdp-ppr.hs create mode 100644 ghc/compiler/tests/wdp-prel-insts.hs create mode 100644 ghc/compiler/typecheck/BackSubst.hi create mode 100644 ghc/compiler/typecheck/BackSubst.lhs create mode 100644 ghc/compiler/typecheck/Disambig.hi create mode 100644 ghc/compiler/typecheck/Disambig.lhs create mode 100644 ghc/compiler/typecheck/GenSpecEtc.hi create mode 100644 ghc/compiler/typecheck/GenSpecEtc.lhs create mode 100644 ghc/compiler/typecheck/Jmakefile create mode 100644 ghc/compiler/typecheck/Spec.hi create mode 100644 ghc/compiler/typecheck/Spec.lhs create mode 100644 ghc/compiler/typecheck/Subst.hi create mode 100644 ghc/compiler/typecheck/Subst.lhs create mode 100644 ghc/compiler/typecheck/TcBinds.hi create mode 100644 ghc/compiler/typecheck/TcBinds.lhs create mode 100644 ghc/compiler/typecheck/TcClassDcl.hi create mode 100644 ghc/compiler/typecheck/TcClassDcl.lhs create mode 100644 ghc/compiler/typecheck/TcClassSig.hi create mode 100644 ghc/compiler/typecheck/TcClassSig.lhs create mode 100644 ghc/compiler/typecheck/TcConDecls.hi create mode 100644 ghc/compiler/typecheck/TcConDecls.lhs create mode 100644 ghc/compiler/typecheck/TcContext.hi create mode 100644 ghc/compiler/typecheck/TcContext.lhs create mode 100644 ghc/compiler/typecheck/TcDefaults.hi create mode 100644 ghc/compiler/typecheck/TcDefaults.lhs create mode 100644 ghc/compiler/typecheck/TcDeriv.hi create mode 100644 ghc/compiler/typecheck/TcDeriv.lhs create mode 100644 ghc/compiler/typecheck/TcExpr.hi create mode 100644 ghc/compiler/typecheck/TcExpr.lhs create mode 100644 ghc/compiler/typecheck/TcGRHSs.hi create mode 100644 ghc/compiler/typecheck/TcGRHSs.lhs create mode 100644 ghc/compiler/typecheck/TcGenDeriv.hi create mode 100644 ghc/compiler/typecheck/TcGenDeriv.lhs create mode 100644 ghc/compiler/typecheck/TcIfaceSig.hi create mode 100644 ghc/compiler/typecheck/TcIfaceSig.lhs create mode 100644 ghc/compiler/typecheck/TcInstDcls.hi create mode 100644 ghc/compiler/typecheck/TcInstDcls.lhs create mode 100644 ghc/compiler/typecheck/TcMatches.hi create mode 100644 ghc/compiler/typecheck/TcMatches.lhs create mode 100644 ghc/compiler/typecheck/TcModule.hi create mode 100644 ghc/compiler/typecheck/TcModule.lhs create mode 100644 ghc/compiler/typecheck/TcMonad.hi create mode 100644 ghc/compiler/typecheck/TcMonad.lhs create mode 100644 ghc/compiler/typecheck/TcMonadFns.hi create mode 100644 ghc/compiler/typecheck/TcMonadFns.lhs create mode 100644 ghc/compiler/typecheck/TcMonoBnds.hi create mode 100644 ghc/compiler/typecheck/TcMonoBnds.lhs create mode 100644 ghc/compiler/typecheck/TcMonoType.hi create mode 100644 ghc/compiler/typecheck/TcMonoType.lhs create mode 100644 ghc/compiler/typecheck/TcParQuals.lhs create mode 100644 ghc/compiler/typecheck/TcPat.hi create mode 100644 ghc/compiler/typecheck/TcPat.lhs create mode 100644 ghc/compiler/typecheck/TcPolyType.hi create mode 100644 ghc/compiler/typecheck/TcPolyType.lhs create mode 100644 ghc/compiler/typecheck/TcPragmas.hi create mode 100644 ghc/compiler/typecheck/TcPragmas.lhs create mode 100644 ghc/compiler/typecheck/TcQuals.hi create mode 100644 ghc/compiler/typecheck/TcQuals.lhs create mode 100644 ghc/compiler/typecheck/TcSimplify.hi create mode 100644 ghc/compiler/typecheck/TcSimplify.lhs create mode 100644 ghc/compiler/typecheck/TcTyDecls.hi create mode 100644 ghc/compiler/typecheck/TcTyDecls.lhs create mode 100644 ghc/compiler/typecheck/Typecheck.hi create mode 100644 ghc/compiler/typecheck/Typecheck.lhs create mode 100644 ghc/compiler/typecheck/Unify.hi create mode 100644 ghc/compiler/typecheck/Unify.lhs create mode 100644 ghc/compiler/typecheck/root.lit create mode 100644 ghc/compiler/uniType/AbsUniType.hi create mode 100644 ghc/compiler/uniType/AbsUniType.lhs create mode 100644 ghc/compiler/uniType/Class.hi create mode 100644 ghc/compiler/uniType/Class.lhs create mode 100644 ghc/compiler/uniType/TyCon.hi create mode 100644 ghc/compiler/uniType/TyCon.lhs create mode 100644 ghc/compiler/uniType/TyVar.hi create mode 100644 ghc/compiler/uniType/TyVar.lhs create mode 100644 ghc/compiler/uniType/UniTyFuns.hi create mode 100644 ghc/compiler/uniType/UniTyFuns.lhs create mode 100644 ghc/compiler/uniType/UniType.hi create mode 100644 ghc/compiler/uniType/UniType.lhs create mode 100644 ghc/compiler/utils/Bag.hi create mode 100644 ghc/compiler/utils/Bag.lhs create mode 100644 ghc/compiler/utils/BitSet.hi create mode 100644 ghc/compiler/utils/BitSet.lhs create mode 100644 ghc/compiler/utils/CharSeq.hi create mode 100644 ghc/compiler/utils/CharSeq.lhs create mode 100644 ghc/compiler/utils/Digraph.hi create mode 100644 ghc/compiler/utils/Digraph.lhs create mode 100644 ghc/compiler/utils/FiniteMap.hi create mode 100644 ghc/compiler/utils/FiniteMap.lhs create mode 100644 ghc/compiler/utils/LiftMonad.hi create mode 100644 ghc/compiler/utils/LiftMonad.lhs create mode 100644 ghc/compiler/utils/ListSetOps.hi create mode 100644 ghc/compiler/utils/ListSetOps.lhs create mode 100644 ghc/compiler/utils/Maybes.hi create mode 100644 ghc/compiler/utils/Maybes.lhs create mode 100644 ghc/compiler/utils/Outputable.hi create mode 100644 ghc/compiler/utils/Outputable.lhs create mode 100644 ghc/compiler/utils/Pretty.hi create mode 100644 ghc/compiler/utils/Pretty.lhs create mode 100644 ghc/compiler/utils/UniqFM.hi create mode 100644 ghc/compiler/utils/UniqFM.lhs create mode 100644 ghc/compiler/utils/UniqSet.hi create mode 100644 ghc/compiler/utils/UniqSet.lhs create mode 100644 ghc/compiler/utils/Unpretty.hi create mode 100644 ghc/compiler/utils/Unpretty.lhs create mode 100644 ghc/compiler/utils/Util.hi create mode 100644 ghc/compiler/utils/Util.lhs create mode 100644 ghc/compiler/yaccParser/Jmakefile create mode 100644 ghc/compiler/yaccParser/MAIL.byacc create mode 100644 ghc/compiler/yaccParser/README-DPH create mode 100644 ghc/compiler/yaccParser/README.debug create mode 100644 ghc/compiler/yaccParser/U_atype.hi create mode 100644 ghc/compiler/yaccParser/U_atype.hs create mode 100644 ghc/compiler/yaccParser/U_binding.hi create mode 100644 ghc/compiler/yaccParser/U_binding.hs create mode 100644 ghc/compiler/yaccParser/U_coresyn.hi create mode 100644 ghc/compiler/yaccParser/U_coresyn.hs create mode 100644 ghc/compiler/yaccParser/U_entidt.hi create mode 100644 ghc/compiler/yaccParser/U_entidt.hs create mode 100644 ghc/compiler/yaccParser/U_finfot.hi create mode 100644 ghc/compiler/yaccParser/U_finfot.hs create mode 100644 ghc/compiler/yaccParser/U_hpragma.hi create mode 100644 ghc/compiler/yaccParser/U_hpragma.hs create mode 100644 ghc/compiler/yaccParser/U_list.hi create mode 100644 ghc/compiler/yaccParser/U_list.hs create mode 100644 ghc/compiler/yaccParser/U_literal.hi create mode 100644 ghc/compiler/yaccParser/U_literal.hs create mode 100644 ghc/compiler/yaccParser/U_pbinding.hi create mode 100644 ghc/compiler/yaccParser/U_pbinding.hs create mode 100644 ghc/compiler/yaccParser/U_tree.hs create mode 100644 ghc/compiler/yaccParser/U_treeHACK.hi create mode 100644 ghc/compiler/yaccParser/U_treeHACK.hs create mode 100644 ghc/compiler/yaccParser/U_ttype.hi create mode 100644 ghc/compiler/yaccParser/U_ttype.hs create mode 100644 ghc/compiler/yaccParser/UgenAll.hi create mode 100644 ghc/compiler/yaccParser/UgenAll.lhs create mode 100644 ghc/compiler/yaccParser/UgenUtil.hi create mode 100644 ghc/compiler/yaccParser/UgenUtil.lhs create mode 100644 ghc/compiler/yaccParser/atype.c create mode 100644 ghc/compiler/yaccParser/atype.h create mode 100644 ghc/compiler/yaccParser/atype.ugn create mode 100644 ghc/compiler/yaccParser/binding.c create mode 100644 ghc/compiler/yaccParser/binding.h create mode 100644 ghc/compiler/yaccParser/binding.ugn create mode 100644 ghc/compiler/yaccParser/constants.h create mode 100644 ghc/compiler/yaccParser/coresyn.c create mode 100644 ghc/compiler/yaccParser/coresyn.h create mode 100644 ghc/compiler/yaccParser/coresyn.ugn create mode 100644 ghc/compiler/yaccParser/entidt.c create mode 100644 ghc/compiler/yaccParser/entidt.h create mode 100644 ghc/compiler/yaccParser/entidt.ugn create mode 100644 ghc/compiler/yaccParser/finfot.c create mode 100644 ghc/compiler/yaccParser/finfot.h create mode 100644 ghc/compiler/yaccParser/finfot.ugn create mode 100644 ghc/compiler/yaccParser/hpragma.c create mode 100644 ghc/compiler/yaccParser/hpragma.h create mode 100644 ghc/compiler/yaccParser/hpragma.ugn create mode 100644 ghc/compiler/yaccParser/hschooks.c create mode 100644 ghc/compiler/yaccParser/hsclink.c create mode 100644 ghc/compiler/yaccParser/hslexer-DPH.lex create mode 100644 ghc/compiler/yaccParser/hslexer.c create mode 100644 ghc/compiler/yaccParser/hslexer.flex create mode 100644 ghc/compiler/yaccParser/hsparser-DPH.y create mode 100644 ghc/compiler/yaccParser/hsparser.tab.c create mode 100644 ghc/compiler/yaccParser/hsparser.tab.h create mode 100644 ghc/compiler/yaccParser/hsparser.y create mode 100644 ghc/compiler/yaccParser/hspincl.h create mode 100644 ghc/compiler/yaccParser/id.c create mode 100644 ghc/compiler/yaccParser/id.h create mode 100644 ghc/compiler/yaccParser/impidt.c create mode 100644 ghc/compiler/yaccParser/impidt.h create mode 100644 ghc/compiler/yaccParser/import_dirlist.c create mode 100644 ghc/compiler/yaccParser/infix.c create mode 100644 ghc/compiler/yaccParser/list.c create mode 100644 ghc/compiler/yaccParser/list.h create mode 100644 ghc/compiler/yaccParser/list.ugn create mode 100644 ghc/compiler/yaccParser/listcomp.c create mode 100644 ghc/compiler/yaccParser/literal.c create mode 100644 ghc/compiler/yaccParser/literal.h create mode 100644 ghc/compiler/yaccParser/literal.ugn create mode 100644 ghc/compiler/yaccParser/main.c create mode 100644 ghc/compiler/yaccParser/pbinding.c create mode 100644 ghc/compiler/yaccParser/pbinding.h create mode 100644 ghc/compiler/yaccParser/pbinding.ugn create mode 100644 ghc/compiler/yaccParser/printtree.c create mode 100644 ghc/compiler/yaccParser/syntax.c create mode 100644 ghc/compiler/yaccParser/tests/Jmakefile create mode 100644 ghc/compiler/yaccParser/tree-DPH.ugn create mode 100644 ghc/compiler/yaccParser/tree.c create mode 100644 ghc/compiler/yaccParser/tree.h create mode 100644 ghc/compiler/yaccParser/tree.ugn create mode 100644 ghc/compiler/yaccParser/ttype-DPH.ugn create mode 100644 ghc/compiler/yaccParser/ttype.c create mode 100644 ghc/compiler/yaccParser/ttype.h create mode 100644 ghc/compiler/yaccParser/ttype.ugn create mode 100644 ghc/compiler/yaccParser/type2context.c create mode 100644 ghc/compiler/yaccParser/util.c create mode 100644 ghc/compiler/yaccParser/utils.h create mode 100644 ghc/docs/ANNOUNCE-0.06 create mode 100644 ghc/docs/ANNOUNCE-0.10 create mode 100644 ghc/docs/ANNOUNCE-0.16 create mode 100644 ghc/docs/ANNOUNCE-0.19 create mode 100644 ghc/docs/ANNOUNCE-0.20 create mode 100644 ghc/docs/ANNOUNCE-0.22 create mode 100644 ghc/docs/ANNOUNCE-0.23 create mode 100644 ghc/docs/ANNOUNCE-0.25 create mode 100644 ghc/docs/Jmakefile create mode 100644 ghc/docs/NOTES.adding-PrimOp create mode 100644 ghc/docs/NOTES.arbitary-ints create mode 100644 ghc/docs/NOTES.c-optimisation create mode 100644 ghc/docs/NOTES.core-overview create mode 100644 ghc/docs/NOTES.desugar create mode 100644 ghc/docs/NOTES.garbage.collection create mode 100644 ghc/docs/NOTES.import create mode 100644 ghc/docs/NOTES.interface create mode 100644 ghc/docs/NOTES.mkworld2 create mode 100644 ghc/docs/NOTES.part-of-book create mode 100644 ghc/docs/NOTES.rename create mode 100644 ghc/docs/NOTES.saving-space create mode 100644 ghc/docs/NOTES.update-mechanism create mode 100644 ghc/docs/Prefix_Form create mode 100644 ghc/docs/README create mode 100644 ghc/docs/abstracts/README create mode 100644 ghc/docs/abstracts/abstracts.sty create mode 100644 ghc/docs/abstracts/abstracts89.tex create mode 100644 ghc/docs/abstracts/abstracts90.tex create mode 100644 ghc/docs/abstracts/abstracts91.tex create mode 100644 ghc/docs/abstracts/abstracts92.tex create mode 100644 ghc/docs/abstracts/abstracts93.tex create mode 100644 ghc/docs/abstracts/abstracts94.tex create mode 100644 ghc/docs/abstracts/before90.tex create mode 100644 ghc/docs/abstracts/reports.tex create mode 100644 ghc/docs/abstracts/slpj.sty create mode 100644 ghc/docs/abstracts/useful.sty create mode 100644 ghc/docs/add_to_compiler/Jmakefile create mode 100644 ghc/docs/add_to_compiler/back-end.verb create mode 100644 ghc/docs/add_to_compiler/core-summary-fig.verb create mode 100644 ghc/docs/add_to_compiler/core-syntax.verb create mode 100644 ghc/docs/add_to_compiler/front-end.verb create mode 100644 ghc/docs/add_to_compiler/howto-add.verb create mode 100644 ghc/docs/add_to_compiler/overview-fig.fig create mode 100644 ghc/docs/add_to_compiler/overview.verb create mode 100644 ghc/docs/add_to_compiler/paper.bbl create mode 100644 ghc/docs/add_to_compiler/paper.verb create mode 100644 ghc/docs/add_to_compiler/slides-root.tex create mode 100644 ghc/docs/add_to_compiler/slides.tex create mode 100644 ghc/docs/add_to_compiler/state-of-play.NOTES create mode 100644 ghc/docs/add_to_compiler/state-of-play.verb create mode 100644 ghc/docs/add_to_compiler/stg-summary-fig.verb create mode 100644 ghc/docs/grasp.sty create mode 100644 ghc/docs/install_guide/Jmakefile create mode 100644 ghc/docs/install_guide/installing.lit create mode 100644 ghc/docs/release_notes/0-02-notes.lit create mode 100644 ghc/docs/release_notes/0-03-README create mode 100644 ghc/docs/release_notes/0-04-README create mode 100644 ghc/docs/release_notes/0-05-notes.lit create mode 100644 ghc/docs/release_notes/0-06-notes.lit create mode 100644 ghc/docs/release_notes/0-07-README create mode 100644 ghc/docs/release_notes/0-07-notes.lit create mode 100644 ghc/docs/release_notes/0-08-notes.lit create mode 100644 ghc/docs/release_notes/0-10-notes.lit create mode 100644 ghc/docs/release_notes/0-16-notes.lit create mode 100644 ghc/docs/release_notes/0-17-notes.lit create mode 100644 ghc/docs/release_notes/0-18-README create mode 100644 ghc/docs/release_notes/0-19-notes.lit create mode 100644 ghc/docs/release_notes/0-22-notes.lit create mode 100644 ghc/docs/release_notes/0-23-notes.lit create mode 100644 ghc/docs/release_notes/0-26-notes.lit create mode 100644 ghc/docs/release_notes/Jmakefile create mode 100644 ghc/docs/release_notes/real-soon-now.lit create mode 100644 ghc/docs/release_notes/release.lit create mode 100644 ghc/docs/simple-monad.lhs create mode 100644 ghc/docs/users_guide/Jmakefile create mode 100644 ghc/docs/users_guide/glasgow_exts.lit create mode 100644 ghc/docs/users_guide/gone_wrong.lit create mode 100644 ghc/docs/users_guide/how_to_run.lit create mode 100644 ghc/docs/users_guide/intro.lit create mode 100644 ghc/docs/users_guide/libraries.lit create mode 100644 ghc/docs/users_guide/parallel.lit create mode 100644 ghc/docs/users_guide/prof-compiler-options.lit create mode 100644 ghc/docs/users_guide/prof-options.lit create mode 100644 ghc/docs/users_guide/prof-post-processors.lit create mode 100644 ghc/docs/users_guide/prof-reports.lit create mode 100644 ghc/docs/users_guide/prof-rts-options.lit create mode 100644 ghc/docs/users_guide/profiling.lit create mode 100644 ghc/docs/users_guide/runtime_control.lit create mode 100644 ghc/docs/users_guide/sooner.lit create mode 100644 ghc/docs/users_guide/ticky.lit create mode 100644 ghc/docs/users_guide/tutorial.lit create mode 100644 ghc/docs/users_guide/user.lit create mode 100644 ghc/docs/users_guide/utils.lit create mode 100644 ghc/docs/users_guide/vs_haskell.lit create mode 100644 ghc/driver/Jmakefile create mode 100644 ghc/driver/driver.lit create mode 100644 ghc/driver/ghc-asm-alpha.lprl create mode 100644 ghc/driver/ghc-asm-hppa.lprl create mode 100644 ghc/driver/ghc-asm-iX86.lprl create mode 100644 ghc/driver/ghc-asm-m68k.lprl create mode 100644 ghc/driver/ghc-asm-mips.lprl create mode 100644 ghc/driver/ghc-asm-sgi.prl create mode 100644 ghc/driver/ghc-asm-solaris.lprl create mode 100644 ghc/driver/ghc-asm-sparc.lprl create mode 100644 ghc/driver/ghc-consist.lprl create mode 100644 ghc/driver/ghc-split.lprl create mode 100644 ghc/driver/ghc.lprl create mode 100644 ghc/driver/ordering-passes create mode 100644 ghc/driver/test_mangler create mode 100644 ghc/glue_TAGS_files.prl create mode 100644 ghc/includes/AgeProfile.lh create mode 100644 ghc/includes/COptJumps.lh create mode 100644 ghc/includes/COptRegs.lh create mode 100644 ghc/includes/COptWraps.lh create mode 100644 ghc/includes/CostCentre.lh create mode 100644 ghc/includes/Force_GC.lh create mode 100644 ghc/includes/GhcConstants.lh create mode 100644 ghc/includes/GranSim.lh create mode 100644 ghc/includes/HLC.h create mode 100644 ghc/includes/Info.lh create mode 100644 ghc/includes/Jmakefile create mode 100644 ghc/includes/LLC.h create mode 100644 ghc/includes/MachRegs.lh create mode 100644 ghc/includes/NativeGen.h create mode 100644 ghc/includes/PEOpCodes.h create mode 100644 ghc/includes/Parallel.lh create mode 100644 ghc/includes/RednCounts.lh create mode 100644 ghc/includes/SMClosures.lh create mode 100644 ghc/includes/SMInfoTables.lh create mode 100644 ghc/includes/SMcompact.lh create mode 100644 ghc/includes/SMcopying.lh create mode 100644 ghc/includes/SMinterface.lh create mode 100644 ghc/includes/SMmark.lh create mode 100644 ghc/includes/SMupdate.lh create mode 100644 ghc/includes/StgDirections.h create mode 100644 ghc/includes/StgMachDeps.h create mode 100644 ghc/includes/StgMacros.lh create mode 100644 ghc/includes/StgRegs.lh create mode 100644 ghc/includes/StgTypes.lh create mode 100644 ghc/includes/Threads.lh create mode 100644 ghc/includes/c-as-asm.lit create mode 100644 ghc/includes/closure.ps create mode 100644 ghc/includes/config.h.in create mode 100644 ghc/includes/error.h create mode 100644 ghc/includes/ghcReadline.h create mode 100644 ghc/includes/ghcRegex.h create mode 100644 ghc/includes/ghcSockets.h create mode 100644 ghc/includes/gmp.h create mode 100644 ghc/includes/ieee-flpt.h create mode 100644 ghc/includes/libposix.h create mode 100644 ghc/includes/mkNativeHdr.lc create mode 100644 ghc/includes/platform.h.in create mode 100644 ghc/includes/pvm3.h create mode 100644 ghc/includes/root.lit create mode 100644 ghc/includes/rtsTypes.lh create mode 100644 ghc/includes/rtsdefs.h create mode 100644 ghc/includes/sparc-sun-sunos4.h create mode 100644 ghc/includes/stgdefs.h create mode 100644 ghc/includes/stgio.h create mode 100644 ghc/includes/timezone.h create mode 100644 ghc/includes/update-frame.ps create mode 100644 ghc/lib/Jmakefile create mode 100644 ghc/lib/README create mode 100644 ghc/lib/ghc/BSD.hi create mode 100644 ghc/lib/ghc/BSD.lhs create mode 100644 ghc/lib/ghc/BSD_mc.hi create mode 100644 ghc/lib/ghc/BSD_mg.hi create mode 100644 ghc/lib/ghc/BSD_mp.hi create mode 100644 ghc/lib/ghc/BSD_p.hi create mode 100644 ghc/lib/ghc/BSD_t.hi create mode 100644 ghc/lib/ghc/Bag.hi create mode 100644 ghc/lib/ghc/Bag.lhs create mode 100644 ghc/lib/ghc/Bag_mc.hi create mode 100644 ghc/lib/ghc/Bag_mg.hi create mode 100644 ghc/lib/ghc/Bag_mp.hi create mode 100644 ghc/lib/ghc/Bag_mr.hi create mode 100644 ghc/lib/ghc/Bag_mt.hi create mode 100644 ghc/lib/ghc/Bag_p.hi create mode 100644 ghc/lib/ghc/Bag_t.hi create mode 100644 ghc/lib/ghc/BitSet.hi create mode 100644 ghc/lib/ghc/BitSet.lhs create mode 100644 ghc/lib/ghc/BitSet_mc.hi create mode 100644 ghc/lib/ghc/BitSet_mg.hi create mode 100644 ghc/lib/ghc/BitSet_mp.hi create mode 100644 ghc/lib/ghc/BitSet_mr.hi create mode 100644 ghc/lib/ghc/BitSet_mt.hi create mode 100644 ghc/lib/ghc/BitSet_p.hi create mode 100644 ghc/lib/ghc/BitSet_t.hi create mode 100644 ghc/lib/ghc/CError.hi create mode 100644 ghc/lib/ghc/CError.lhs create mode 100644 ghc/lib/ghc/CError_mc.hi create mode 100644 ghc/lib/ghc/CError_mg.hi create mode 100644 ghc/lib/ghc/CError_mp.hi create mode 100644 ghc/lib/ghc/CError_p.hi create mode 100644 ghc/lib/ghc/CError_t.hi create mode 100644 ghc/lib/ghc/CharSeq.hi create mode 100644 ghc/lib/ghc/CharSeq.lhs create mode 100644 ghc/lib/ghc/CharSeq_mc.hi create mode 100644 ghc/lib/ghc/CharSeq_mg.hi create mode 100644 ghc/lib/ghc/CharSeq_mp.hi create mode 100644 ghc/lib/ghc/CharSeq_mr.hi create mode 100644 ghc/lib/ghc/CharSeq_mt.hi create mode 100644 ghc/lib/ghc/CharSeq_p.hi create mode 100644 ghc/lib/ghc/CharSeq_t.hi create mode 100644 ghc/lib/ghc/FiniteMap.hi create mode 100644 ghc/lib/ghc/FiniteMap.lhs create mode 100644 ghc/lib/ghc/FiniteMap_mc.hi create mode 100644 ghc/lib/ghc/FiniteMap_mg.hi create mode 100644 ghc/lib/ghc/FiniteMap_mp.hi create mode 100644 ghc/lib/ghc/FiniteMap_mr.hi create mode 100644 ghc/lib/ghc/FiniteMap_mt.hi create mode 100644 ghc/lib/ghc/FiniteMap_p.hi create mode 100644 ghc/lib/ghc/FiniteMap_t.hi create mode 100644 ghc/lib/ghc/ListSetOps.hi create mode 100644 ghc/lib/ghc/ListSetOps.lhs create mode 100644 ghc/lib/ghc/ListSetOps_mc.hi create mode 100644 ghc/lib/ghc/ListSetOps_mg.hi create mode 100644 ghc/lib/ghc/ListSetOps_mp.hi create mode 100644 ghc/lib/ghc/ListSetOps_mr.hi create mode 100644 ghc/lib/ghc/ListSetOps_mt.hi create mode 100644 ghc/lib/ghc/ListSetOps_p.hi create mode 100644 ghc/lib/ghc/ListSetOps_t.hi create mode 100644 ghc/lib/ghc/MatchPS.hi create mode 100644 ghc/lib/ghc/MatchPS.lhs create mode 100644 ghc/lib/ghc/MatchPS_mc.hi create mode 100644 ghc/lib/ghc/MatchPS_mg.hi create mode 100644 ghc/lib/ghc/MatchPS_mp.hi create mode 100644 ghc/lib/ghc/MatchPS_p.hi create mode 100644 ghc/lib/ghc/MatchPS_t.hi create mode 100644 ghc/lib/ghc/Maybes.hi create mode 100644 ghc/lib/ghc/Maybes.lhs create mode 100644 ghc/lib/ghc/Maybes_mc.hi create mode 100644 ghc/lib/ghc/Maybes_mg.hi create mode 100644 ghc/lib/ghc/Maybes_mp.hi create mode 100644 ghc/lib/ghc/Maybes_mr.hi create mode 100644 ghc/lib/ghc/Maybes_mt.hi create mode 100644 ghc/lib/ghc/Maybes_p.hi create mode 100644 ghc/lib/ghc/Maybes_t.hi create mode 100644 ghc/lib/ghc/PackedString.hi create mode 100644 ghc/lib/ghc/PackedString.lhs create mode 100644 ghc/lib/ghc/PackedString_mc.hi create mode 100644 ghc/lib/ghc/PackedString_mg.hi create mode 100644 ghc/lib/ghc/PackedString_mp.hi create mode 100644 ghc/lib/ghc/PackedString_mr.hi create mode 100644 ghc/lib/ghc/PackedString_mt.hi create mode 100644 ghc/lib/ghc/PackedString_p.hi create mode 100644 ghc/lib/ghc/PackedString_t.hi create mode 100644 ghc/lib/ghc/Pretty.hi create mode 100644 ghc/lib/ghc/Pretty.lhs create mode 100644 ghc/lib/ghc/Pretty_mc.hi create mode 100644 ghc/lib/ghc/Pretty_mg.hi create mode 100644 ghc/lib/ghc/Pretty_mp.hi create mode 100644 ghc/lib/ghc/Pretty_mr.hi create mode 100644 ghc/lib/ghc/Pretty_mt.hi create mode 100644 ghc/lib/ghc/Pretty_p.hi create mode 100644 ghc/lib/ghc/Pretty_t.hi create mode 100644 ghc/lib/ghc/Readline.hi create mode 100644 ghc/lib/ghc/Readline.lhs create mode 100644 ghc/lib/ghc/Readline_mc.hi create mode 100644 ghc/lib/ghc/Readline_mg.hi create mode 100644 ghc/lib/ghc/Readline_mp.hi create mode 100644 ghc/lib/ghc/Readline_p.hi create mode 100644 ghc/lib/ghc/Readline_t.hi create mode 100644 ghc/lib/ghc/Regex.hi create mode 100644 ghc/lib/ghc/Regex.lhs create mode 100644 ghc/lib/ghc/Regex_mc.hi create mode 100644 ghc/lib/ghc/Regex_mg.hi create mode 100644 ghc/lib/ghc/Regex_mp.hi create mode 100644 ghc/lib/ghc/Regex_p.hi create mode 100644 ghc/lib/ghc/Regex_t.hi create mode 100644 ghc/lib/ghc/Set.hi create mode 100644 ghc/lib/ghc/Set.lhs create mode 100644 ghc/lib/ghc/Set_mc.hi create mode 100644 ghc/lib/ghc/Set_mg.hi create mode 100644 ghc/lib/ghc/Set_mp.hi create mode 100644 ghc/lib/ghc/Set_mr.hi create mode 100644 ghc/lib/ghc/Set_mt.hi create mode 100644 ghc/lib/ghc/Set_p.hi create mode 100644 ghc/lib/ghc/Set_t.hi create mode 100644 ghc/lib/ghc/Socket.hi create mode 100644 ghc/lib/ghc/Socket.lhs create mode 100644 ghc/lib/ghc/SocketPrim.hi create mode 100644 ghc/lib/ghc/SocketPrim.lhs create mode 100644 ghc/lib/ghc/SocketPrim_mc.hi create mode 100644 ghc/lib/ghc/SocketPrim_mg.hi create mode 100644 ghc/lib/ghc/SocketPrim_mp.hi create mode 100644 ghc/lib/ghc/SocketPrim_p.hi create mode 100644 ghc/lib/ghc/SocketPrim_t.hi create mode 100644 ghc/lib/ghc/Socket_mc.hi create mode 100644 ghc/lib/ghc/Socket_mg.hi create mode 100644 ghc/lib/ghc/Socket_mp.hi create mode 100644 ghc/lib/ghc/Socket_p.hi create mode 100644 ghc/lib/ghc/Socket_t.hi create mode 100644 ghc/lib/ghc/Util.hi create mode 100644 ghc/lib/ghc/Util.lhs create mode 100644 ghc/lib/ghc/Util_mc.hi create mode 100644 ghc/lib/ghc/Util_mg.hi create mode 100644 ghc/lib/ghc/Util_mp.hi create mode 100644 ghc/lib/ghc/Util_mr.hi create mode 100644 ghc/lib/ghc/Util_mt.hi create mode 100644 ghc/lib/ghc/Util_p.hi create mode 100644 ghc/lib/ghc/Util_t.hi create mode 100644 ghc/lib/glaExts/ByteOps.hi create mode 100644 ghc/lib/glaExts/ByteOps.lhs create mode 100644 ghc/lib/glaExts/ByteOps_mc.hi create mode 100644 ghc/lib/glaExts/ByteOps_mg.hi create mode 100644 ghc/lib/glaExts/ByteOps_mp.hi create mode 100644 ghc/lib/glaExts/ByteOps_mr.hi create mode 100644 ghc/lib/glaExts/ByteOps_mt.hi create mode 100644 ghc/lib/glaExts/ByteOps_p.hi create mode 100644 ghc/lib/glaExts/ByteOps_t.hi create mode 100644 ghc/lib/glaExts/Jmakefile create mode 100644 ghc/lib/glaExts/MainIO.lhs create mode 100644 ghc/lib/glaExts/MainIO13.hi create mode 100644 ghc/lib/glaExts/MainIO13.lhs create mode 100644 ghc/lib/glaExts/MainIO13_mc.hi create mode 100644 ghc/lib/glaExts/MainIO13_mg.hi create mode 100644 ghc/lib/glaExts/MainIO13_mp.hi create mode 100644 ghc/lib/glaExts/MainIO13_mr.hi create mode 100644 ghc/lib/glaExts/MainIO13_mt.hi create mode 100644 ghc/lib/glaExts/MainIO13_p.hi create mode 100644 ghc/lib/glaExts/MainIO13_t.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO.lhs create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_mc.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_mg.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_mp.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_mr.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_mt.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_p.hi create mode 100644 ghc/lib/glaExts/PreludeDialogueIO_t.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO.lhs create mode 100644 ghc/lib/glaExts/PreludeErrIO_mc.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO_mg.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO_mp.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO_mr.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO_mt.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO_p.hi create mode 100644 ghc/lib/glaExts/PreludeErrIO_t.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc.lhs create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_mc.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_mg.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_mp.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_mr.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_mt.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_p.hi create mode 100644 ghc/lib/glaExts/PreludeGlaMisc_t.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST.lhs create mode 100644 ghc/lib/glaExts/PreludeGlaST_mc.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST_mg.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST_mp.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST_mr.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST_mt.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST_p.hi create mode 100644 ghc/lib/glaExts/PreludeGlaST_t.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_1s.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_2s.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_du.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_i.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_j.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_k.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_l.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_m.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_mc.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_mg.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_mp.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_mr.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_mt.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_n.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_o.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_p.hi create mode 100644 ghc/lib/glaExts/PreludeMain13_help_t.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_1s.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_2s.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_du.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_i.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_j.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_k.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_l.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_m.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_mc.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_mg.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_mp.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_mr.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_mt.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_n.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_o.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_p.hi create mode 100644 ghc/lib/glaExts/PreludeMainIO_help_t.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO.lhs create mode 100644 ghc/lib/glaExts/PreludePrimIO_mc.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO_mg.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO_mp.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO_mr.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO_mt.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO_p.hi create mode 100644 ghc/lib/glaExts/PreludePrimIO_t.hi create mode 100644 ghc/lib/glaExts/Stdio.hi create mode 100644 ghc/lib/glaExts/Stdio.lhs create mode 100644 ghc/lib/glaExts/Stdio_mc.hi create mode 100644 ghc/lib/glaExts/Stdio_mg.hi create mode 100644 ghc/lib/glaExts/Stdio_mp.hi create mode 100644 ghc/lib/glaExts/Stdio_mr.hi create mode 100644 ghc/lib/glaExts/Stdio_mt.hi create mode 100644 ghc/lib/glaExts/Stdio_p.hi create mode 100644 ghc/lib/glaExts/Stdio_t.hi create mode 100644 ghc/lib/glaExts/lazyimp.lit create mode 100644 ghc/lib/haskell-1.3/LibCPUTime.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime.lhs create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_p.hi create mode 100644 ghc/lib/haskell-1.3/LibCPUTime_t.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory.lhs create mode 100644 ghc/lib/haskell-1.3/LibDirectory_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory_p.hi create mode 100644 ghc/lib/haskell-1.3/LibDirectory_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixDB.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixDB_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixErr_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixFiles_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixIO_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcEnv_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixProcPrim_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixTTY_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil.lhs create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosixUtil_t.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_p.hi create mode 100644 ghc/lib/haskell-1.3/LibPosix_t.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem.lhs create mode 100644 ghc/lib/haskell-1.3/LibSystem_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem_p.hi create mode 100644 ghc/lib/haskell-1.3/LibSystem_t.hi create mode 100644 ghc/lib/haskell-1.3/LibTime.hi create mode 100644 ghc/lib/haskell-1.3/LibTime.lhs create mode 100644 ghc/lib/haskell-1.3/LibTime_mc.hi create mode 100644 ghc/lib/haskell-1.3/LibTime_mg.hi create mode 100644 ghc/lib/haskell-1.3/LibTime_mp.hi create mode 100644 ghc/lib/haskell-1.3/LibTime_mr.hi create mode 100644 ghc/lib/haskell-1.3/LibTime_mt.hi create mode 100644 ghc/lib/haskell-1.3/LibTime_p.hi create mode 100644 ghc/lib/haskell-1.3/LibTime_t.hi create mode 100644 ghc/lib/hbc/Algebra.hi create mode 100644 ghc/lib/hbc/Algebra.hs create mode 100644 ghc/lib/hbc/Algebra_mc.hi create mode 100644 ghc/lib/hbc/Algebra_mg.hi create mode 100644 ghc/lib/hbc/Algebra_mp.hi create mode 100644 ghc/lib/hbc/Algebra_mr.hi create mode 100644 ghc/lib/hbc/Algebra_mt.hi create mode 100644 ghc/lib/hbc/Algebra_p.hi create mode 100644 ghc/lib/hbc/Algebra_t.hi create mode 100644 ghc/lib/hbc/Hash.hi create mode 100644 ghc/lib/hbc/Hash.hs create mode 100644 ghc/lib/hbc/Hash_mc.hi create mode 100644 ghc/lib/hbc/Hash_mg.hi create mode 100644 ghc/lib/hbc/Hash_mp.hi create mode 100644 ghc/lib/hbc/Hash_mr.hi create mode 100644 ghc/lib/hbc/Hash_mt.hi create mode 100644 ghc/lib/hbc/Hash_p.hi create mode 100644 ghc/lib/hbc/Hash_t.hi create mode 100644 ghc/lib/hbc/ListUtil.hi create mode 100644 ghc/lib/hbc/ListUtil.hs create mode 100644 ghc/lib/hbc/ListUtil_mc.hi create mode 100644 ghc/lib/hbc/ListUtil_mg.hi create mode 100644 ghc/lib/hbc/ListUtil_mp.hi create mode 100644 ghc/lib/hbc/ListUtil_mr.hi create mode 100644 ghc/lib/hbc/ListUtil_mt.hi create mode 100644 ghc/lib/hbc/ListUtil_p.hi create mode 100644 ghc/lib/hbc/ListUtil_t.hi create mode 100644 ghc/lib/hbc/Miranda.hi create mode 100644 ghc/lib/hbc/Miranda.hs create mode 100644 ghc/lib/hbc/Miranda_mc.hi create mode 100644 ghc/lib/hbc/Miranda_mg.hi create mode 100644 ghc/lib/hbc/Miranda_mp.hi create mode 100644 ghc/lib/hbc/Miranda_mr.hi create mode 100644 ghc/lib/hbc/Miranda_mt.hi create mode 100644 ghc/lib/hbc/Miranda_p.hi create mode 100644 ghc/lib/hbc/Miranda_t.hi create mode 100644 ghc/lib/hbc/NameSupply.hi create mode 100644 ghc/lib/hbc/NameSupply.hs create mode 100644 ghc/lib/hbc/NameSupply_mc.hi create mode 100644 ghc/lib/hbc/NameSupply_mg.hi create mode 100644 ghc/lib/hbc/NameSupply_mp.hi create mode 100644 ghc/lib/hbc/NameSupply_mr.hi create mode 100644 ghc/lib/hbc/NameSupply_mt.hi create mode 100644 ghc/lib/hbc/NameSupply_p.hi create mode 100644 ghc/lib/hbc/NameSupply_t.hi create mode 100644 ghc/lib/hbc/Native.hi create mode 100644 ghc/lib/hbc/Native.hs create mode 100644 ghc/lib/hbc/Native_mc.hi create mode 100644 ghc/lib/hbc/Native_mg.hi create mode 100644 ghc/lib/hbc/Native_mp.hi create mode 100644 ghc/lib/hbc/Native_mr.hi create mode 100644 ghc/lib/hbc/Native_mt.hi create mode 100644 ghc/lib/hbc/Native_p.hi create mode 100644 ghc/lib/hbc/Native_t.hi create mode 100644 ghc/lib/hbc/Number.hi create mode 100644 ghc/lib/hbc/Number.hs create mode 100644 ghc/lib/hbc/Number_mc.hi create mode 100644 ghc/lib/hbc/Number_mg.hi create mode 100644 ghc/lib/hbc/Number_mp.hi create mode 100644 ghc/lib/hbc/Number_mr.hi create mode 100644 ghc/lib/hbc/Number_mt.hi create mode 100644 ghc/lib/hbc/Number_p.hi create mode 100644 ghc/lib/hbc/Number_t.hi create mode 100644 ghc/lib/hbc/Parse.hi create mode 100644 ghc/lib/hbc/Parse.hs create mode 100644 ghc/lib/hbc/Parse_mc.hi create mode 100644 ghc/lib/hbc/Parse_mg.hi create mode 100644 ghc/lib/hbc/Parse_mp.hi create mode 100644 ghc/lib/hbc/Parse_mr.hi create mode 100644 ghc/lib/hbc/Parse_mt.hi create mode 100644 ghc/lib/hbc/Parse_p.hi create mode 100644 ghc/lib/hbc/Parse_t.hi create mode 100644 ghc/lib/hbc/Pretty.hi create mode 100644 ghc/lib/hbc/Pretty.hs create mode 100644 ghc/lib/hbc/Pretty_mc.hi create mode 100644 ghc/lib/hbc/Pretty_mg.hi create mode 100644 ghc/lib/hbc/Pretty_mp.hi create mode 100644 ghc/lib/hbc/Pretty_mr.hi create mode 100644 ghc/lib/hbc/Pretty_mt.hi create mode 100644 ghc/lib/hbc/Pretty_p.hi create mode 100644 ghc/lib/hbc/Pretty_t.hi create mode 100644 ghc/lib/hbc/Printf.hi create mode 100644 ghc/lib/hbc/Printf.hs create mode 100644 ghc/lib/hbc/Printf_mc.hi create mode 100644 ghc/lib/hbc/Printf_mg.hi create mode 100644 ghc/lib/hbc/Printf_mp.hi create mode 100644 ghc/lib/hbc/Printf_mr.hi create mode 100644 ghc/lib/hbc/Printf_mt.hi create mode 100644 ghc/lib/hbc/Printf_p.hi create mode 100644 ghc/lib/hbc/Printf_t.hi create mode 100644 ghc/lib/hbc/QSort.hi create mode 100644 ghc/lib/hbc/QSort.hs create mode 100644 ghc/lib/hbc/QSort_mc.hi create mode 100644 ghc/lib/hbc/QSort_mg.hi create mode 100644 ghc/lib/hbc/QSort_mp.hi create mode 100644 ghc/lib/hbc/QSort_mr.hi create mode 100644 ghc/lib/hbc/QSort_mt.hi create mode 100644 ghc/lib/hbc/QSort_p.hi create mode 100644 ghc/lib/hbc/QSort_t.hi create mode 100644 ghc/lib/hbc/Random.hi create mode 100644 ghc/lib/hbc/Random.hs create mode 100644 ghc/lib/hbc/Random_mc.hi create mode 100644 ghc/lib/hbc/Random_mg.hi create mode 100644 ghc/lib/hbc/Random_mp.hi create mode 100644 ghc/lib/hbc/Random_mr.hi create mode 100644 ghc/lib/hbc/Random_mt.hi create mode 100644 ghc/lib/hbc/Random_p.hi create mode 100644 ghc/lib/hbc/Random_t.hi create mode 100644 ghc/lib/hbc/SimpleLex.hi create mode 100644 ghc/lib/hbc/SimpleLex.hs create mode 100644 ghc/lib/hbc/SimpleLex_mc.hi create mode 100644 ghc/lib/hbc/SimpleLex_mg.hi create mode 100644 ghc/lib/hbc/SimpleLex_mp.hi create mode 100644 ghc/lib/hbc/SimpleLex_mr.hi create mode 100644 ghc/lib/hbc/SimpleLex_mt.hi create mode 100644 ghc/lib/hbc/SimpleLex_p.hi create mode 100644 ghc/lib/hbc/SimpleLex_t.hi create mode 100644 ghc/lib/hbc/Time.hi create mode 100644 ghc/lib/hbc/Time.hs create mode 100644 ghc/lib/hbc/Time_mc.hi create mode 100644 ghc/lib/hbc/Time_mg.hi create mode 100644 ghc/lib/hbc/Time_mp.hi create mode 100644 ghc/lib/hbc/Time_mr.hi create mode 100644 ghc/lib/hbc/Time_mt.hi create mode 100644 ghc/lib/hbc/Time_p.hi create mode 100644 ghc/lib/hbc/Time_t.hi create mode 100644 ghc/lib/hbc/Trace.hi create mode 100644 ghc/lib/hbc/Trace.hs create mode 100644 ghc/lib/hbc/Trace_mc.hi create mode 100644 ghc/lib/hbc/Trace_mg.hi create mode 100644 ghc/lib/hbc/Trace_mp.hi create mode 100644 ghc/lib/hbc/Trace_p.hi create mode 100644 ghc/lib/hbc/Trace_t.hi create mode 100644 ghc/lib/hbc/Word.hi create mode 100644 ghc/lib/hbc/Word.hs create mode 100644 ghc/lib/hbc/Word_mc.hi create mode 100644 ghc/lib/hbc/Word_mg.hi create mode 100644 ghc/lib/hbc/Word_mp.hi create mode 100644 ghc/lib/hbc/Word_mr.hi create mode 100644 ghc/lib/hbc/Word_mt.hi create mode 100644 ghc/lib/hbc/Word_p.hi create mode 100644 ghc/lib/hbc/Word_t.hi create mode 100644 ghc/lib/make_extra_deps create mode 100644 ghc/lib/prelude/Builtin.hi create mode 100644 ghc/lib/prelude/Builtin.hs create mode 100644 ghc/lib/prelude/Builtin_mc.hi create mode 100644 ghc/lib/prelude/Builtin_mg.hi create mode 100644 ghc/lib/prelude/Builtin_mp.hi create mode 100644 ghc/lib/prelude/Builtin_mr.hi create mode 100644 ghc/lib/prelude/Builtin_mt.hi create mode 100644 ghc/lib/prelude/Builtin_p.hi create mode 100644 ghc/lib/prelude/Builtin_t.hi create mode 100644 ghc/lib/prelude/Channel.hi create mode 100644 ghc/lib/prelude/Channel.lhs create mode 100644 ghc/lib/prelude/ChannelVar.hi create mode 100644 ghc/lib/prelude/ChannelVar.lhs create mode 100644 ghc/lib/prelude/ChannelVar_mc.hi create mode 100644 ghc/lib/prelude/ChannelVar_mg.hi create mode 100644 ghc/lib/prelude/ChannelVar_mp.hi create mode 100644 ghc/lib/prelude/ChannelVar_p.hi create mode 100644 ghc/lib/prelude/ChannelVar_t.hi create mode 100644 ghc/lib/prelude/Channel_mc.hi create mode 100644 ghc/lib/prelude/Channel_mg.hi create mode 100644 ghc/lib/prelude/Channel_mp.hi create mode 100644 ghc/lib/prelude/Channel_p.hi create mode 100644 ghc/lib/prelude/Channel_t.hi create mode 100644 ghc/lib/prelude/Cls.hi create mode 100644 ghc/lib/prelude/Cls.hs create mode 100644 ghc/lib/prelude/Cls_mc.hi create mode 100644 ghc/lib/prelude/Cls_mg.hi create mode 100644 ghc/lib/prelude/Cls_mp.hi create mode 100644 ghc/lib/prelude/Cls_mr.hi create mode 100644 ghc/lib/prelude/Cls_mt.hi create mode 100644 ghc/lib/prelude/Cls_p.hi create mode 100644 ghc/lib/prelude/Cls_t.hi create mode 100644 ghc/lib/prelude/Concurrent.hi create mode 100644 ghc/lib/prelude/Concurrent.lhs create mode 100644 ghc/lib/prelude/Concurrent_mc.hi create mode 100644 ghc/lib/prelude/Concurrent_mg.hi create mode 100644 ghc/lib/prelude/Concurrent_mp.hi create mode 100644 ghc/lib/prelude/Concurrent_p.hi create mode 100644 ghc/lib/prelude/Concurrent_t.hi create mode 100644 ghc/lib/prelude/Core.hi create mode 100644 ghc/lib/prelude/Core.hs create mode 100644 ghc/lib/prelude/Core_mc.hi create mode 100644 ghc/lib/prelude/Core_mg.hi create mode 100644 ghc/lib/prelude/Core_mp.hi create mode 100644 ghc/lib/prelude/Core_mr.hi create mode 100644 ghc/lib/prelude/Core_mt.hi create mode 100644 ghc/lib/prelude/Core_p.hi create mode 100644 ghc/lib/prelude/Core_t.hi create mode 100644 ghc/lib/prelude/FoldrBuild.hs create mode 100644 ghc/lib/prelude/IArray.hi create mode 100644 ghc/lib/prelude/IArray.hs create mode 100644 ghc/lib/prelude/IArray_mc.hi create mode 100644 ghc/lib/prelude/IArray_mg.hi create mode 100644 ghc/lib/prelude/IArray_mp.hi create mode 100644 ghc/lib/prelude/IArray_mr.hi create mode 100644 ghc/lib/prelude/IArray_mt.hi create mode 100644 ghc/lib/prelude/IArray_p.hi create mode 100644 ghc/lib/prelude/IArray_t.hi create mode 100644 ghc/lib/prelude/IBool.hi create mode 100644 ghc/lib/prelude/IBool.hs create mode 100644 ghc/lib/prelude/IBool_mc.hi create mode 100644 ghc/lib/prelude/IBool_mg.hi create mode 100644 ghc/lib/prelude/IBool_mp.hi create mode 100644 ghc/lib/prelude/IBool_mr.hi create mode 100644 ghc/lib/prelude/IBool_mt.hi create mode 100644 ghc/lib/prelude/IBool_p.hi create mode 100644 ghc/lib/prelude/IBool_t.hi create mode 100644 ghc/lib/prelude/IChar.hi create mode 100644 ghc/lib/prelude/IChar.hs create mode 100644 ghc/lib/prelude/IChar_mc.hi create mode 100644 ghc/lib/prelude/IChar_mg.hi create mode 100644 ghc/lib/prelude/IChar_mp.hi create mode 100644 ghc/lib/prelude/IChar_mr.hi create mode 100644 ghc/lib/prelude/IChar_mt.hi create mode 100644 ghc/lib/prelude/IChar_p.hi create mode 100644 ghc/lib/prelude/IChar_t.hi create mode 100644 ghc/lib/prelude/IComplex.hi create mode 100644 ghc/lib/prelude/IComplex.hs create mode 100644 ghc/lib/prelude/IComplex_mc.hi create mode 100644 ghc/lib/prelude/IComplex_mg.hi create mode 100644 ghc/lib/prelude/IComplex_mp.hi create mode 100644 ghc/lib/prelude/IComplex_mr.hi create mode 100644 ghc/lib/prelude/IComplex_mt.hi create mode 100644 ghc/lib/prelude/IComplex_p.hi create mode 100644 ghc/lib/prelude/IComplex_t.hi create mode 100644 ghc/lib/prelude/IDouble.hi create mode 100644 ghc/lib/prelude/IDouble.hs create mode 100644 ghc/lib/prelude/IDouble_mc.hi create mode 100644 ghc/lib/prelude/IDouble_mg.hi create mode 100644 ghc/lib/prelude/IDouble_mp.hi create mode 100644 ghc/lib/prelude/IDouble_mr.hi create mode 100644 ghc/lib/prelude/IDouble_mt.hi create mode 100644 ghc/lib/prelude/IDouble_p.hi create mode 100644 ghc/lib/prelude/IDouble_t.hi create mode 100644 ghc/lib/prelude/IFloat.hi create mode 100644 ghc/lib/prelude/IFloat.hs create mode 100644 ghc/lib/prelude/IFloat_mc.hi create mode 100644 ghc/lib/prelude/IFloat_mg.hi create mode 100644 ghc/lib/prelude/IFloat_mp.hi create mode 100644 ghc/lib/prelude/IFloat_mr.hi create mode 100644 ghc/lib/prelude/IFloat_mt.hi create mode 100644 ghc/lib/prelude/IFloat_p.hi create mode 100644 ghc/lib/prelude/IFloat_t.hi create mode 100644 ghc/lib/prelude/IInt.hi create mode 100644 ghc/lib/prelude/IInt.hs create mode 100644 ghc/lib/prelude/IInt_mc.hi create mode 100644 ghc/lib/prelude/IInt_mg.hi create mode 100644 ghc/lib/prelude/IInt_mp.hi create mode 100644 ghc/lib/prelude/IInt_mr.hi create mode 100644 ghc/lib/prelude/IInt_mt.hi create mode 100644 ghc/lib/prelude/IInt_p.hi create mode 100644 ghc/lib/prelude/IInt_t.hi create mode 100644 ghc/lib/prelude/IInteger.hi create mode 100644 ghc/lib/prelude/IInteger.hs create mode 100644 ghc/lib/prelude/IInteger_mc.hi create mode 100644 ghc/lib/prelude/IInteger_mg.hi create mode 100644 ghc/lib/prelude/IInteger_mp.hi create mode 100644 ghc/lib/prelude/IInteger_mr.hi create mode 100644 ghc/lib/prelude/IInteger_mt.hi create mode 100644 ghc/lib/prelude/IInteger_p.hi create mode 100644 ghc/lib/prelude/IInteger_t.hi create mode 100644 ghc/lib/prelude/IList.hi create mode 100644 ghc/lib/prelude/IList.hs create mode 100644 ghc/lib/prelude/IList_mc.hi create mode 100644 ghc/lib/prelude/IList_mg.hi create mode 100644 ghc/lib/prelude/IList_mp.hi create mode 100644 ghc/lib/prelude/IList_mr.hi create mode 100644 ghc/lib/prelude/IList_mt.hi create mode 100644 ghc/lib/prelude/IList_p.hi create mode 100644 ghc/lib/prelude/IList_t.hi create mode 100644 ghc/lib/prelude/IO.hi create mode 100644 ghc/lib/prelude/IO.hs create mode 100644 ghc/lib/prelude/IO_mc.hi create mode 100644 ghc/lib/prelude/IO_mg.hi create mode 100644 ghc/lib/prelude/IO_mp.hi create mode 100644 ghc/lib/prelude/IO_mr.hi create mode 100644 ghc/lib/prelude/IO_mt.hi create mode 100644 ghc/lib/prelude/IO_p.hi create mode 100644 ghc/lib/prelude/IO_t.hi create mode 100644 ghc/lib/prelude/IRatio.hi create mode 100644 ghc/lib/prelude/IRatio.hs create mode 100644 ghc/lib/prelude/IRatio_mc.hi create mode 100644 ghc/lib/prelude/IRatio_mg.hi create mode 100644 ghc/lib/prelude/IRatio_mp.hi create mode 100644 ghc/lib/prelude/IRatio_mr.hi create mode 100644 ghc/lib/prelude/IRatio_mt.hi create mode 100644 ghc/lib/prelude/IRatio_p.hi create mode 100644 ghc/lib/prelude/IRatio_t.hi create mode 100644 ghc/lib/prelude/ITup0.hi create mode 100644 ghc/lib/prelude/ITup0.hs create mode 100644 ghc/lib/prelude/ITup0_mc.hi create mode 100644 ghc/lib/prelude/ITup0_mg.hi create mode 100644 ghc/lib/prelude/ITup0_mp.hi create mode 100644 ghc/lib/prelude/ITup0_mr.hi create mode 100644 ghc/lib/prelude/ITup0_mt.hi create mode 100644 ghc/lib/prelude/ITup0_p.hi create mode 100644 ghc/lib/prelude/ITup0_t.hi create mode 100644 ghc/lib/prelude/ITup2.hi create mode 100644 ghc/lib/prelude/ITup2.hs create mode 100644 ghc/lib/prelude/ITup2_mc.hi create mode 100644 ghc/lib/prelude/ITup2_mg.hi create mode 100644 ghc/lib/prelude/ITup2_mp.hi create mode 100644 ghc/lib/prelude/ITup2_mr.hi create mode 100644 ghc/lib/prelude/ITup2_mt.hi create mode 100644 ghc/lib/prelude/ITup2_p.hi create mode 100644 ghc/lib/prelude/ITup2_t.hi create mode 100644 ghc/lib/prelude/ITup3.hi create mode 100644 ghc/lib/prelude/ITup3.hs create mode 100644 ghc/lib/prelude/ITup3_mc.hi create mode 100644 ghc/lib/prelude/ITup3_mg.hi create mode 100644 ghc/lib/prelude/ITup3_mp.hi create mode 100644 ghc/lib/prelude/ITup3_mr.hi create mode 100644 ghc/lib/prelude/ITup3_mt.hi create mode 100644 ghc/lib/prelude/ITup3_p.hi create mode 100644 ghc/lib/prelude/ITup3_t.hi create mode 100644 ghc/lib/prelude/ITup4.hi create mode 100644 ghc/lib/prelude/ITup4.hs create mode 100644 ghc/lib/prelude/ITup4_mc.hi create mode 100644 ghc/lib/prelude/ITup4_mg.hi create mode 100644 ghc/lib/prelude/ITup4_mp.hi create mode 100644 ghc/lib/prelude/ITup4_mr.hi create mode 100644 ghc/lib/prelude/ITup4_mt.hi create mode 100644 ghc/lib/prelude/ITup4_p.hi create mode 100644 ghc/lib/prelude/ITup4_t.hi create mode 100644 ghc/lib/prelude/ITup5.hi create mode 100644 ghc/lib/prelude/ITup5.hs create mode 100644 ghc/lib/prelude/ITup5_mc.hi create mode 100644 ghc/lib/prelude/ITup5_mg.hi create mode 100644 ghc/lib/prelude/ITup5_mp.hi create mode 100644 ghc/lib/prelude/ITup5_mr.hi create mode 100644 ghc/lib/prelude/ITup5_mt.hi create mode 100644 ghc/lib/prelude/ITup5_p.hi create mode 100644 ghc/lib/prelude/ITup5_t.hi create mode 100644 ghc/lib/prelude/List.hi create mode 100644 ghc/lib/prelude/List.hs create mode 100644 ghc/lib/prelude/List_mc.hi create mode 100644 ghc/lib/prelude/List_mg.hi create mode 100644 ghc/lib/prelude/List_mp.hi create mode 100644 ghc/lib/prelude/List_mr.hi create mode 100644 ghc/lib/prelude/List_mt.hi create mode 100644 ghc/lib/prelude/List_p.hi create mode 100644 ghc/lib/prelude/List_t.hi create mode 100644 ghc/lib/prelude/Merge.hi create mode 100644 ghc/lib/prelude/Merge.lhs create mode 100644 ghc/lib/prelude/Merge_mc.hi create mode 100644 ghc/lib/prelude/Merge_mg.hi create mode 100644 ghc/lib/prelude/Merge_mp.hi create mode 100644 ghc/lib/prelude/Merge_p.hi create mode 100644 ghc/lib/prelude/Merge_t.hi create mode 100644 ghc/lib/prelude/PS.hi create mode 100644 ghc/lib/prelude/PS.lhs create mode 100644 ghc/lib/prelude/PS_mc.hi create mode 100644 ghc/lib/prelude/PS_mg.hi create mode 100644 ghc/lib/prelude/PS_mp.hi create mode 100644 ghc/lib/prelude/PS_mr.hi create mode 100644 ghc/lib/prelude/PS_mt.hi create mode 100644 ghc/lib/prelude/PS_p.hi create mode 100644 ghc/lib/prelude/PS_t.hi create mode 100644 ghc/lib/prelude/Parallel.hi create mode 100644 ghc/lib/prelude/Parallel.lhs create mode 100644 ghc/lib/prelude/Parallel_mc.hi create mode 100644 ghc/lib/prelude/Parallel_mg.hi create mode 100644 ghc/lib/prelude/Parallel_mp.hi create mode 100644 ghc/lib/prelude/Parallel_p.hi create mode 100644 ghc/lib/prelude/Parallel_t.hi create mode 100644 ghc/lib/prelude/Prel.hi create mode 100644 ghc/lib/prelude/Prel.hs create mode 100644 ghc/lib/prelude/Prel13.hi create mode 100644 ghc/lib/prelude/Prel13.hs create mode 100644 ghc/lib/prelude/Prel13_mc.hi create mode 100644 ghc/lib/prelude/Prel13_mg.hi create mode 100644 ghc/lib/prelude/Prel13_mp.hi create mode 100644 ghc/lib/prelude/Prel13_mr.hi create mode 100644 ghc/lib/prelude/Prel13_mt.hi create mode 100644 ghc/lib/prelude/Prel13_p.hi create mode 100644 ghc/lib/prelude/Prel13_t.hi create mode 100644 ghc/lib/prelude/PrelCore13.hi create mode 100644 ghc/lib/prelude/PrelCore13.hs create mode 100644 ghc/lib/prelude/PrelCore13_mc.hi create mode 100644 ghc/lib/prelude/PrelCore13_mg.hi create mode 100644 ghc/lib/prelude/PrelCore13_mp.hi create mode 100644 ghc/lib/prelude/PrelCore13_mr.hi create mode 100644 ghc/lib/prelude/PrelCore13_mt.hi create mode 100644 ghc/lib/prelude/PrelCore13_p.hi create mode 100644 ghc/lib/prelude/PrelCore13_t.hi create mode 100644 ghc/lib/prelude/PrelCoreHi.hs create mode 100644 ghc/lib/prelude/Prel_mc.hi create mode 100644 ghc/lib/prelude/Prel_mg.hi create mode 100644 ghc/lib/prelude/Prel_mp.hi create mode 100644 ghc/lib/prelude/Prel_mr.hi create mode 100644 ghc/lib/prelude/Prel_mt.hi create mode 100644 ghc/lib/prelude/Prel_p.hi create mode 100644 ghc/lib/prelude/Prel_t.hi create mode 100644 ghc/lib/prelude/Prelude.hi create mode 100644 ghc/lib/prelude/PreludeCore.hi create mode 100644 ghc/lib/prelude/PreludeCore_mc.hi create mode 100644 ghc/lib/prelude/PreludeCore_mg.hi create mode 100644 ghc/lib/prelude/PreludeCore_mp.hi create mode 100644 ghc/lib/prelude/PreludeCore_mr.hi create mode 100644 ghc/lib/prelude/PreludeCore_mt.hi create mode 100644 ghc/lib/prelude/PreludeCore_p.hi create mode 100644 ghc/lib/prelude/PreludeCore_t.hi create mode 100644 ghc/lib/prelude/PreludeHi.hs create mode 100644 ghc/lib/prelude/PreludeIO.hi create mode 100644 ghc/lib/prelude/PreludeIO.lhs create mode 100644 ghc/lib/prelude/PreludeIOError.hi create mode 100644 ghc/lib/prelude/PreludeIOError.lhs create mode 100644 ghc/lib/prelude/PreludeIOError_mc.hi create mode 100644 ghc/lib/prelude/PreludeIOError_mg.hi create mode 100644 ghc/lib/prelude/PreludeIOError_mp.hi create mode 100644 ghc/lib/prelude/PreludeIOError_mr.hi create mode 100644 ghc/lib/prelude/PreludeIOError_mt.hi create mode 100644 ghc/lib/prelude/PreludeIOError_p.hi create mode 100644 ghc/lib/prelude/PreludeIOError_t.hi create mode 100644 ghc/lib/prelude/PreludeIO_mc.hi create mode 100644 ghc/lib/prelude/PreludeIO_mg.hi create mode 100644 ghc/lib/prelude/PreludeIO_mp.hi create mode 100644 ghc/lib/prelude/PreludeIO_mr.hi create mode 100644 ghc/lib/prelude/PreludeIO_mt.hi create mode 100644 ghc/lib/prelude/PreludeIO_p.hi create mode 100644 ghc/lib/prelude/PreludeIO_t.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO.lhs create mode 100644 ghc/lib/prelude/PreludeMonadicIO_mc.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO_mg.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO_mp.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO_mr.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO_mt.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO_p.hi create mode 100644 ghc/lib/prelude/PreludeMonadicIO_t.hi create mode 100644 ghc/lib/prelude/PreludeNull_.hi create mode 100644 ghc/lib/prelude/PreludeNull__1s.hi create mode 100644 ghc/lib/prelude/PreludeNull__2s.hi create mode 100644 ghc/lib/prelude/PreludeNull__du.hi create mode 100644 ghc/lib/prelude/PreludeNull__i.hi create mode 100644 ghc/lib/prelude/PreludeNull__j.hi create mode 100644 ghc/lib/prelude/PreludeNull__k.hi create mode 100644 ghc/lib/prelude/PreludeNull__l.hi create mode 100644 ghc/lib/prelude/PreludeNull__m.hi create mode 100644 ghc/lib/prelude/PreludeNull__mc.hi create mode 100644 ghc/lib/prelude/PreludeNull__mg.hi create mode 100644 ghc/lib/prelude/PreludeNull__mp.hi create mode 100644 ghc/lib/prelude/PreludeNull__mr.hi create mode 100644 ghc/lib/prelude/PreludeNull__mt.hi create mode 100644 ghc/lib/prelude/PreludeNull__n.hi create mode 100644 ghc/lib/prelude/PreludeNull__o.hi create mode 100644 ghc/lib/prelude/PreludeNull__p.hi create mode 100644 ghc/lib/prelude/PreludeNull__t.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO.lhs create mode 100644 ghc/lib/prelude/PreludeReadTextIO_mc.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO_mg.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO_mp.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO_mr.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO_mt.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO_p.hi create mode 100644 ghc/lib/prelude/PreludeReadTextIO_t.hi create mode 100644 ghc/lib/prelude/PreludeStdIO.hi create mode 100644 ghc/lib/prelude/PreludeStdIO.lhs create mode 100644 ghc/lib/prelude/PreludeStdIO_mc.hi create mode 100644 ghc/lib/prelude/PreludeStdIO_mg.hi create mode 100644 ghc/lib/prelude/PreludeStdIO_mp.hi create mode 100644 ghc/lib/prelude/PreludeStdIO_mr.hi create mode 100644 ghc/lib/prelude/PreludeStdIO_mt.hi create mode 100644 ghc/lib/prelude/PreludeStdIO_p.hi create mode 100644 ghc/lib/prelude/PreludeStdIO_t.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO.lhs create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_mc.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_mg.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_mp.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_mr.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_mt.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_p.hi create mode 100644 ghc/lib/prelude/PreludeWriteTextIO_t.hi create mode 100644 ghc/lib/prelude/Prelude_mc.hi create mode 100644 ghc/lib/prelude/Prelude_mg.hi create mode 100644 ghc/lib/prelude/Prelude_mp.hi create mode 100644 ghc/lib/prelude/Prelude_mr.hi create mode 100644 ghc/lib/prelude/Prelude_mt.hi create mode 100644 ghc/lib/prelude/Prelude_p.hi create mode 100644 ghc/lib/prelude/Prelude_t.hi create mode 100644 ghc/lib/prelude/SampleVar.hi create mode 100644 ghc/lib/prelude/SampleVar.lhs create mode 100644 ghc/lib/prelude/SampleVar_mc.hi create mode 100644 ghc/lib/prelude/SampleVar_mg.hi create mode 100644 ghc/lib/prelude/SampleVar_mp.hi create mode 100644 ghc/lib/prelude/SampleVar_p.hi create mode 100644 ghc/lib/prelude/SampleVar_t.hi create mode 100644 ghc/lib/prelude/Semaphore.hi create mode 100644 ghc/lib/prelude/Semaphore.lhs create mode 100644 ghc/lib/prelude/Semaphore_mc.hi create mode 100644 ghc/lib/prelude/Semaphore_mg.hi create mode 100644 ghc/lib/prelude/Semaphore_mp.hi create mode 100644 ghc/lib/prelude/Semaphore_p.hi create mode 100644 ghc/lib/prelude/Semaphore_t.hi create mode 100644 ghc/lib/prelude/Text.hi create mode 100644 ghc/lib/prelude/Text.hs create mode 100644 ghc/lib/prelude/Text_mc.hi create mode 100644 ghc/lib/prelude/Text_mg.hi create mode 100644 ghc/lib/prelude/Text_mp.hi create mode 100644 ghc/lib/prelude/Text_mr.hi create mode 100644 ghc/lib/prelude/Text_mt.hi create mode 100644 ghc/lib/prelude/Text_p.hi create mode 100644 ghc/lib/prelude/Text_t.hi create mode 100644 ghc/lib/prelude/TyArray.hi create mode 100644 ghc/lib/prelude/TyArray.hs create mode 100644 ghc/lib/prelude/TyArray_mc.hi create mode 100644 ghc/lib/prelude/TyArray_mg.hi create mode 100644 ghc/lib/prelude/TyArray_mp.hi create mode 100644 ghc/lib/prelude/TyArray_mr.hi create mode 100644 ghc/lib/prelude/TyArray_mt.hi create mode 100644 ghc/lib/prelude/TyArray_p.hi create mode 100644 ghc/lib/prelude/TyArray_t.hi create mode 100644 ghc/lib/prelude/TyBool.hs create mode 100644 ghc/lib/prelude/TyComplex.hi create mode 100644 ghc/lib/prelude/TyComplex.hs create mode 100644 ghc/lib/prelude/TyComplex_mc.hi create mode 100644 ghc/lib/prelude/TyComplex_mg.hi create mode 100644 ghc/lib/prelude/TyComplex_mp.hi create mode 100644 ghc/lib/prelude/TyComplex_mr.hi create mode 100644 ghc/lib/prelude/TyComplex_mt.hi create mode 100644 ghc/lib/prelude/TyComplex_p.hi create mode 100644 ghc/lib/prelude/TyComplex_t.hi create mode 100644 ghc/lib/prelude/TyIO.hi create mode 100644 ghc/lib/prelude/TyIO.hs create mode 100644 ghc/lib/prelude/TyIO_mc.hi create mode 100644 ghc/lib/prelude/TyIO_mg.hi create mode 100644 ghc/lib/prelude/TyIO_mp.hi create mode 100644 ghc/lib/prelude/TyIO_mr.hi create mode 100644 ghc/lib/prelude/TyIO_mt.hi create mode 100644 ghc/lib/prelude/TyIO_p.hi create mode 100644 ghc/lib/prelude/TyIO_t.hi create mode 100644 ghc/lib/prelude/TyRatio.hs create mode 100644 ghc/lib/prelude/TysBasic.hs create mode 100644 ghc/lib/prelude/UTypes.hi create mode 100644 ghc/lib/prelude/UTypes_1s.hi create mode 100644 ghc/lib/prelude/UTypes_2s.hi create mode 100644 ghc/lib/prelude/UTypes_du.hi create mode 100644 ghc/lib/prelude/UTypes_i.hi create mode 100644 ghc/lib/prelude/UTypes_j.hi create mode 100644 ghc/lib/prelude/UTypes_k.hi create mode 100644 ghc/lib/prelude/UTypes_l.hi create mode 100644 ghc/lib/prelude/UTypes_m.hi create mode 100644 ghc/lib/prelude/UTypes_mc.hi create mode 100644 ghc/lib/prelude/UTypes_mg.hi create mode 100644 ghc/lib/prelude/UTypes_mp.hi create mode 100644 ghc/lib/prelude/UTypes_mr.hi create mode 100644 ghc/lib/prelude/UTypes_mt.hi create mode 100644 ghc/lib/prelude/UTypes_n.hi create mode 100644 ghc/lib/prelude/UTypes_o.hi create mode 100644 ghc/lib/prelude/UTypes_p.hi create mode 100644 ghc/lib/prelude/UTypes_t.hi create mode 100644 ghc/lib/tests/Jmakefile create mode 100644 ghc/misc/examples/cats/ccat4.c create mode 100644 ghc/misc/examples/cats/ccat5.c create mode 100644 ghc/misc/examples/cats/hcat1.hs create mode 100644 ghc/misc/examples/cats/hcat2.hs create mode 100644 ghc/misc/examples/cats/hcat3.hs create mode 100644 ghc/misc/examples/cats/hcat4.hs create mode 100644 ghc/misc/examples/cats/hcat5.hs create mode 100644 ghc/misc/examples/cats/hcat6.hs create mode 100644 ghc/misc/examples/cats/mangle_times create mode 100644 ghc/misc/examples/hsh/Hsh.hs create mode 100644 ghc/misc/examples/io/io001/Main.hs create mode 100644 ghc/misc/examples/io/io002/Main.hs create mode 100644 ghc/misc/examples/io/io003/Main.hs create mode 100644 ghc/misc/examples/io/io004/Main.hs create mode 100644 ghc/misc/examples/io/io005/Main.hs create mode 100644 ghc/misc/examples/io/io006/Main.hs create mode 100644 ghc/misc/examples/io/io007/Main.hs create mode 100644 ghc/misc/examples/io/io008/Main.hs create mode 100644 ghc/misc/examples/io/io009/Main.hs create mode 100644 ghc/misc/examples/io/io010/Main.hs create mode 100644 ghc/misc/examples/io/io011/Main.hs create mode 100644 ghc/misc/examples/io/io012/Main.hs create mode 100644 ghc/misc/examples/io/io013/Main.hs create mode 100644 ghc/misc/examples/io/io014/Main.hs create mode 100644 ghc/misc/examples/io/io015/Main.hs create mode 100644 ghc/misc/examples/io/io016/Main.hs create mode 100644 ghc/misc/examples/io/io017/Main.hs create mode 100644 ghc/misc/examples/io/io018/Main.hs create mode 100644 ghc/misc/examples/io/io019/Main.hs create mode 100644 ghc/misc/examples/io/io020/Main.hs create mode 100644 ghc/misc/examples/io/io021/Main.hs create mode 100644 ghc/misc/examples/net001/Main.hs create mode 100644 ghc/misc/examples/net002/Main.hs create mode 100644 ghc/misc/examples/net003/Main.hs create mode 100644 ghc/misc/examples/net004/Main.hs create mode 100644 ghc/misc/examples/net005/Main.hs create mode 100644 ghc/misc/examples/net006/Main.hs create mode 100644 ghc/misc/examples/net007/Main.hs create mode 100644 ghc/misc/examples/net008/Main.hs create mode 100644 ghc/misc/examples/nfib/nfibD.hs create mode 100644 ghc/misc/examples/nfib/nfibF.hs create mode 100644 ghc/misc/examples/nfib/nfibI.hs create mode 100644 ghc/misc/examples/nfib/nfibJ.hs create mode 100644 ghc/misc/examples/nfib/nfibO.hs create mode 100644 ghc/misc/examples/nfib/nfibR.hs create mode 100644 ghc/misc/examples/posix/po001/Main.hs create mode 100644 ghc/misc/examples/posix/po002/Main.hs create mode 100644 ghc/misc/examples/posix/po003/Main.hs create mode 100644 ghc/misc/examples/posix/po004/Main.hs create mode 100644 ghc/misc/examples/posix/po005/Main.hs create mode 100644 ghc/misc/examples/posix/po006/Main.hs create mode 100644 ghc/misc/examples/posix/po007/Main.hs create mode 100644 ghc/misc/examples/posix/po008/Main.hs create mode 100644 ghc/misc/examples/posix/po009/Main.hs create mode 100644 ghc/misc/examples/posix/po010/Main.hs create mode 100644 ghc/misc/examples/posix/po011/Main.hs create mode 100644 ghc/misc/examples/posix/po012/Main.hs create mode 100644 ghc/misc/spat-analysers/README create mode 100644 ghc/misc/spat-analysers/REGSTATS create mode 100644 ghc/misc/spat-analysers/StgRegAddrs.h create mode 100644 ghc/misc/spat-analysers/icount.c create mode 100644 ghc/misc/spat-analysers/icount_by_activity.c create mode 100644 ghc/misc/spat-analysers/makefile create mode 100644 ghc/misc/spat-analysers/show_icounts create mode 100644 ghc/misc/spat-analysers/spatmain.c create mode 100644 ghc/misc/spat-analysers/stgregs.c create mode 100644 ghc/misc/test-arch.c create mode 100644 ghc/mkworld/GHC_OPTS create mode 100644 ghc/mkworld/Jmakefile create mode 100644 ghc/mkworld/install-ghc.ljm create mode 100644 ghc/mkworld/macros-ghc.ljm create mode 100644 ghc/mkworld/only4-ghc.ljm create mode 100644 ghc/mkworld/root.lit create mode 100644 ghc/mkworld/site-ghc.jm.in create mode 100644 ghc/mkworld/suffixes-ghc.ljm create mode 100644 ghc/mkworld/utils-ghc.ljm create mode 100644 ghc/runtime/Jmakefile create mode 100644 ghc/runtime/c-as-asm/CallWrap_C.lc create mode 100644 ghc/runtime/c-as-asm/FreeMallocPtr.lc create mode 100644 ghc/runtime/c-as-asm/HpOverflow.lc create mode 100644 ghc/runtime/c-as-asm/PerformIO.lhc create mode 100644 ghc/runtime/c-as-asm/StablePtr.lc create mode 100644 ghc/runtime/c-as-asm/StablePtrOps.lc create mode 100644 ghc/runtime/c-as-asm/StgDebug.lc create mode 100644 ghc/runtime/c-as-asm/StgMiniInt.lc create mode 100644 ghc/runtime/gmp/COPYING create mode 100644 ghc/runtime/gmp/ChangeLog create mode 100644 ghc/runtime/gmp/INSTALL create mode 100644 ghc/runtime/gmp/Jmakefile create mode 100644 ghc/runtime/gmp/Makefile.original create mode 100644 ghc/runtime/gmp/README create mode 100644 ghc/runtime/gmp/TODO create mode 100644 ghc/runtime/gmp/VERSION create mode 100644 ghc/runtime/gmp/_mpz_get_str.c create mode 100644 ghc/runtime/gmp/_mpz_set_str.c create mode 100644 ghc/runtime/gmp/alloca.c create mode 100644 ghc/runtime/gmp/cre-conv-tab.c create mode 100644 ghc/runtime/gmp/cre-mparam.c create mode 100644 ghc/runtime/gmp/cre-stddefh.c create mode 100644 ghc/runtime/gmp/gmp-impl.h create mode 100644 ghc/runtime/gmp/gmp.h create mode 100644 ghc/runtime/gmp/gmp.texi create mode 100644 ghc/runtime/gmp/itom.c create mode 100644 ghc/runtime/gmp/longlong.h create mode 100644 ghc/runtime/gmp/mdiv.c create mode 100644 ghc/runtime/gmp/memory.c create mode 100644 ghc/runtime/gmp/mfree.c create mode 100644 ghc/runtime/gmp/min.c create mode 100644 ghc/runtime/gmp/mout.c create mode 100644 ghc/runtime/gmp/move.c create mode 100644 ghc/runtime/gmp/mp.h create mode 100644 ghc/runtime/gmp/mp_clz_tab.c create mode 100644 ghc/runtime/gmp/mp_set_fns.c create mode 100644 ghc/runtime/gmp/mpn_add.c create mode 100644 ghc/runtime/gmp/mpn_cmp.c create mode 100644 ghc/runtime/gmp/mpn_div.c create mode 100644 ghc/runtime/gmp/mpn_dm_1.c create mode 100644 ghc/runtime/gmp/mpn_lshift.c create mode 100644 ghc/runtime/gmp/mpn_mod_1.c create mode 100644 ghc/runtime/gmp/mpn_mul.c create mode 100644 ghc/runtime/gmp/mpn_mul_classic.c-EXTRA create mode 100644 ghc/runtime/gmp/mpn_rshift.c create mode 100644 ghc/runtime/gmp/mpn_rshiftci.c create mode 100644 ghc/runtime/gmp/mpn_sqrt.c create mode 100644 ghc/runtime/gmp/mpn_sub.c create mode 100644 ghc/runtime/gmp/mpq_add.c create mode 100644 ghc/runtime/gmp/mpq_clear.c create mode 100644 ghc/runtime/gmp/mpq_cmp.c create mode 100644 ghc/runtime/gmp/mpq_div.c create mode 100644 ghc/runtime/gmp/mpq_get_den.c create mode 100644 ghc/runtime/gmp/mpq_get_num.c create mode 100644 ghc/runtime/gmp/mpq_init.c create mode 100644 ghc/runtime/gmp/mpq_inv.c create mode 100644 ghc/runtime/gmp/mpq_mul.c create mode 100644 ghc/runtime/gmp/mpq_neg.c create mode 100644 ghc/runtime/gmp/mpq_set.c create mode 100644 ghc/runtime/gmp/mpq_set_den.c create mode 100644 ghc/runtime/gmp/mpq_set_num.c create mode 100644 ghc/runtime/gmp/mpq_set_si.c create mode 100644 ghc/runtime/gmp/mpq_set_ui.c create mode 100644 ghc/runtime/gmp/mpq_sub.c create mode 100644 ghc/runtime/gmp/mpz_abs.c create mode 100644 ghc/runtime/gmp/mpz_add.c create mode 100644 ghc/runtime/gmp/mpz_add_ui.c create mode 100644 ghc/runtime/gmp/mpz_and.c create mode 100644 ghc/runtime/gmp/mpz_clear.c create mode 100644 ghc/runtime/gmp/mpz_clrbit.c create mode 100644 ghc/runtime/gmp/mpz_cmp.c create mode 100644 ghc/runtime/gmp/mpz_cmp_si.c create mode 100644 ghc/runtime/gmp/mpz_cmp_ui.c create mode 100644 ghc/runtime/gmp/mpz_com.c create mode 100644 ghc/runtime/gmp/mpz_div.c create mode 100644 ghc/runtime/gmp/mpz_div_2exp.c create mode 100644 ghc/runtime/gmp/mpz_div_ui.c create mode 100644 ghc/runtime/gmp/mpz_dm.c create mode 100644 ghc/runtime/gmp/mpz_dm_ui.c create mode 100644 ghc/runtime/gmp/mpz_dmincl.c create mode 100644 ghc/runtime/gmp/mpz_fac_ui.c create mode 100644 ghc/runtime/gmp/mpz_gcd.c create mode 100644 ghc/runtime/gmp/mpz_gcdext.c create mode 100644 ghc/runtime/gmp/mpz_get_si.c create mode 100644 ghc/runtime/gmp/mpz_get_str.c create mode 100644 ghc/runtime/gmp/mpz_get_ui.c create mode 100644 ghc/runtime/gmp/mpz_init.c create mode 100644 ghc/runtime/gmp/mpz_inp_raw.c create mode 100644 ghc/runtime/gmp/mpz_inp_str.c create mode 100644 ghc/runtime/gmp/mpz_ior.c create mode 100644 ghc/runtime/gmp/mpz_iset.c create mode 100644 ghc/runtime/gmp/mpz_iset_si.c create mode 100644 ghc/runtime/gmp/mpz_iset_str.c create mode 100644 ghc/runtime/gmp/mpz_iset_ui.c create mode 100644 ghc/runtime/gmp/mpz_mdiv.c create mode 100644 ghc/runtime/gmp/mpz_mdiv_ui.c create mode 100644 ghc/runtime/gmp/mpz_mdm.c create mode 100644 ghc/runtime/gmp/mpz_mdm_ui.c create mode 100644 ghc/runtime/gmp/mpz_mmod.c create mode 100644 ghc/runtime/gmp/mpz_mmod_ui.c create mode 100644 ghc/runtime/gmp/mpz_mod.c create mode 100644 ghc/runtime/gmp/mpz_mod_2exp.c create mode 100644 ghc/runtime/gmp/mpz_mod_ui.c create mode 100644 ghc/runtime/gmp/mpz_mul.c create mode 100644 ghc/runtime/gmp/mpz_mul_2exp.c create mode 100644 ghc/runtime/gmp/mpz_mul_ui.c create mode 100644 ghc/runtime/gmp/mpz_neg.c create mode 100644 ghc/runtime/gmp/mpz_out_raw.c create mode 100644 ghc/runtime/gmp/mpz_out_str.c create mode 100644 ghc/runtime/gmp/mpz_perfsqr.c create mode 100644 ghc/runtime/gmp/mpz_pow_ui.c create mode 100644 ghc/runtime/gmp/mpz_powm.c create mode 100644 ghc/runtime/gmp/mpz_powm_ui.c create mode 100644 ghc/runtime/gmp/mpz_pprime_p.c create mode 100644 ghc/runtime/gmp/mpz_random.c create mode 100644 ghc/runtime/gmp/mpz_random2.c create mode 100644 ghc/runtime/gmp/mpz_realloc.c create mode 100644 ghc/runtime/gmp/mpz_set.c create mode 100644 ghc/runtime/gmp/mpz_set_si.c create mode 100644 ghc/runtime/gmp/mpz_set_str.c create mode 100644 ghc/runtime/gmp/mpz_set_ui.c create mode 100644 ghc/runtime/gmp/mpz_size.c create mode 100644 ghc/runtime/gmp/mpz_sizeinb.c create mode 100644 ghc/runtime/gmp/mpz_sqrt.c create mode 100644 ghc/runtime/gmp/mpz_sqrtrem.c create mode 100644 ghc/runtime/gmp/mpz_sub.c create mode 100644 ghc/runtime/gmp/mpz_sub_ui.c create mode 100644 ghc/runtime/gmp/mtox.c create mode 100644 ghc/runtime/gmp/sdiv.c create mode 100644 ghc/runtime/gmp/test-stddefh.c create mode 100644 ghc/runtime/gmp/tests/Jmakefile create mode 100644 ghc/runtime/gmp/xtom.c create mode 100644 ghc/runtime/griproot.lit create mode 100644 ghc/runtime/gum/FetchMe.lhc create mode 100644 ghc/runtime/gum/GlobAddr.lc create mode 100644 ghc/runtime/gum/HLComms.lc create mode 100644 ghc/runtime/gum/Hash.lc create mode 100644 ghc/runtime/gum/LLComms.lc create mode 100644 ghc/runtime/gum/Pack.lc create mode 100644 ghc/runtime/gum/ParInit.lc create mode 100644 ghc/runtime/gum/RBH.lc create mode 100644 ghc/runtime/gum/Sparks.lc create mode 100644 ghc/runtime/gum/SysMan.lc create mode 100644 ghc/runtime/gum/Unpack.lc create mode 100644 ghc/runtime/hooks/ErrorHdr.lc create mode 100644 ghc/runtime/hooks/OutOfHeap.lc create mode 100644 ghc/runtime/hooks/OutOfStk.lc create mode 100644 ghc/runtime/hooks/OutOfVM.lc create mode 100644 ghc/runtime/hooks/PatErrorHdr.lc create mode 100644 ghc/runtime/hooks/TraceHooks.lc create mode 100644 ghc/runtime/io/closeFile.lc create mode 100644 ghc/runtime/io/createDirectory.lc create mode 100644 ghc/runtime/io/env.lc create mode 100644 ghc/runtime/io/errno.lc create mode 100644 ghc/runtime/io/execvpe.lc create mode 100644 ghc/runtime/io/fileEOF.lc create mode 100644 ghc/runtime/io/fileGetc.lc create mode 100644 ghc/runtime/io/fileLookAhead.lc create mode 100644 ghc/runtime/io/filePosn.lc create mode 100644 ghc/runtime/io/filePutc.lc create mode 100644 ghc/runtime/io/fileSize.lc create mode 100644 ghc/runtime/io/flushFile.lc create mode 100644 ghc/runtime/io/getBufferMode.lc create mode 100644 ghc/runtime/io/getCPUTime.lc create mode 100644 ghc/runtime/io/getClockTime.lc create mode 100644 ghc/runtime/io/getCurrentDirectory.lc create mode 100644 ghc/runtime/io/getDirectoryContents.lc create mode 100644 ghc/runtime/io/getLock.lc create mode 100644 ghc/runtime/io/ghcReadline.lc create mode 100644 ghc/runtime/io/inputReady.lc create mode 100644 ghc/runtime/io/openFile.lc create mode 100644 ghc/runtime/io/posix.c create mode 100644 ghc/runtime/io/readFile.lc create mode 100644 ghc/runtime/io/removeDirectory.lc create mode 100644 ghc/runtime/io/removeFile.lc create mode 100644 ghc/runtime/io/renameDirectory.lc create mode 100644 ghc/runtime/io/renameFile.lc create mode 100644 ghc/runtime/io/seekFile.lc create mode 100644 ghc/runtime/io/setBuffering.lc create mode 100644 ghc/runtime/io/setCurrentDirectory.lc create mode 100644 ghc/runtime/io/showTime.lc create mode 100644 ghc/runtime/io/system.lc create mode 100644 ghc/runtime/io/toClockSec.lc create mode 100644 ghc/runtime/io/toLocalTime.lc create mode 100644 ghc/runtime/io/toUTCTime.lc create mode 100644 ghc/runtime/io/writeFile.lc create mode 100644 ghc/runtime/main/GranSim.lc create mode 100644 ghc/runtime/main/Itimer.lc create mode 100644 ghc/runtime/main/RednCounts.lc create mode 100644 ghc/runtime/main/SMRep.lc create mode 100644 ghc/runtime/main/Select.lc create mode 100644 ghc/runtime/main/Signals.lc create mode 100644 ghc/runtime/main/StgOverflow.lc create mode 100644 ghc/runtime/main/StgStartup.lhc create mode 100644 ghc/runtime/main/StgThreads.lhc create mode 100644 ghc/runtime/main/StgTrace.lc create mode 100644 ghc/runtime/main/StgUpdate.lhc create mode 100644 ghc/runtime/main/Threads.lc create mode 100644 ghc/runtime/main/TopClosure.lc create mode 100644 ghc/runtime/main/TopClosure13.lc create mode 100644 ghc/runtime/main/main.lc create mode 100644 ghc/runtime/prims/ByteOps.lc create mode 100644 ghc/runtime/prims/PrimArith.lc create mode 100644 ghc/runtime/prims/PrimMisc.lc create mode 100644 ghc/runtime/prims/test-float.c create mode 100644 ghc/runtime/profiling/CHANGES-REQD create mode 100644 ghc/runtime/profiling/CostCentre.lc create mode 100644 ghc/runtime/profiling/Hashing.lc create mode 100644 ghc/runtime/profiling/HeapProfile.lc create mode 100644 ghc/runtime/profiling/Indexing.lc create mode 100644 ghc/runtime/profiling/LifeProfile.lc create mode 100644 ghc/runtime/profiling/Timer.lc create mode 100644 ghc/runtime/regex/AUTHORS create mode 100644 ghc/runtime/regex/COPYING create mode 100644 ghc/runtime/regex/ChangeLog create mode 100644 ghc/runtime/regex/INSTALL create mode 100644 ghc/runtime/regex/Jmakefile create mode 100644 ghc/runtime/regex/Jmakefile-original create mode 100644 ghc/runtime/regex/Makefile.in create mode 100644 ghc/runtime/regex/Makefile.reg create mode 100644 ghc/runtime/regex/Makefile.regex create mode 100644 ghc/runtime/regex/NEWS create mode 100644 ghc/runtime/regex/PerlSyntaxCaveats create mode 100644 ghc/runtime/regex/README create mode 100644 ghc/runtime/regex/VERSION create mode 100644 ghc/runtime/regex/configure create mode 100644 ghc/runtime/regex/configure.in create mode 100644 ghc/runtime/regex/doc/Makefile.in create mode 100644 ghc/runtime/regex/doc/include.awk create mode 100644 ghc/runtime/regex/doc/regex.texi create mode 100644 ghc/runtime/regex/doc/xregex.texi create mode 100644 ghc/runtime/regex/regex.c create mode 100644 ghc/runtime/regex/test.hs create mode 100644 ghc/runtime/regex/test/ChangeLog create mode 100644 ghc/runtime/regex/test/Makefile.in create mode 100644 ghc/runtime/regex/test/alloca.c create mode 100644 ghc/runtime/regex/test/bsd-interf.c create mode 100644 ghc/runtime/regex/test/debugmalloc.c create mode 100644 ghc/runtime/regex/test/emacsmalloc.c create mode 100644 ghc/runtime/regex/test/fileregex.c create mode 100644 ghc/runtime/regex/test/g++malloc.c create mode 100644 ghc/runtime/regex/test/getpagesize.h create mode 100644 ghc/runtime/regex/test/iregex.c create mode 100644 ghc/runtime/regex/test/main.c create mode 100644 ghc/runtime/regex/test/malloc-test.c create mode 100644 ghc/runtime/regex/test/other.c create mode 100644 ghc/runtime/regex/test/printchar.c create mode 100644 ghc/runtime/regex/test/psx-basic.c create mode 100644 ghc/runtime/regex/test/psx-extend.c create mode 100644 ghc/runtime/regex/test/psx-generic.c create mode 100644 ghc/runtime/regex/test/psx-group.c create mode 100644 ghc/runtime/regex/test/psx-interf.c create mode 100644 ghc/runtime/regex/test/psx-interv.c create mode 100644 ghc/runtime/regex/test/regexcpp.sed create mode 100644 ghc/runtime/regex/test/syntax.skel create mode 100644 ghc/runtime/regex/test/test.c create mode 100644 ghc/runtime/regex/test/test.h create mode 100644 ghc/runtime/regex/test/tregress.c create mode 100644 ghc/runtime/regex/test/upcase.c create mode 100644 ghc/runtime/regex/test/xmalloc.c create mode 100644 ghc/runtime/storage/Force_GC.lc create mode 100644 ghc/runtime/storage/SM1s.lc create mode 100644 ghc/runtime/storage/SM2s.lc create mode 100644 ghc/runtime/storage/SMalloc.lc create mode 100644 ghc/runtime/storage/SMap.lc create mode 100644 ghc/runtime/storage/SMcheck.lc create mode 100644 ghc/runtime/storage/SMcompacting.h create mode 100644 ghc/runtime/storage/SMcompacting.lc create mode 100644 ghc/runtime/storage/SMcompacting.lh create mode 100644 ghc/runtime/storage/SMcopying.lc create mode 100644 ghc/runtime/storage/SMcopying.lh create mode 100644 ghc/runtime/storage/SMdu.lc create mode 100644 ghc/runtime/storage/SMevac.lc create mode 100644 ghc/runtime/storage/SMextn.lc create mode 100644 ghc/runtime/storage/SMextn.lh create mode 100644 ghc/runtime/storage/SMgen.lc create mode 100644 ghc/runtime/storage/SMinit.lc create mode 100644 ghc/runtime/storage/SMinternal.lh create mode 100644 ghc/runtime/storage/SMmark.lhc create mode 100644 ghc/runtime/storage/SMmarkDefs.lh create mode 100644 ghc/runtime/storage/SMmarking.lc create mode 100644 ghc/runtime/storage/SMscan.lc create mode 100644 ghc/runtime/storage/SMscav.lc create mode 100644 ghc/runtime/storage/SMstacks.lc create mode 100644 ghc/runtime/storage/SMstatic.lc create mode 100644 ghc/runtime/storage/SMstats.lc create mode 100644 ghc/runtime/storage/mprotect.lc create mode 100644 ghc/runtime/threadroot.lit create mode 100644 ghc/utils/Jmakefile create mode 100644 ghc/utils/hp2ps/AreaBelow.c create mode 100644 ghc/utils/hp2ps/AreaBelow.h create mode 100644 ghc/utils/hp2ps/AuxFile.c create mode 100644 ghc/utils/hp2ps/AuxFile.h create mode 100644 ghc/utils/hp2ps/Axes.c create mode 100644 ghc/utils/hp2ps/Axes.h create mode 100644 ghc/utils/hp2ps/CHANGES create mode 100644 ghc/utils/hp2ps/Curves.c create mode 100644 ghc/utils/hp2ps/Curves.h create mode 100644 ghc/utils/hp2ps/Defines.h create mode 100644 ghc/utils/hp2ps/Deviation.c create mode 100644 ghc/utils/hp2ps/Deviation.h create mode 100644 ghc/utils/hp2ps/Dimensions.c create mode 100644 ghc/utils/hp2ps/Dimensions.h create mode 100644 ghc/utils/hp2ps/Error.c create mode 100644 ghc/utils/hp2ps/Error.h create mode 100644 ghc/utils/hp2ps/HpFile.c create mode 100644 ghc/utils/hp2ps/HpFile.h create mode 100644 ghc/utils/hp2ps/Jmakefile create mode 100644 ghc/utils/hp2ps/Key.c create mode 100644 ghc/utils/hp2ps/Key.h create mode 100644 ghc/utils/hp2ps/Main.c create mode 100644 ghc/utils/hp2ps/Main.h create mode 100644 ghc/utils/hp2ps/Marks.c create mode 100644 ghc/utils/hp2ps/Marks.h create mode 100644 ghc/utils/hp2ps/PsFile.c create mode 100644 ghc/utils/hp2ps/PsFile.h create mode 100644 ghc/utils/hp2ps/README.GHC create mode 100644 ghc/utils/hp2ps/Reorder.c create mode 100644 ghc/utils/hp2ps/Reorder.h create mode 100644 ghc/utils/hp2ps/Scale.c create mode 100644 ghc/utils/hp2ps/Scale.h create mode 100644 ghc/utils/hp2ps/Shade.c create mode 100644 ghc/utils/hp2ps/Shade.h create mode 100644 ghc/utils/hp2ps/TopTwenty.c create mode 100644 ghc/utils/hp2ps/TopTwenty.h create mode 100644 ghc/utils/hp2ps/TraceElement.c create mode 100644 ghc/utils/hp2ps/TraceElement.h create mode 100644 ghc/utils/hp2ps/Utilities.c create mode 100644 ghc/utils/hp2ps/Utilities.h create mode 100644 ghc/utils/hp2ps/hp2ps.1 create mode 100644 ghc/utils/hp2ps/makefile.original create mode 100644 ghc/utils/hscpp/Jmakefile create mode 100644 ghc/utils/hscpp/hscpp.prl create mode 100644 ghc/utils/hstags/Jmakefile create mode 100644 ghc/utils/hstags/README create mode 100644 ghc/utils/hstags/hstags-help.c create mode 100644 ghc/utils/hstags/hstags.prl create mode 100644 ghc/utils/mkdependHS/Jmakefile create mode 100644 ghc/utils/mkdependHS/mkdependHS.prl create mode 100644 ghc/utils/parallel/Jmakefile create mode 100644 ghc/utils/parallel/ghc-fool-sort.pl create mode 100644 ghc/utils/parallel/ghc-unfool-sort.pl create mode 100644 ghc/utils/parallel/gr2ps.bash create mode 100644 ghc/utils/parallel/gr2qp.pl create mode 100644 ghc/utils/parallel/grs2gr.pl create mode 100644 ghc/utils/parallel/qp2ps.pl create mode 100644 ghc/utils/pvm/README create mode 100644 ghc/utils/pvm/debugger.emacs create mode 100644 ghc/utils/pvm/debugger2 create mode 100644 ghc/utils/stat2resid/Jmakefile create mode 100644 ghc/utils/stat2resid/parse-gcstats.prl create mode 100644 ghc/utils/stat2resid/process-gcstats.prl create mode 100644 ghc/utils/stat2resid/stat2resid.prl create mode 100644 ghc/utils/ugen/Jmakefile create mode 100644 ghc/utils/ugen/funs.h create mode 100644 ghc/utils/ugen/gen.c create mode 100644 ghc/utils/ugen/id.c create mode 100644 ghc/utils/ugen/id.h create mode 100644 ghc/utils/ugen/lex.l create mode 100644 ghc/utils/ugen/main.c create mode 100644 ghc/utils/ugen/manual.mm create mode 100644 ghc/utils/ugen/syntax.y create mode 100644 ghc/utils/ugen/tree.ugn create mode 100644 ghc/utils/ugen/yyerror.c create mode 100644 ghc/utils/unlit/Jmakefile create mode 100644 ghc/utils/unlit/README create mode 100644 ghc/utils/unlit/unlit.c create mode 100644 glafp-utils/Jmakefile create mode 100644 glafp-utils/Makefile.BOOT create mode 100644 glafp-utils/PATCHLEVEL create mode 100644 glafp-utils/README create mode 100644 glafp-utils/etags/Jmakefile create mode 100644 glafp-utils/etags/README create mode 100644 glafp-utils/etags/etags.c create mode 100644 glafp-utils/etags/jbw-fixes create mode 100644 glafp-utils/etags/wells-fixes create mode 100644 glafp-utils/msub/Jmakefile create mode 100644 glafp-utils/msub/msub.c create mode 100644 glafp-utils/msub/msub.man create mode 100644 glafp-utils/msub/msub.ms create mode 100644 glafp-utils/msub/test.makefile create mode 100644 glafp-utils/msub/test.stdout create mode 100644 glafp-utils/msub/testfile create mode 100644 glafp-utils/perl-4.035-fixes create mode 100644 glafp-utils/scripts/Jmakefile create mode 100644 glafp-utils/scripts/fastmake.prl create mode 100644 glafp-utils/scripts/lndir-Xos.h create mode 100644 glafp-utils/scripts/lndir-Xosdefs.h create mode 100644 glafp-utils/scripts/lndir.c create mode 100644 glafp-utils/scripts/lndir.c-X11R5 create mode 100644 glafp-utils/scripts/lndir.man create mode 100644 glafp-utils/scripts/lndir.sh create mode 100644 glafp-utils/scripts/ltx.prl create mode 100644 glafp-utils/scripts/mkdependC.prl create mode 100644 glafp-utils/scripts/mkdirhier.man create mode 100644 glafp-utils/scripts/mkdirhier.sh create mode 100644 glafp-utils/scripts/perltags.prl create mode 100644 glafp-utils/scripts/runstdtest.prl create mode 100644 glafp-utils/scripts/zap-if-same.prl create mode 100644 glafp-utils/verbatim/Jmakefile create mode 100644 glafp-utils/verbatim/verbatim.c create mode 100644 glafp-utils/verbatim/verbatim.lex create mode 100644 install-sh diff --git a/ANNOUNCE-0.26 b/ANNOUNCE-0.26 new file mode 100644 index 0000000..fa35253 --- /dev/null +++ b/ANNOUNCE-0.26 @@ -0,0 +1,153 @@ + The Glasgow Haskell Compiler -- version 0.26 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We are proud to announce a new public release of the Glasgow Haskell +Compiler (GHC, version 0.26). Sources and binaries are freely +available by anonymous FTP and on the World-Wide Web; details below. + +Haskell is "the" standard lazy functional programming language [see +SIGPLAN Notices, May 1992]. The current language version is 1.2. GHC +provides some proposed features of 1.3, notably monadic I/O. + +The Glasgow Haskell project seeks to bring the power and elegance of +functional programming to bear on real-world problems. To that end, +GHC lets you call C (including cross-system garbage collection), +provides good profiling tools, supports ever richer I/O, and (with +this release) adds concurrency. Our goal is to make it the "tool of +choice for real-world applications". + +Highlights of what's new in GHC 0.26 since 0.24 (March 1995): + + * Concurrent Haskell: with this, you can build programs out of many + I/O-performing, interacting `threads'. We have a draft paper + about Concurrent Haskell, and our forthcoming Haggis GUI toolkit + uses it. + + * Parallel Haskell, running on top of PVM (Parallel Virtual Machine) + and hence portable to pretty much any parallel architecture, + whether shared memory or distributed memory. With this, your + Haskell program runs on multiple processors, guided by `par` and + `seq` annotations. The first pretty-much-everyone-can-try-it + parallel functional programming system! NB: The parallel stuff is + "research-tool quality"... consider this an alpha release. + + * "Foldr/build" deforestation (by Andy Gill) is in, as are + "SPECIALIZE instance" pragmas (by Patrick Sansom). + + * The LibPosix library provides an even richer I/O interface than + the standard 1.3 I/O library. A program like a shell or an FTP + client can be written in Haskell -- examples included. + + * Yet more cool libraries: Readline (GNU command-line editing), + Socket (BSD sockets), Regex and MatchPS (GNU regular expressions). + By Darren Moffat and Sigbjorn Finne. + + * New ports -- Linux (a.out) and MIPS (Silicon Graphics). + + * NB: configuration has changed yet again -- for the better, of + course :-) + +Please see the release notes for a complete discussion of What's New. + +To run this release, you need a machine with 16+MB memory, GNU C +(`gcc'), and `perl'. We have seen GHC 0.26 work on these platforms: +alpha-dec-osf2, hppa1.1-hp-hpux9, i386-unknown-linuxaout, +m68k-sun-sunos4, mips-sgi-irix5, and sparc-sun-{sunos4,solaris2}. +Similar platforms should work with minimal hacking effort. +The installer's guide give a full what-ports-work report. + +Binaries are now distributed in `bundles', e.g. a "profiling bundle" +or a "concurrency bundle" for your platform. Just grab the ones you +need. + +Once you have the distribution, please follow the pointers in +ghc/README to find all of the documentation about this release. NB: +preserve modification times when un-tarring the files (no `m' option +for tar, please)! + +We run mailing lists for GHC users and bug reports; to subscribe, send +mail to glasgow-haskell-{users,bugs}-request@dcs.glasgow.ac.uk. +Please send bug reports to glasgow-haskell-bugs. + +Particular thanks to: Jim Mattson (author of much of the code) who has +now moved to HP in California; and the Turing Institute who donated a +lot of SGI cycles for the SGI port. + +Simon Peyton Jones and Will Partain + +Dated: 95/07/24 + +Relevant URLs on the World-Wide Web: + +GHC home page http://www.dcs.glasgow.ac.uk/fp/software/ghc.html +Glasgow FP group page http://www.dcs.glasgow.ac.uk/fp/ +comp.lang.functional FAQ http://www.cs.nott.ac.uk/Department/Staff/mpj/faq.html + +====================================================================== +How to get GHC 0.26: + +This release is available by anonymous FTP from the main Haskell +archive sites, in the directory pub/haskell/glasgow: + + ftp.dcs.glasgow.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.227.140) + haskell.cs.yale.edu (128.36.11.43) + +The Glasgow site is mirrored by src.doc.ic.ac.uk (146.169.43.1), in +computing/programming/languages/haskell/glasgow. + +These are the available files (.gz files are gzipped) -- some are `on +demand', ask if you don't see them: + +ghc-0.26-src.tar.gz The source distribution; about 3MB. + +ghc-0.26.ANNOUNCE This file. + +ghc-0.26.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-0.26-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +ghc-0.26-.tar.gz Basic binary distribution for a particular + . Unpack and go: you can compile + and run Haskell programs with nothing but one + of these files. NB: does *not* include + profiling (see below). + + ==> alpha-dec-osf2 + hppa1.1-hp-hpux9 + i386-unknown-linuxaout + i386-unknown-solaris2 + m68k-sun-sunos4 + mips-sgi-irix5 + sparc-sun-sunos4 + sparc-sun-solaris2 + +ghc-0.26--.tar.gz + + ==> as above + ==> prof (profiling) + conc (concurrent Haskell) + par (parallel) + gran (GranSim parallel simulator) + ticky (`ticky-ticky' counts -- for implementors) + prof-conc (profiling for "conc[urrent]") + prof-ticky (ticky for "conc[urrent]") + +ghc-0.26-hc-files.tar.gz Basic set of intermediate C (.hc) files for the + compiler proper, the prelude, and `Hello, + world'. Used for bootstrapping the system. + About 4MB. + +ghc-0.26--hc-files.tar.gz Further sets of .hc files, for + building other "bundles", e.g., profiling. + +ghc-0.26-hi-files-.tar.gz Sometimes it's more convenient to + use a different set of interface files than + the ones in *-src.tar.gz. (The installation + guide will advise you of this.) + +We could provide diffs from previous versions of GHC, should you +require them. A full set would be very large (7MB). diff --git a/Makefile.config b/Makefile.config new file mode 100644 index 0000000..90c5ab4 --- /dev/null +++ b/Makefile.config @@ -0,0 +1,23 @@ +# partain: probably not the right thing yet + +all: configure + +configure: configure.in + rm -f configure.new + autoconf configure.in > configure.new \ + || ( rm -f configure.new; exit 1 ) + rm -f configure + mv configure.new configure + chmod +x configure + chmod -w configure + rm -f configure.new + +CONFIG_H_IN = ghc/includes/config.h.in + +config.h.in: configure.in + rm -f $(CONFIG_H_IN) + autoheader configure.in > $(CONFIG_H_IN) \ + || ( rm -f $(CONFIG_H_IN); exit 1 ) + +# do something about autoheader +# do something about ghc-vs-nofib configure scripts diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000..3626858 --- /dev/null +++ b/Makefile.in @@ -0,0 +1,36 @@ +# @configure_input@ + +srcdir = @srcdir@ +VPATH = @srcdir@ + +CC = @CC@ + +INSTALL = @INSTALL@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ + +LIBS = @LIBS@ + +CFLAGS = -O +LDFLAGS = -O + +prefix = /usr/local +exec_prefix = $(prefix) +binprefix = +manprefix = + +bindir = $(exec_prefix)/bin +libdir = $(exec_prefix)/lib +mandir = $(prefix)/man/man1 +manext = 1 + +SHELL = /bin/sh + +Makefile: Makefile.in config.status + $(SHELL) config.status +config.status: configure + $(SHELL) config.status --recheck +configure: configure.in + cd $(srcdir); autoconf < configure.in > configure.new + grep -v '# Generated automatically from' < configure.new > configure + diff --git a/README b/README new file mode 100644 index 0000000..590a8bb --- /dev/null +++ b/README @@ -0,0 +1,20 @@ +This is the root directory for functional-programming tools +distributed by the Computing Science Department at Glasgow University. +Simon Peyton Jones is the ringleader +of this effort. The tools are: + + ghc the Glasgow Haskell compilation system + haggis the Haggis GUI toolkit + happy the Happy Haskell parser generator + nofib the NoFib Haskell benchmarking suite + literate the Glasgow "literate programming" system + mkworld configuration system (derived from X11 imake) + glafp-utils shared utility programs + +The "literate" stuff is usually distributed *with* other systems, but +not necessarily. Components which are always part of a distribution +(never stand-alone) are "glafp-utils" and "mkworld" (a configuration +system). + +There is usually an ANNOUNCE* file with any distribution. Please +consult that, or the /README file, to find out how to proceed. diff --git a/STARTUP.in b/STARTUP.in new file mode 100644 index 0000000..d8b9171 --- /dev/null +++ b/STARTUP.in @@ -0,0 +1,116 @@ +#! /bin/sh +# +# die quickly if anything goes astray... +set -e + +# figure out the absolute pathname of the "top" directory +# (the one which has "mkworld", "nofib", "glafp-utils", etc., as subdirs) +hardtop=`pwd` +hardtop=`echo $hardtop | sed 's|^/tmp_mnt/|/|' | sed 's|^/export/|/|' | sed 's|^/grasp_tmp|/local/grasp_tmp|'` +echo '' +echo "*** The top of your build tree is: $hardtop" + +case "$hardtop" in + # NeXTStep brain damage + /private/tmp_mnt/auto* ) + echo '***' + echo '*** AAARRRGGGHHHH!!!' + echo '***' + echo '*** Stupid automounter (and pwd) will not tell me' + echo '*** the absolute pathname for the current directory.' + echo '*** Be sure to set TopDirPwd in mkworld/site-DEF.jm.' + echo '*** (Then it does not matter what this script decides.)' + echo '***' + ;; +esac + +# make "mkworld", "literate", and "glafp-utils" (no special configuration) + +# make all the Makefiles first + +for i in @DoingMkWorld@ @DoingGlaFpUtils@ @DoingLiterate@ ; do + if [ -d $i ] ; then + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** configuring $i ..." ; \ + make -f Makefile.BOOT BOOT_DEFINES="-P none -S std -DTopDirPwd=$hardtop"; \ + echo '' ; \ + echo "*** making Makefiles in $i ..." ; \ + make Makefile ; \ + make Makefiles \ + ) + else + echo warning: $i is not a directory -- doing nothing for it + fi +done + +# now make the dependencies and Real Stuff + +for i in @DoingMkWorld@ @DoingGlaFpUtils@ @DoingLiterate@ ; do + if [ -d $i ] ; then + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** making dependencies in $i ..." ; \ + make depend ; \ + echo '' ; \ + echo "*** making all in $i ..." ; \ + make all \ + ) + else + echo warning: $i is not a directory -- doing nothing for it + fi +done + +# OK, now make the \`real' Makefiles + +for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ ; do + if [ -d $i ] ; then + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** configuring $i ..." ; \ + make -f Makefile.BOOT BOOT_DEFINES="-P $i -S @MkWorldSetup@ -C mkworld -DTopDirPwd=$hardtop"; \ + echo '' ; \ + echo "*** making Makefiles in $i ..." ; \ + make Makefile ; \ + make Makefiles \ + ) + else + echo warning: $i is not a directory -- doing nothing for it + fi +done + +# Finally, the dependencies + +for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ ; do + if [ -d $i ] ; then + ( set -e; \ + cd $i ; \ + echo '' ; \ + echo "*** making dependencies in $i ..." ; \ + make depend \ + ) + else + echo warning: $i is not a directory -- doing nothing for it + fi +done + +echo '' +echo '*******************************************************************' +echo "* Looking good! All you should need to do now is... *" +echo '* *' +for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ ; do + echo " cd $i" + if [ $i = nofib ] ; then + echo ' make all # or...' + echo ' make runtests' + else + echo ' make all' + echo ' make install # if you are so inclined...' + fi +done +echo '* *' +echo '*******************************************************************' +exit 0 diff --git a/config.guess b/config.guess new file mode 100644 index 0000000..41f828a --- /dev/null +++ b/config.guess @@ -0,0 +1,536 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +# +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Written by Per Bothner . +# The master version of this file is at the FSF in /home/gd/gnu/lib. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit system type (host/target name). +# +# Only a few systems have been added to this list; please add others +# (but try to keep the structure clean). +# + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 8/24/94.) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15 + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + alpha:OSF1:V*:*) + # After 1.2, OSF1 uses "V1.3" for uname -r. + echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'` + exit 0 ;; + alpha:OSF1:*:*) + # 1.2 uses "1.2" for uname -r. + echo alpha-dec-osf${UNAME_RELEASE} + exit 0 ;; + amiga:NetBSD:*:*) + echo m68k-cbm-netbsd${UNAME_RELEASE} + exit 0 ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit 0;; + Pyramid*:OSx*:*:*) + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit 0 ;; + sun4*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + i86pc:SunOS:5.*:*) + echo i386-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit 0 ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit 0 ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit 0 ;; + atari*:NetBSD:*:*) + echo m68k-atari-netbsd${UNAME_RELEASE} + exit 0 ;; + sun3*:NetBSD:*:*) + echo m68k-sun-netbsd${UNAME_RELEASE} + exit 0 ;; + mac68k:NetBSD:*:*) + echo m68k-apple-netbsd${UNAME_RELEASE} + exit 0 ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit 0 ;; + mips:*:5*:RISCos) + echo mips-mips-riscos${UNAME_RELEASE} + exit 0 ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit 0 ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit 0 ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit 0 ;; + AViiON:dgux:*:*) + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \ + -o ${TARGET_BINARY_INTERFACE}x = x ] ; then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + exit 0 ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit 0 ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit 0 ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit 0 ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit 0 ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit 0 ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i[34]86:AIX:*:*) + echo i386-ibm-aix + exit 0 ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + sed 's/^ //' << EOF >dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + echo rs6000-ibm-aix3.2.5 + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit 0 ;; + *:AIX:*:4) + if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then + IBM_REV=4.1 + elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then + IBM_REV=4.1.1 + else + IBM_REV=4.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit 0 ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit 0 ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit 0 ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC NetBSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit 0 ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit 0 ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit 0 ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit 0 ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit 0 ;; + 9000/[3478]??:HP-UX:*:*) + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;; + 9000/8?? ) HP_ARCH=hppa1.0 ;; + esac + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit 0 ;; + 3050*:HI-UX:*:*) + sed 's/^ //' << EOF >dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy + echo unknown-hitachi-hiuxwe2 + exit 0 ;; + 9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit 0 ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit 0 ;; + hp7??:OSF1:*:* | hp8?7:OSF1:*:* ) + echo hppa1.1-hp-osf + exit 0 ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit 0 ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit 0 ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit 0 ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit 0 ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit 0 ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit 0 ;; + CRAY*X-MP:*:*:*) + echo xmp-cray-unicos + exit 0 ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} + exit 0 ;; + CRAY*C90:*:*:*) + echo c90-cray-unicos${UNAME_RELEASE} + exit 0 ;; + CRAY-2:*:*:*) + echo cray2-cray-unicos + exit 0 ;; + hp3[0-9][05]:NetBSD:*:*) + echo m68k-hp-netbsd${UNAME_RELEASE} + exit 0 ;; + i[34]86:BSD/386:*:* | *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; + *:FreeBSD:*:*) + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit 0 ;; + *:NetBSD:*:*) + echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + exit 0 ;; + *:GNU:*:*) + echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + *:Linux:*:*) + # Systems without a BFD linker + if test -d /usr/lib/ldscripts/. ; then + : + else + echo "${UNAME_MACHINE}-unknown-linuxoldld" + exit 0 + fi + # Determine whether the default compiler is a.out or elf + cat >dummy.c </dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0 + rm -f dummy.c dummy;; +# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions +# are messed up and put the nodename in both sysname and nodename. + i[34]86:DYNIX/ptx:4*:*) + echo i386-sequent-sysv4 + exit 0 ;; + i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*) + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE} + else + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE} + fi + exit 0 ;; + i[34]86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` + (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 + echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-unknown-sysv32 + fi + exit 0 ;; + Intel:Mach:3*:*) + echo i386-unknown-mach3 + exit 0 ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit 0 ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit 0 ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit 0 ;; + M680[234]0:*:R3V[567]*:*) + test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; + 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0) + uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4.3 && exit 0 ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; + m680[234]0:LynxOS:2.2*:*) + echo m68k-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit 0 ;; + i[34]86:LynxOS:2.2*:*) + echo i386-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; + TSUNAMI:LynxOS:2.2*:*) + echo sparc-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; + rs6000:LynxOS:2.2*:*) + echo rs6000-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit 0 ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit 0 ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +cat >dummy.c < + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + printf ("%s-next-nextstep%s\n", __ARCHITECTURE__, version==2 ? "2" : "3"); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-unknown-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + printf ("i386-sequent-ptx\n"); exit (0); +#endif + +#if defined (vax) +#if !defined (ultrix) + printf ("vax-dec-bsd\n"); exit (0); +#else + printf ("vax-dec-ultrix\n"); exit (0); +#endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0 +rm -f dummy.c dummy + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit 0 ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit 0 ;; + c34*) + echo c34-convex-bsd + exit 0 ;; + c38*) + echo c38-convex-bsd + exit 0 ;; + c4*) + echo c4-convex-bsd + exit 0 ;; + esac +fi + +#echo '(Unable to guess system type)' 1>&2 + +exit 1 diff --git a/config.sub b/config.sub new file mode 100644 index 0000000..93371be --- /dev/null +++ b/config.sub @@ -0,0 +1,866 @@ +#! /bin/sh +# Configuration validation subroutine script, version 1.1. +# Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +if [ x$1 = x ] +then + echo Configuration name missing. 1>&2 + echo "Usage: $0 CPU-MFR-OPSYS" 1>&2 + echo "or $0 ALIAS" 1>&2 + echo where ALIAS is a recognized configuration type. 1>&2 + exit 1 +fi + +# First pass through any local machine types. +case $1 in + *local*) + echo $1 + exit 0 + ;; + *) + ;; +esac + +# Separate what the user gave into CPU-COMPANY and OS (if any). +basic_machine=`echo $1 | sed 's/-[^-]*$//'` +if [ $basic_machine != $1 ] +then os=`echo $1 | sed 's/.*-/-/'` +else os=; fi + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp ) + os= + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ + | arme[lb] | pyramid \ + | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ + | alpha | we32k | ns16k | clipper | sparclite | i370 | sh \ + | powerpc | powerpcle | sparc64 | 1750a | dsp16xx | mips64 | mipsel \ + | pdp11 | mips64el | mips64orion | mips64orionel \ + | sparc) + basic_machine=$basic_machine-unknown + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \ + | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ + | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \ + | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \ + | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \ + | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \ + | pdp11-* | sh-* | powerpc-* | powerpcle-* | sparc64-* | mips64-* | mipsel-* \ + | mips64el-* | mips64orion-* | mips64orionel-*) + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-cbm + ;; + amigados) + basic_machine=m68k-cbm + os=-amigados + ;; + amigaunix | amix) + basic_machine=m68k-cbm + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | ymp) + basic_machine=ymp-cray + os=-unicos + ;; + cray2) + basic_machine=cray2-cray + os=-unicos + ;; + crds | unos) + basic_machine=m68k-crds + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + os=-mvs + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i[345]86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv32 + ;; + i[345]86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv4 + ;; + i[345]86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv + ;; + i[345]86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-solaris2 + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + miniframe) + basic_machine=m68000-convergent + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + np1) + basic_machine=np1-gould + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pentium | p5 | p6) + # We don't have specific support for the Intel Pentium (p6) followon yet, so just call it a Pentium + basic_machine=i586-intel + ;; + pentium-* | p5-* | p6-*) + # We don't have specific support for the Intel Pentium (p6) followon yet, so just call it a Pentium + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + k5) + # We don't have specific support for AMD's K5 yet, so just call it a Pentium + basic_machine=i586-amd + ;; + nexen) + # We don't have specific support for Nexgen yet, so just call it a Pentium + basic_machine=i586-nexgen + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=rs6000-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + xmp) + basic_machine=xmp-cray + os=-unicos + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + mips) + basic_machine=mips-mips + ;; + romp) + basic_machine=romp-ibm + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sparc) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -unixware* | svr4*) + os=-sysv4 + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \ + | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ + | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \ + | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* ) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -ctix* | -uts*) + os=-sysv + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -xenix) + os=-xenix + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-semi) + os=-aout + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-ibm) + os=-aix + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigados + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -lynxos*) + vendor=lynx + ;; + -aix*) + vendor=ibm + ;; + -hpux*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -vxworks*) + vendor=wrs + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os diff --git a/configure.in b/configure.in new file mode 100644 index 0000000..4958303 --- /dev/null +++ b/configure.in @@ -0,0 +1,1916 @@ +dnl == autoconf source for the Glasgow FP tools == +dnl (grep for '^dnl' to see the outline of this file) +dnl +dnl * INITIAL SETUP, CHOICE OF PLATFORM(S) +#!/bin/sh +# +# (c) The AQUA Project, Glasgow University, 1994-1995 +# +# Configure script for the Glasgow functional programming tools +# (created automagically by autoconf...do not edit by hand) +# +# Do "./configure --help" to see what flags are available. +# (Better yet, read the documentation!) +# +# ------------------------------------------------------------------------- +AC_INIT(STARTUP.in) +# +# Prepare to generate the following header files +# +AC_CONFIG_HEADER(ghc/includes/config.h literate/config.h) +# ToDo !!!!!!!!!!!!!!!! +# +# No, we don't do `--srcdir'... +if test x"$srcdir" != 'x.' ; then + echo "This configuration does not support the \`--srcdir' option." + exit 1 +fi + +# ------------------------------------------------------------------------- +dnl ** choose what blobs to build (ghc,haggis,happy,nofib,????) + +# set to the name for the dir if doing it, otherwise empty +DoingGHC='ghc' +DoingNoFib='' +DoingHappy='' +DoingHaggis='' +# the following are not normally changed +DoingLiterate='literate' +DoingMkWorld='mkworld' +DoingGlaFpUtils='glafp-utils' + +MkWorldSetup='std' + +AC_ARG_ENABLE(ghc, + [ +********************************************************************** +* Configuration options for the Glasgow functional-programming tools * +********************************************************************** + +First, select *which* of the tools you want to build, +with --{enable,disable}-{ghc,nofib,happy,haggis}. +(The default is: only GHC (Glasgow Haskell compiler).) + +Second, you may set one of a few applies-in-all-cases options. +For example, --with-tmpdir=/usr/tmp. + +Then you may set various options which are specifically for the +tools you choose in step 1. For GHC, perhaps --enable-concurrent. +For NoFib, perhaps --enable-all-tests. And so on. + +The rest of this message lists all of the configure options. If the +option is enabled by default, the message says how to disable it. And +vice versa. + +If you are confused, don't forget the installation documents that came +with the software! + +******************************************************************* +** FOR SELECTING WHICH GLASGOW FP TOOLS TO BUILD: + +--disable-ghc do *not* build GHC as part of Glasgow FP tools], + [case "$enableval" in + yes) DoingGHC='ghc' + ;; + no) DoingGHC='' + ;; + *) echo "I don't understand this option: --enable-ghc=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingGHC" = 'xxxghc' -a \( ! -d ghc \) ; then + DoingGHC='' + echo 'Doing --disable-ghc, as there is no ghc directory' +fi +ghc_mkworld_site_ghc_jm='ghc/mkworld/site-ghc.jm' +ghc_includes_platform_h='ghc/includes/platform.h' +# duznae work: ghc_includes_config_h='ghc/includes/config.h' +if test "xxx$DoingGHC" = 'xxx' ; then + ghc_mkworld_site_ghc_jm='' + ghc_includes_platform_h='' +# ghc_includes_config_h='' +fi + +AC_ARG_ENABLE(nofib, + [--enable-nofib build NoFib suite as part of Glasgow FP tools], + [case "$enableval" in + yes) DoingNoFib='nofib' + ;; + no) DoingNoFib='' + ;; + *) echo "I don't understand this option: --enable-nofib=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingNoFib" = 'xxxnofib' -a \( ! -d nofib \) ; then + DoingNoFib='' + echo 'Doing --disable-nofib, as there is no nofib directory' +fi +nofib_mkworld_site_nofib_jm='nofib/mkworld/site-nofib.jm' +if test "xxx$DoingNoFib" = 'xxx' ; then + nofib_mkworld_site_nofib_jm='' +fi + +AC_ARG_ENABLE(happy, + [--enable-happy build Happy parser-generator as part of Glasgow FP tools], + [case "$enableval" in + yes) DoingHappy='happy' + ;; + no) DoingHappy='' + ;; + *) echo "I don't understand this option: --enable-happy=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingHappy" = 'xxxhappy' -a \( ! -d happy \) ; then + DoingHappy='' + echo 'Doing --disable-happy, as there is no happy directory' +fi + +AC_ARG_ENABLE(haggis, + [--disable-haggis build Haggis GUI toolkit as part of Glasgow FP tools], + [case "$enableval" in + yes) DoingHaggis='haggis' + ;; + no) DoingHaggis='' + ;; + *) echo "I don't understand this option: --enable-haggis=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingHaggis" = 'xxxhaggis' -a \( ! -d haggis \) ; then + DoingHaggis='' + echo 'Doing --disable-haggis, as there is no haggis directory' +fi + +AC_ARG_ENABLE(literate, + [ +The following three are \`for hackers only': +--disable-literate do *not* build literate-programming stuff], + [case "$enableval" in + yes) DoingLiterate='literate' + ;; + no) DoingLiterate='' + ;; + *) echo "I don't understand this option: --enable-literate=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingLiterate" = 'xxxliterate' -a \( ! -d literate \) ; then + DoingLiterate='' + echo 'Doing --disable-literate, as there is no literate directory' +fi + +AC_ARG_ENABLE(mkworld, + [--disable-mkworld do *not* build \`mkworld' configuration stuff], + [case "$enableval" in + yes) DoingMkWorld='mkworld' + ;; + no) DoingMkWorld='' + ;; + *) echo "I don't understand this option: --enable-mkworld=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingMkWorld" = 'xxxmkworld' -a \( ! -d mkworld \) ; then + DoingMkWorld='' + echo 'Doing --disable-mkworld, as there is no mkworld directory' +fi + +AC_ARG_ENABLE(glafp-utils, + [--disable-glafp-utils do *not* build \`glafp utilities'], + [case "$enableval" in + yes) DoingGlaFpUtils='glafp-utils' + ;; + no) DoingGlaFpUtils='' + ;; + *) echo "I don't understand this option: --enable-glafp-utils=$enableval" + exit 1 + ;; + esac]) +if test "xxx$DoingGlaFpUtils" = 'xxxglafp-utils' -a \( ! -d glafp-utils \) ; then + DoingGlaFpUtils='' + echo 'Doing --disable-glafp-utils, as there is no glafp-utils directory' +fi + +AC_SUBST(DoingGHC) +AC_SUBST(DoingNoFib) +AC_SUBST(DoingHappy) +AC_SUBST(DoingHaggis) +AC_SUBST(DoingLiterate) +AC_SUBST(DoingMkWorld) +AC_SUBST(DoingGlaFpUtils) + +# ------------------------------------------------------------------------- +dnl ** choose host(/target/build) platform +# Guess host/target/build platform(s) if necessary. +# Partly stolen from GCC "configure". +# +if test "x$target" = xNONE ; then + if test "x$nonopt" != xNONE; then + target=$nonopt + else + # This way of testing the result of a command substitution is + # defined by Posix.2 (section 3.9.1) as well as traditional shells. + if target=`$srcdir/config.guess` ; then + echo "Configuring for a ${target} host." 1>&2 + else + echo 'Config.guess failed to determine the host type. You need \ +to specify one.' 1>&2 + if [ -r config.status ] + then + tail +2 config.status 1>&2 + fi + exit 1 + fi + fi +fi + +# "$host" defaults to "$target" +if test "x$host" = xNONE ; then + host=$target +fi +# "$build" defaults to "$host" +if test "x$build" = xNONE ; then + build=$host +else + echo "This configuration does not support the \`--build' option." + exit 1 +fi + +dnl ** canonicalize platform names +# Canonicali[sz]e those babies +BuildPlatform=`/bin/sh $srcdir/config.sub $build` || exit 1 +HostPlatform=`/bin/sh $srcdir/config.sub $host` || exit 1 +TargetPlatform=`/bin/sh $srcdir/config.sub $target` || exit 1 + +if test x"$TargetPlatform" != x"$HostPlatform" ; then + echo "GHC configuration does not support differing host/target (i.e., cross-compiling)" + exit 1 +fi + +# The following will be more difficult when we *are* cross-compiling. +# Suitable names to slam in *_CPP are in platform.h.in. +# We also record the architecture, vendor, and operating system (OS) +# separately. +case $HostPlatform in +alpha-dec-osf1* | alpha-dec-osf2*) + HostPlatform=alpha-dec-osf1 # canonicalise for our purposes + TargetPlatform=alpha-dec-osf1 # this will work for now... (hack) + BuildPlatform=alpha-dec-osf1 #hack + HostPlatform_CPP='alpha_dec_osf1' + HostArch_CPP='alpha' + HostVendor_CPP='dec' + HostOS_CPP='osf1' + ;; +hppa1.1-hp-hpux*) + HostPlatform=hppa1.1-hp-hpux # canonicalise for our purposes (hack) + TargetPlatform=hppa1.1-hp-hpux + BuildPlatform=hppa1.1-hp-hpux + HostPlatform_CPP='hppa1_1_hp_hpux' + HostArch_CPP='hppa1_1' + HostVendor_CPP='hp' + HostOS_CPP='hpux' + ;; +i386-*-linuxaout*) + HostPlatform=i386-unknown-linuxaout # hack again + TargetPlatform=i386-unknown-linuxaout + BuildPlatform=i386-unknown-linuxaout + HostPlatform_CPP='i386_unknown_linuxaout' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='linuxaout' + ;; +i486-*-linuxaout*) + HostPlatform=i386-unknown-linuxaout # hack again: NB: name for arch is *i386*! + TargetPlatform=i386-unknown-linuxaout + BuildPlatform=i386-unknown-linuxaout + HostPlatform_CPP='i386_unknown_linuxaout' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='linuxaout' + ;; +i386-*-linux*) + HostPlatform=i386-unknown-linux # hack again + TargetPlatform=i386-unknown-linux + BuildPlatform=i386-unknown-linux + HostPlatform_CPP='i386_unknown_linux' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='linux' + ;; +i486-*-linux*) + HostPlatform=i386-unknown-linux # hack again: NB: name for arch is *i386*! + TargetPlatform=i386-unknown-linux + BuildPlatform=i386-unknown-linux + HostPlatform_CPP='i386_unknown_linux' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='linux' + ;; +i386-*-freebsd*) + HostPlatform_CPP='i386_unknown_freebsd' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='freebsd' + ;; +i486-*-freebsd*) + HostPlatform_CPP='i386_unknown_freebsd' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='freebsd' + ;; +i386-*-netbsd*) + HostPlatform_CPP='i386_unknown_netbsd' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='netbsd' + ;; +i486-*-netbsd*) + HostPlatform_CPP='i386_unknown_netbsd' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='netbsd' + ;; +i386-*-solaris2*) + HostPlatform=i386-unknown-solaris2 # hack again + TargetPlatform=i386-unknown-solaris2 + BuildPlatform=i386-unknown-solaris2 + HostPlatform_CPP='i386_unknown_solaris2' + HostArch_CPP='i386' + HostVendor_CPP='unknown' + HostOS_CPP='solaris2' + ;; +m68k-next-nextstep2) + HostPlatform_CPP='m68k_next_nextstep2' + HostArch_CPP='m68k' + HostVendor_CPP='next' + HostOS_CPP='nextstep2' + ;; +m68k-next-nextstep3) + HostPlatform_CPP='m68k_next_nextstep3' + HostArch_CPP='m68k' + HostVendor_CPP='next' + HostOS_CPP='nextstep3' + ;; +i386-next-nextstep3) + HostPlatform=i386-next-nextstep3 # hack again + TargetPlatform=i386-next-nextstep3 + BuildPlatform=i386-next-nextstep3 + HostPlatform_CPP='i386_next_nextstep3' + HostArch_CPP='i386' + HostVendor_CPP='next' + HostOS_CPP='nextstep3' + ;; +m68k-sun-sunos4*) + HostPlatform=m68k-sun-sunos4 + TargetPlatform=m68k-sun-sunos4 #hack + BuildPlatform=m68k-sun-sunos4 #hack + HostPlatform_CPP='m68k_sun_sunos4' + HostArch_CPP='m68k' + HostVendor_CPP='sun' + HostOS_CPP='sunos4' + ;; +mips-dec-ultrix*) + HostPlatform_CPP='mips_dec_ultrix' + HostArch_CPP='mipsel' # NB a little different + HostVendor_CPP='dec' + HostOS_CPP='ultrix' + ;; +mips-sgi-irix*) + HostPlatform=mips-sgi-irix + TargetPlatform=mips-sgi-irix #hack + BuildPlatform=mips-sgi-irix #hack + HostPlatform_CPP='mips_sgi_irix' + HostArch_CPP='mipseb' # NB a little different + HostVendor_CPP='sgi' + HostOS_CPP='irix' + ;; +rs6000-ibm-aix*) + HostPlatform_CPP='rs6000_ibm_aix' + HostArch_CPP='rs6000' + HostVendor_CPP='ibm' + HostOS_CPP='aix' + ;; +sparc-sun-sunos4*) + HostPlatform=sparc-sun-sunos4 + TargetPlatform=sparc-sun-sunos4 #hack + BuildPlatform=sparc-sun-sunos4 #hack + HostPlatform_CPP='sparc_sun_sunos4' + HostArch_CPP='sparc' + HostVendor_CPP='sun' + HostOS_CPP='sunos4' + ;; +sparc-sun-solaris2*) + HostPlatform=sparc-sun-solaris2 + TargetPlatform=sparc-sun-solaris2 #hack + BuildPlatform=sparc-sun-solaris2 #hack + HostPlatform_CPP='sparc_sun_solaris2' + HostArch_CPP='sparc' + HostVendor_CPP='sun' + HostOS_CPP='solaris2' + ;; +*) + echo "Unrecognised platform: $HostPlatform" + exit 1 + ;; +esac + +test -n "$verbose" && echo "Host platform set to $HostPlatform" +test -n "$verbose" -a x"$HostPlatform" != x"$TargetPlatform" \ + && echo "Target platform set to $TargetPlatform" +test -n "$verbose" -a x"$BuildPlatform" != x"$HostPlatform" \ + && echo "Build platform set to $BuildPlatform" + +BuildPlatform_CPP=$HostPlatform_CPP +TargetPlatform_CPP=$HostPlatform_CPP +BuildArch_CPP=$HostArch_CPP +TargetArch_CPP=$HostArch_CPP +BuildOS_CPP=$HostOS_CPP +TargetOS_CPP=$HostOS_CPP +BuildVendor_CPP=$HostVendor_CPP +TargetVendor_CPP=$HostVendor_CPP +dnl Cannot afford all these AC_SUBSTs (because of braindead seds w/ 99 cmd limits +dnl AC_SUBST(BuildPlatform) +AC_SUBST(HostPlatform) +dnl AC_SUBST(TargetPlatform) +AC_SUBST(HostPlatform_CPP) +dnl AC_SUBST(BuildPlatform_CPP) +dnl AC_SUBST(TargetPlatform_CPP) +AC_SUBST(HostArch_CPP) +dnl AC_SUBST(BuildArch_CPP) +dnl AC_SUBST(TargetArch_CPP) +AC_SUBST(HostOS_CPP) +dnl AC_SUBST(BuildOS_CPP) +dnl AC_SUBST(TargetOS_CPP) +AC_SUBST(HostVendor_CPP) +dnl AC_SUBST(BuildVendor_CPP) +dnl AC_SUBST(TargetVendor_CPP) + +# ------------------------------------------------------------------------- +dnl +dnl * _GENERAL_ CONFIGURATION CHECKS +# +dnl ** are we at Glasgow? +# +if test -d /local/fp -a -d /users/fp/simonpj; then + echo "Brilliant! You must be a Glaswegian." + AT_GLASGOW=1 + if test "x$prefix" = xNONE; then + prefix=/local/fp + echo "Assuming installation prefix of $prefix" + fi + if test "x$exec_prefix" = xNONE; then + # Sigh: the defn of exec_prefix does not include the bin* bit... + # WDP 94/07 + exec_prefix=/local/fp + echo "Assuming binary installation prefix of $exec_prefix" + fi +else + AT_GLASGOW=0 +fi +AC_SUBST(AT_GLASGOW) +test -n "$verbose" && echo " setting AT_GLASGOW to $AT_GLASGOW" +# +# +# +dnl ** does #! work? +# +AC_SYS_INTERPRETER() +# +dnl ** look for `perl', but watch out for version 4.035 +# +AC_CHECK_PROG(PerlCmd,perl,$ac_dir/$ac_word) +if test -z "$PerlCmd"; then + echo "You must install perl before you can continue" + echo "Perhaps it is already installed, but not in your PATH?" + exit 1 +else + $PerlCmd -v >conftest.out 2>&1 + if egrep "version 4" conftest.out >/dev/null 2>&1; then + if egrep "Patch level: 35" conftest.out >/dev/null 2>&1; then + echo " +************************************************************************ +Uh-oh...looks like you have Perl 4.035. + +Perl version 4.035 has a bug to do with recursion that will bite if +you run the lit2texi script, when making Info files from +literate files of various sorts. Either use the current version +(4.036), an older version (e.g., perl 4.019) or apply the patch in +glafp-utils/perl-4.035-fixes to your 4.035 perl. +************************************************************************ +" + fi + else + echo "I'm not sure if your version of perl will work," + echo "but it's worth a shot, eh?" + fi + rm -fr conftest* +fi +# +dnl ** does #!.../perl work? (sometimes it's too long...) +echo "checking if \`#!$PerlCmd' works in shell scripts" +echo "#!$PerlCmd"' +exit $1; +' > conftest +chmod u+x conftest +(SHELL=/bin/sh; export SHELL; ./conftest 69 > /dev/null) +if test $? -ne 69; then + echo "It does!" +else + echo "It doesn't! Perhaps \`#!$PerlCmd' is too long (often 32 characters max)" + exit 1 +fi +rm -f conftest +# +dnl ** check if perl library is properly installed +# (by seeing if a "do 'getopts.pl'" works... +if $PerlCmd -e 'do "getopts.pl" || exit(1); exit(0);' > /dev/null 2>&1 ; then + : +else + echo "I think your perl library is misinstalled." + echo "The following script did not work:" + echo ' do "getopts.pl" || exit(1); exit(0);' + exit 1 +fi +# +# +dnl ** look for GCC and find out which version +# Figure out which C compiler to use. Gcc is preferred. +# If gcc, make sure it's at least 2.1 +# +AC_PROG_CC +if test -z "$GCC"; then + echo "You would be better off with gcc" + echo "Perhaps it is already installed, but not in your PATH?" + HaveGcc='NO' +else + gcc -v > conftest.out 2>&1 + echo '/version (\d+)\.(\d+)/ && $1*10+$2 > 20 && print "YES";' > conftest.pl + HaveGcc=`eval $PerlCmd -n conftest.pl conftest.out` + if test -z "$HaveGcc"; then + echo "I'm not sure if your version of gcc will work," + echo "but it's worth a shot, eh?" + HaveGcc='YES' + fi + rm -fr conftest* +fi +AC_SUBST(HaveGcc) +AC_C_CROSS +# +dnl ** figure out how to do context diffs +# (NB: NeXTStep thinks diff'ing a file against itself is "trouble") +# +echo foo > conftest1 +echo foo > conftest2 +if diff -C 1 conftest1 conftest2 > /dev/null 2>&1 ; then + ContextDiffCmd='diff -C 1' +else + if diff -c1 conftest1 conftest2 > /dev/null 2>&1 ; then + ContextDiffCmd='diff -c1' + else + echo "Can't figure out how to do context diffs." + echo "Neither \`diff -C 1' nor \`diff -c1' works." + exit 1 + fi +fi +rm -f conftest1 conftest2 +AC_SUBST(ContextDiffCmd) +# +dnl ** look for a decent parser generator (bison preferred) +# +# +AC_CHECK_PROG(YaccCmd, bison, bison -y) +if test -z "$YaccCmd"; then + echo "Can't find bison out there..." + AC_CHECK_PROG(WhatCmd, what, what, :) + AC_CHECK_PROG(YaccCmd, yacc, $ac_dir/$ac_word) + if test -z "$YaccCmd"; then + echo "But that's okay...I can't find yacc either." + YaccCmd=: + else + $WhatCmd $YaccCmd > conftest.out + if egrep 'y1\.c 1\..*SMI' conftest.out >/dev/null 2>&1; then + echo "I don't trust your $YaccCmd; it looks like an old Sun yacc" + if test -x /usr/lang/yacc; then + echo "I'm going to use /usr/lang/yacc instead" + YaccCmd=/usr/lang/yacc + else + echo "I'm assuming the worst...no parser generator at all" + YaccCmd=: + fi + elif egrep 'y1\.c.*Revision: 4\.2\.6\.3.*DEC' conftest.out >/dev/null 2>&1; then + echo "I don't trust your $YaccCmd; it looks like a lame DEC yacc" + echo "I'm assuming the worst...no parser generator at all" + YaccCmd=: + else + echo "But that's okay...as far as I know, your yacc will work." + fi + rm -fr conftest* + fi +fi + +#-------------------------------------------------------------- +WithHc='haskell-compiler-unspecified' +WithHcType='HC_UNSPECIFIED' + +AC_ARG_WITH(hc, + [ +******************************************************************* +** GENERAL OPTIONS WHICH APPLY TO ALL TOOLS: + +--with-hc= + ghc* => Glasgow Haskell invoked by the name given + hbc* => Chalmers HBC, invoked by the name given + nhc* => Niklas Rojemo's "nhc", invoked by the name given + C or c => Don't use a Haskell compiler; + build from intermediate C (.hc) files. + in-place => Use ghc/driver/ghc; i.e. you've built GHC + and you want to use it un-installed ("in-place"). + ], + [case "$withval" in + ghc* | glhc* ) + WithHc=$withval + ;; + hbc* ) WithHc=$withval + ;; + nhc* ) WithHc=$withval + ;; + c | C) WithHc='C' + ;; + in-place ) + WithHc='IN-PLACE' + ;; + *) echo "I don't understand this option: --with-hc=$withval" + exit 1 + ;; + esac]) + +# make sure that what they said makes sense.... set WithHcType +case $WithHc in + haskell-compiler-unspecified ) # maybe they will say something later... + ;; + ghc* | glhc* ) + WithHcType='HC_GLASGOW_GHC' + AC_CHECK_PROG(have_ghc,$WithHc,$ac_dir/$ac_word) + if test -z "$have_ghc"; then + echo "Can't find Glasgow Haskell to compile with: $WithHc" + exit 1 + fi + ;; + hbc* ) # Look for the dastardly competition + WithHcType='HC_CHALMERS_HBC' + AC_CHECK_PROG(have_hbc,$WithHc,YES,NO) + if test $have_hbc = 'NO' ; then + echo "Can't find Chalmers HBC to compile with: $WithHc" + exit 1 + fi + ;; + nhc* ) # Look for Niklas Rojemo's "nhc" + WithHcType='HC_ROJEMO_NHC' + AC_CHECK_PROG(have_nhc,$WithHc,YES,NO) + if test $have_nhc = 'NO' ; then + echo "Can't find Niklas Rojemo's NHC to compile with: $WithHc" + exit 1 + fi + ;; + c | C) WithHcType='HC_USE_HC_FILES' + ;; + IN-PLACE) WithHcType='HC_GLASGOW_GHC' + ;; +esac +AC_SUBST(WithHc) +AC_SUBST(WithHcType) + +dnl ** possibly choose a different tmpdir (default /tmp) +# let the user decide where the best tmpdir is +# /tmp is the default; /usr/tmp is sometimes a good choice. +# Very site-specific. +TmpDir='/tmp' +AC_ARG_WITH(tmpdir, + [--with-tmpdir= Use an alternative directory for +temporary files (presumably because /tmp is too small).], + [TmpDir="$withval"]) +AC_SUBST(TmpDir) + +dnl ** possibly set a max heap for Haskell compilations +# let the user specify a maximum heap to be used; the old +# "I have a 64MB machine, why not use a 32MB heap?" thing. +HcMaxHeapWasSet='NO' +HcMaxHeap='0' +AC_ARG_WITH(max-heap, + [ +--with-max-heap= Do all Haskell compilations +with a heap of this size. (If you've got it, flaunt it.)], + [HcMaxHeapWasSet='YES' + HcMaxHeap="$withval"]) +AC_SUBST(HcMaxHeapWasSet) +AC_SUBST(HcMaxHeap) + +dnl ** figure out about mkdependHS +MkDependHSCmd=':' +if test -f ./ghc/utils/mkdependHS/mkdependHS \ + -o -f ./ghc/utils/mkdependHS/mkdependHS.prl ; then + MkDependHSCmd='TopDirPwd/ghc/utils/mkdependHS/mkdependHS' +else + AC_CHECK_PROG(have_mkdependHS,mkdependHS,YES,NO) + if test $have_mkdependHS = 'YES' ; then + MkDependHSCmd='mkdependHS' + fi +fi +AC_SUBST(MkDependHSCmd) + +# ------------------------------------------------------------------------- +# +dnl ** figure out how to invoke cpp directly (gcc -E is no good) +# +AC_PROG_CPP +if echo $CPP | egrep gcc >/dev/null 2>&1; then + echo > conftest.c + gcc -v -E conftest.c >/dev/null 2>conftest.out + echo '/(\S+\/cpp)/ && print "$1";' > conftest.pl + GNUCPP="`eval $PerlCmd -n conftest.pl conftest.out`" + test -n "$verbose" && echo " setting GNUCPP to $GNUCPP" + RAWCPP="`eval $PerlCmd -n conftest.pl conftest.out` -traditional" + test -n "$verbose" && echo " setting RAWCPP to $RAWCPP" + rm -fr conftest* +fi +# ToDo: what are GNUCPP and RAWCPP if the above if didn't fire? WDP 95/02 +AC_SUBST(GNUCPP) +AC_SUBST(RAWCPP) +# +dnl ** figure out how to do a BSD-ish install +# +AC_PROG_INSTALL +# +dnl ** figure out what arguments to feed to `ar' +# +AC_CHECK_PROG(ArCmd,ar,$ac_dir/$ac_word) +if test -z "$ArCmd"; then + echo "You don't seem to have ar...I have no idea how to make a library" + exit 1; +fi +if $ArCmd clqs conftest.a >/dev/null 2>/dev/null; then + ArCmd="$ArCmd clqs" + NeedRanLib='' +elif $ArCmd cqs conftest.a >/dev/null 2>/dev/null; then + ArCmd="$ArCmd cqs" + NeedRanLib='' +elif $ArCmd clq conftest.a >/dev/null 2>/dev/null; then + ArCmd="$ArCmd clq" + NeedRanLib='YES' +elif $ArCmd cq conftest.a >/dev/null 2>/dev/null; then + ArCmd="$ArCmd cq" + NeedRanLib='YES' +else + echo "I can't figure out how to use your $ArCmd" + exit 1 +fi +rm -rf conftest* +test -n "$ArCmd" && test -n "$verbose" && echo " setting ArCmd to $ArCmd" +AC_SUBST(ArCmd) +# +dnl ** figure out if we need `ranlib' +# +if test -z "$NeedRanLib"; then + # we hackily override a few platforms on a case-by-case basis + case $HostPlatform in + i386-*-linuxaout) + NeedRanLib='YES' + ;; + *) RANLIB=':' + ;; + esac + test -n "$verbose" && echo " setting RANLIB to $RANLIB" +fi +if test -n "$NeedRanLib"; then + AC_PROG_RANLIB +fi +AC_SUBST(RANLIB) +# +dnl ** check for full ANSI header (.h) files +# +AC_HEADER_STDC +# +dnl ** check for specific header (.h) files that we are interested in +# +AC_CHECK_HEADERS(dirent.h fcntl.h grp.h malloc.h memory.h nlist.h pwd.h siginfo.h signal.h stdlib.h string.h sys/fault.h sys/file.h sys/mman.h sys/param.h sys/procfs.h sys/resource.h sys/signal.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/vadvise.h sys/wait.h termios.h time.h types.h unistd.h utime.h vfork.h ) +# +dnl ** check if it is safe to include both and +# +AC_HEADER_TIME +# +dnl ** how do we get a timezone name? +# +AC_STRUCT_TIMEZONE +# +dnl ** determine the type of signal() +# +AC_TYPE_SIGNAL +# +dnl ** decide whether or not flex lexers need to be linked with -lfl +# +AC_CHECK_LIB(fl,yywrap, + FlexLibAvailable='YES', + FlexLibAvailable='NO') +AC_SUBST(FlexLibAvailable) +# +dnl ** Decide whether or not lex lexers need to be linked with -ll +# (Linux, for example, does not have "lex", only "flex") +# +AC_CHECK_LIB(l,yywrap, + LexLibAvailable='YES', + LexLibAvailable='NO') +AC_SUBST(LexLibAvailable) +# +dnl ** check for specific library functions that we are interested in +# +AC_CHECK_FUNCS(access ftime getclock getpagesize getrusage gettimeofday mktime mprotect setitimer stat sysconf timelocal times vadvise vfork) +# +dnl ** can we get alloca? +# +AC_FUNC_ALLOCA +# +dnl ** determine whether or not const works +# +AC_C_CONST +# +dnl ** check for leading underscores in symbol names +# We assume that they _aren't_ there if anything goes wrong. +# +echo checking for a leading underscore in symbol names +AC_TRY_RUN( +[#ifdef HAVE_NLIST_H +#include +struct nlist xYzzY[] = {{"_xYzzY", 0},{0}}; +#endif + +main(argc, argv) +int argc; +char **argv; +{ +#ifdef HAVE_NLIST_H + if(nlist(argv[0], xYzzY) == 0 && xYzzY[0].n_value != 0) + exit(0); +#endif + exit(1); +}], LeadingUnderscore='YES', LeadingUnderscore='NO', LeadingUnderscore='YES') +test -n "$verbose" && echo " setting LeadingUnderscore to $LeadingUnderscore" + +# ------------------------------------------------------------------------- +dnl +dnl * `GHC' CONFIGURATION STUFF + +if test "xxx$DoingGHC" = 'xxxghc' ; then +# a very big "if"! +# +dnl ** which builds to build? +# builds: normal = sequential _ap_o ; _p = profiling (sequential); +# _t = ticky; _u = unregisterized +GhcBuild_normal='YES' +GhcBuild_p='YES' +GhcBuild_t='NO' +GhcBuild_u='NO' +# _mc = concurrent; _mr = profiled concurrent; _mt = ticky concurrent +# _mp = parallel; _mg = gransim +GhcBuild_mc='NO' +GhcBuild_mr='NO' +GhcBuild_mt='NO' +GhcBuild_mp='NO' +GhcBuild_mg='NO' +# GC builds: _2s, _1s, _du (, _gn) +GhcBuild_2s='NO' +GhcBuild_1s='NO' +GhcBuild_du='NO' +# user builds: a...o +GhcBuild_a='NO' +GhcBuild_b='NO' +GhcBuild_c='NO' +GhcBuild_d='NO' +GhcBuild_e='NO' +GhcBuild_f='NO' +GhcBuild_g='NO' +GhcBuild_h='NO' +GhcBuild_i='NO' +GhcBuild_j='NO' +GhcBuild_k='NO' +GhcBuild_l='NO' +GhcBuild_m='NO' +GhcBuild_n='NO' +GhcBuild_o='NO' + +AC_ARG_ENABLE(normal-build, + [ +******************************************************************* +** \`GHC' (GLASGOW HASKELL COMPILER) OPTIONS: + +Choose all the \`builds' of GHC that you want: + +--disable-normal-build do *not* build GHC for normal sequential code], + [case "$enableval" in + yes) GhcBuild_normal='YES' + ;; + no) GhcBuild_normal='NO' + ;; + *) echo "I don't understand this option: --enable-normal-build=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(profiling, + [--disable-profiling do *not* build profiling features], + [case "$enableval" in + yes) GhcBuild_p='YES' + ;; + no) GhcBuild_p='NO' + ;; + *) echo "I don't understand this option: --enable-profiling=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(ticky, + [--enable-ticky build for \`ticky-ticky' profiling (for implementors)], + [case "$enableval" in + yes) GhcBuild_t='YES' + ;; + no) GhcBuild_t='NO' + ;; + *) echo "I don't understand this option: --enable-ticky=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(concurrent, + [--enable-concurrent turn on \`concurrent Haskell' features], + [case "$enableval" in + yes) GhcBuild_mc='YES' + ;; + no) GhcBuild_mc='NO' + ;; + *) echo "I don't understand this option: --enable-concurrent=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(profiled-concurrent, + [--enable-profiled-concurrent turn on profiling for \`concurrent Haskell'], + [case "$enableval" in + yes) GhcBuild_mr='YES' + ;; + no) GhcBuild_mr='NO' + ;; + *) echo "I don't understand this option: --enable-profiled-concurrent=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(ticky-concurrent, + [--enable-ticky-concurrent turn on \`ticky-ticky' profiling for \`concurrent Haskell'], + [case "$enableval" in + yes) GhcBuild_mt='YES' + ;; + no) GhcBuild_mt='NO' + ;; + *) echo "I don't understand this option: --enable-ticky-concurrent=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(parallel, + [--enable-parallel turn on \`parallel Haskell' features], + [case "$enableval" in + yes) GhcBuild_mp='YES'; + ;; + no) GhcBuild_mp='NO' + ;; + *) echo "I don't understand this option: --enable-parallel=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(gransim, + [--enable-gransim turn on GranSim parallel simulator], + [case "$enableval" in + yes) GhcBuild_mg='YES'; + ;; + no) GhcBuild_mg='NO' + ;; + *) echo "I don't understand this option: --enable-gransim=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(gc-2s, + [--enable-gc-2s a build with the 2-space copying garbage collector], + [case "$enableval" in + yes) GhcBuild_2s='YES' + ;; + no) GhcBuild_2s='NO' + ;; + *) echo "I don't understand this option: --enable-gc-2s=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(gc-1s, + [--enable-gc-1s a build with the 1-space compacting garbage collector], + [case "$enableval" in + yes) GhcBuild_1s='YES' + ;; + no) GhcBuild_1s='NO' + ;; + *) echo "I don't understand this option: --enable-gc-1s=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(gc-du, + [--enable-gc-du a build with \`dual-mode' (1s/2s) garbage collector], + [case "$enableval" in + yes) GhcBuild_du='YES' + ;; + no) GhcBuild_du='NO' + ;; + *) echo "I don't understand this option: --enable-gc-du=$enableval" + exit 1 + ;; + esac]) + +dnl some seds only allow 99 commands, meaning no more +dnl than 99 AC_SUBSTs. AARRGGHH!! +dnl AC_ARG_ENABLE(user-way-a, +dnl [--enable-user-way-a build for \`user way a' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_a='YES' +dnl ;; +dnl no) GhcBuild_a='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-a=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-b, +dnl [--enable-user-way-b build for \`user way b' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_b='YES' +dnl ;; +dnl no) GhcBuild_b='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-b=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-c, +dnl [--enable-user-way-c build for \`user way c' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_c='YES' +dnl ;; +dnl no) GhcBuild_c='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-c=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-d, +dnl [--enable-user-way-d build for \`user way d' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_d='YES' +dnl ;; +dnl no) GhcBuild_d='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-d=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-e, +dnl [--enable-user-way-e build for \`user way e' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_e='YES' +dnl ;; +dnl no) GhcBuild_e='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-e=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-f, +dnl [--enable-user-way-f build for \`user way f' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_f='YES' +dnl ;; +dnl no) GhcBuild_f='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-f=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-g, +dnl [--enable-user-way-g build for \`user way g' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_g='YES' +dnl ;; +dnl no) GhcBuild_g='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-g=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-h, +dnl [--enable-user-way-h build for \`user way h' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_h='YES' +dnl ;; +dnl no) GhcBuild_h='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-h=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-i, +dnl [--enable-user-way-i build for \`user way i' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_i='YES' +dnl ;; +dnl no) GhcBuild_i='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-i=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-j, +dnl [--enable-user-way-j build for \`user way j' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_j='YES' +dnl ;; +dnl no) GhcBuild_j='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-j=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-k, +dnl [--enable-user-way-k build for \`user way k' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_k='YES' +dnl ;; +dnl no) GhcBuild_k='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-k=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-l, +dnl [--enable-user-way-l build for \`user way l' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_l='YES' +dnl ;; +dnl no) GhcBuild_l='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-l=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-m, +dnl [--enable-user-way-m build for \`user way m' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_m='YES' +dnl ;; +dnl no) GhcBuild_m='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-m=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-n, +dnl [--enable-user-way-n build for \`user way n' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_n='YES' +dnl ;; +dnl no) GhcBuild_n='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-n=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +dnl AC_ARG_ENABLE(user-way-o, +dnl [--enable-user-way-o build for \`user way o' (mostly for implementors)], +dnl [case "$enableval" in +dnl yes) GhcBuild_o='YES' +dnl ;; +dnl no) GhcBuild_o='NO' +dnl ;; +dnl *) echo "I don't understand this option: --enable-user-way-o=$enableval" +dnl exit 1 +dnl ;; +dnl esac]) +dnl +AC_SUBST(GhcBuild_normal) +AC_SUBST(GhcBuild_p) +AC_SUBST(GhcBuild_t) +AC_SUBST(GhcBuild_u) +AC_SUBST(GhcBuild_mc) +AC_SUBST(GhcBuild_mr) +AC_SUBST(GhcBuild_mt) +AC_SUBST(GhcBuild_mp) +AC_SUBST(GhcBuild_mg) +AC_SUBST(GhcBuild_2s) +AC_SUBST(GhcBuild_1s) +AC_SUBST(GhcBuild_du) +dnl AC_SUBST(GhcBuild_a) +dnl AC_SUBST(GhcBuild_b) +dnl AC_SUBST(GhcBuild_c) +dnl AC_SUBST(GhcBuild_d) +dnl AC_SUBST(GhcBuild_e) +dnl AC_SUBST(GhcBuild_f) +dnl AC_SUBST(GhcBuild_g) +dnl AC_SUBST(GhcBuild_h) +dnl AC_SUBST(GhcBuild_i) +dnl AC_SUBST(GhcBuild_j) +dnl AC_SUBST(GhcBuild_k) +dnl AC_SUBST(GhcBuild_l) +dnl AC_SUBST(GhcBuild_m) +dnl AC_SUBST(GhcBuild_n) +dnl AC_SUBST(GhcBuild_o) + +#--------------------------------------------------------------- +# +dnl ** which Haskell compiler to bootstrap GHC with? +# Figure out what Haskell compiler(s) to use for booting +# +# first, the defaults... +WithGhcHc='haskell-compiler-unspecified' +WithGhcHcType='HC_UNSPECIFIED' +GhcBuilderVersion='26' + +AC_ARG_WITH(hc-for-ghc, + [ +The Haskell compiler for bootstrapping GHC (if any); this option, +if used, overrides --with-hc=<...>: + + --with-hc-for-ghc= + ghc* => Glasgow Haskell invoked by the name given + C or c => Don't use a Haskell compiler; + build from intermediate C (.hc) files. + ], + [case "$withval" in + ghc* | glhc* ) + WithGhcHc=$withval + ;; + hbc* ) echo "HBC will not compile GHC 0.26 as is (sigh)" + exit 1 + ;; + c | C) WithGhcHc='C' + WithGhcHcType='HC_USE_HC_FILES' + ;; + *) echo "I don't understand this option: --with-hc-for-ghc=$withval" + exit 1 + ;; + esac]) + +# make sure that what they said makes sense.... set WithGhcHcType +case $WithGhcHc in + haskell-compiler-unspecified ) # maybe they said something earlier... + if test $WithHc = 'haskell-compiler-unspecified' ; then + echo "Neither --with-hc nor --with-hc-for-ghc was properly set" + exit 1 + fi + if test $WithHcType = 'HC_GLASGOW_GHC' ; then + touch conftest.o + $WithHc -v -C conftest.o > conftest.out 2>&1 + echo '/version (\d+)\.(\d+)/ && print ($1*100+$2);' > conftest.pl + GhcBuilderVersion=`eval $PerlCmd -n conftest.pl conftest.out` + rm -rf conftest* + fi + ;; + ghc* | glhc* ) + WithGhcHcType='HC_GLASGOW_GHC' + AC_CHECK_PROG(have_ghc,$WithGhcHc,$ac_dir/$ac_word) + if test -z "$have_ghc"; then + echo "Can't find Glasgow Haskell to compile with: $WithGhcHc" + exit 1 + else + touch conftest.o + $WithGhcHc -v -C conftest.o > conftest.out 2>&1 + echo '/version (\d+)\.(\d+)/ && print ($1*100+$2);' > conftest.pl + GhcBuilderVersion=`eval $PerlCmd -n conftest.pl conftest.out` + rm -rf conftest* + fi + ;; + c | C) WithGhcHcType='HC_USE_HC_FILES' + ;; +esac +AC_SUBST(GhcBuilderVersion) +AC_SUBST(WithGhcHc) +AC_SUBST(WithGhcHcType) + +dnl ** use portable (slow) C? -- preferably not +GhcWithRegisterised='YES' +AC_ARG_ENABLE(portable-C, + [Other things for GHC: + +--enable-portable-C use portable C (slow), not \`registerised' (fast)], + [case "$enableval" in + yes) GhcWithRegisterised='NO' + ;; + no) GhcWithRegisterised='YES' + ;; + *) echo "I don't understand this option: --enable-portable-C=$enableval" + exit 1 + ;; + esac]) + +if test $GhcWithRegisterised = 'YES'; then + case $HostPlatform in + alpha-* | hppa1.1-* | i386-* | m68k-* | mips-* | sparc-* ) + ;; + *) + echo "Don't know non-portable C tricks for this platform: $HostPlatform" + GhcWithRegisterised='NO' + ;; + esac +fi +AC_SUBST(GhcWithRegisterised) + +if test $GhcWithRegisterised = 'NO'; then + GhcBuild_u='YES' + GhcBuild_normal='NO' + GhcBuild_p='NO' +fi +# ToDo: make sure we can do concurrent for platform/circs... +# ToDo: make sure we can do profiling for platform/circs... +# ToDo: make sure we can do parallel for platform/circs... +# ToDo: make sure we can do gransim for platform/circs... + +dnl ** build GHC compiler proper (\`hsc') from .hc files? +GhcWithHscBuiltViaC='NO' +AC_ARG_ENABLE(hsc-built-via-C, + [--enable-hsc-built-via-C build compiler proper (hsc) from intermediate .hc + files (disabled by default)], + [case "$enableval" in + yes) GhcWithHscBuiltViaC='YES' + ;; + no) GhcWithHscBuiltViaC='NO' + ;; + *) echo "I don't understand this option: --enable-hsc-built-via-C=$enableval" + exit 1 + ;; + esac]) +case $WithGhcHc in + haskell-compiler-unspecified ) # maybe they said something earlier... + if test $WithHcType = 'HC_USE_HC_FILES' ; then + GhcWithHscBuiltViaC='YES' + fi + ;; + c | C) GhcWithHscBuiltViaC='YES' + ;; + *) ;; +esac +AC_SUBST(GhcWithHscBuiltViaC) + +dnl ** build \`hsc' with -O? +GhcWithHscOptimised='YES' +AC_ARG_ENABLE(hsc-optimised, + [--disable-hsc-optimised don't build compiler proper (hsc) with -O], + [case "$enableval" in + yes) GhcWithHscOptimised='YES' + ;; + no) GhcWithHscOptimised='NO' + ;; + *) echo "I don't understand this option: --enable-hsc-optimised=$enableval" + exit 1 + ;; + esac]) +AC_SUBST(GhcWithHscOptimised) + +dnl ** build \`hsc' with -DDEBUG? +GhcWithHscDebug='NO' +AC_ARG_ENABLE(hsc-debug, + [--enable-hsc-debug build compiler proper (hsc) with -DDEBUG], + [case "$enableval" in + yes) GhcWithHscDebug='YES' + ;; + no) GhcWithHscDebug='NO' + ;; + *) echo "I don't understand this option: --enable-hsc-debug=$enableval" + exit 1 + ;; + esac]) +AC_SUBST(GhcWithHscDebug) + +dnl ** omit native-code generator from \`hsc'? +GhcWithNativeCodeGen='YES' +AC_ARG_ENABLE(native-code-generator, + [--enable-native-code-generator build an n.c.g. + [enabled for supported platforms]], + [case "$enableval" in + yes) GhcWithNativeCodeGen='YES' + ;; + no) GhcWithNativeCodeGen='NO' + ;; + *) echo "I don't understand this option: --enable-native-code-generator=$enableval" + exit 1 + ;; + esac]) +if test $GhcWithNativeCodeGen = 'YES'; then + case $TargetPlatform in + sparc-sun-sunos4 | sparc-sun-solaris2 | alpha-dec-osf1 ) + ;; + *) + echo "Don't have a native-code generator for this platform: $TargetPlatform" + GhcWithNativeCodeGen='NO' + ;; + esac +fi +AC_SUBST(GhcWithNativeCodeGen) + +dnl ** include Marlow's deforester in \`hsc'? +GhcWithDeforester='NO' +AC_ARG_ENABLE(deforester, + [--enable-deforester build deforester into compiler (HACKERS ONLY)], + [case "$enableval" in + yes) GhcWithDeforester='YES' + ;; + no) GhcWithDeforester='NO' + ;; + *) echo "I don't understand this option: --enable-deforester=$enableval" + exit 1 + ;; + esac]) +AC_SUBST(GhcWithDeforester) + +dnl ** include Readline library? +GhcWithReadline='NO' +AC_ARG_ENABLE(readline-library, + [--enable-readline-library include (GNU) readline library in -syslib GHC], + [case "$enableval" in + yes) GhcWithReadline='YES' + ;; + no) GhcWithReadline='NO' + ;; + *) echo "I don't understand this option: --enable-readline-library=$enableval" + exit 1 + ;; + esac]) +AC_SUBST(GhcWithReadline) + +dnl ** include Sockets library? +GhcWithSockets='NO' +AC_ARG_ENABLE(sockets-library, + [--enable-sockets-library include the network-interface (sockets) library in -syslib GHC], + [case "$enableval" in + yes) GhcWithSockets='YES' + ;; + no) GhcWithSockets='NO' + ;; + *) echo "I don't understand this option: --enable-sockets-library=$enableval" + exit 1 + ;; + esac]) +AC_SUBST(GhcWithSockets) + +dnl ** build the interpreter? +BuildGHCI='NO' +AC_ARG_ENABLE(ghci, + [--enable-ghci build Glasgow Haskell interpreter (HACKERS ONLY)], + [case "$enableval" in + yes) BuildGHCI='YES' + ;; + no) BuildGHCI='NO' + ;; + *) echo "I don't understand this option: --enable-ghci=$enableval" + exit 1 + ;; + esac]) +AC_SUBST(BuildGHCI) + +# here ends a very big if DoingGHC = 'ghc' ... +fi + +# +# ------------------------------------------------------------------------- +dnl +dnl * `Happy' CONFIGURATION STUFF + +if test "xxx$DoingHappy" = 'xxxhappy' ; then +# a very big "if"! + +dnl ** which Haskell compiler to use on happy? +WithHappyHc='haskell-compiler-unspecified' +WithHappyHcType='HC_UNSPECIFIED' + +AC_ARG_WITH(hc-for-happy, + [ +******************************************************************* +** \`Happy' PARSER-GENERATOR OPTIONS: + +The Haskell compiler to compile Happy; this option, if used, overrides +--with-hc=<...>: + + --with-hc-for-happy= + ghc* => Glasgow Haskell invoked by the name given + hbc* => Chalmers HBC, invoked by the name given + nhc* => Niklas Rojemo's "nhc", invoked by the name given + in-place => Use ghc/driver/ghc; i.e. you've built GHC + and you want to use it un-installed ("in-place").], + [case "$withval" in + ghc* | glhc* ) + WithHappyHc=$withval + ;; + hbc* ) WithHappyHc=$withval + ;; + nhc* ) WithHappyHc=$withval + ;; + in-place ) + WithHappyHc='IN-PLACE' + ;; + *) echo "I don't understand this option: --with-hc-for-happy=$withval" + exit 1 + ;; + esac]) + +# make sure that what they said makes sense.... set WithHappyHcType +case $WithHappyHc in + haskell-compiler-unspecified ) # maybe they said something earlier... + if test $WithHc = 'haskell-compiler-unspecified' ; then + echo "Neither --with-hc nor --with-hc-for-happy was properly set" + exit 1 + fi + ;; + ghc* | glhc* ) + WithHappyHcType='HC_GLASGOW_GHC' + AC_CHECK_PROG(have_ghc,$WithHappyHc,$ac_dir/$ac_word) + if test -z "$have_ghc"; then + echo "Can't find Glasgow Haskell to compile with: $WithHappyHc" + exit 1 + fi + ;; + hbc* ) # Look for the dastardly competition + WithHappyHcType='HC_CHALMERS_HBC' + AC_CHECK_PROG(have_hbc,$WithHappyHc,YES,NO) + if test $have_hbc = 'NO' ; then + echo "Can't find Chalmers HBC to compile with: $WithHappyHc" + exit 1 + fi + ;; + nhc* ) # Look for Niklas Rojemo's "nhc" + WithHappyHcType='HC_ROJEMO_NHC' + AC_CHECK_PROG(have_nhc,$WithHappyHc,YES,NO) + if test $have_nhc = 'NO' ; then + echo "Can't find Niklas Rojemo's NHC to compile with: $WithHappyHc" + exit 1 + fi + ;; + IN-PLACE) WithHappyHcType='HC_GLASGOW_GHC' + ;; +esac +AC_SUBST(WithHappyHc) +AC_SUBST(WithHappyHcType) + +# here ends a very big if DoingHappy = 'happy' ... +fi +# +# ------------------------------------------------------------------------- +dnl +dnl * `Haggis' CONFIGURATION STUFF + +if test "xxx$DoingHaggis" = 'xxxhaggis' ; then +# a very big "if"! + +dnl ** which Haskell compiler to use on haggis? +WithHaggisHc='haskell-compiler-unspecified' +WithHaggisHcType='HC_UNSPECIFIED' + +AC_ARG_WITH(hc-for-haggis, + [ +******************************************************************* +** \`Haggis' HASKELL GUI TOOLKIT OPTIONS: + +The Haskell compiler to compile the Haggis toolkit; this option, if +used, overrides --with-hc=<...>: + + --with-hc-for-haggis= + ghc* => Glasgow Haskell invoked by the name given + and you want to use it un-installed ("in-place").], + [case "$withval" in + ghc* | glhc* ) + WithHaggisHc=$withval + ;; + in-place ) + WithHaggisHc='IN-PLACE' + ;; + *) echo "I don't understand this option: --with-hc-for-haggis=$withval" + exit 1 + ;; + esac]) + +# make sure that what they said makes sense.... set WithHaggisHcType +case $WithHaggisHc in + haskell-compiler-unspecified ) # maybe they said something earlier... + if test $WithHc = 'haskell-compiler-unspecified' ; then + echo "Neither --with-hc nor --with-hc-for-haggis was properly set" + exit 1 + fi + ;; + ghc* | glhc* ) + WithHaggisHcType='HC_GLASGOW_GHC' + AC_CHECK_PROG(have_ghc,$WithHaggisHc,$ac_dir/$ac_word) + if test -z "$have_ghc"; then + echo "Can't find Glasgow Haskell to compile with: $WithHaggisHc" + exit 1 + fi + ;; + IN-PLACE) WithHaggisHcType='HC_GLASGOW_GHC' + ;; +esac +AC_SUBST(WithHaggisHc) +AC_SUBST(WithHaggisHcType) + +# here ends a very big if DoingHaggis = 'haggis' ... +fi +# +# ------------------------------------------------------------------------- +dnl +dnl * `NoFib' CONFIGURATION STUFF + +if test "xxx$DoingNoFib" = 'xxxnofib' ; then +# a very big "if"! + +dnl ** which Haskell compiler to test with NoFib? +WithNoFibHc='haskell-compiler-unspecified' +WithNoFibHcType='HC_UNSPECIFIED' + +AC_ARG_WITH(hc-for-nofib, + [ +******************************************************************* +** NoFib HASKELL BENCHMARK SUITE OPTIONS: + +The Haskell compiler to compile the NoFib programs; this option, if +used, overrides --with-hc=<...>: + + --with-hc-for-nofib= + ghc* => Glasgow Haskell invoked by the name given + hbc* => Chalmers HBC, invoked by the name given + nhc* => Niklas Rojemo's "nhc", invoked by the name given + in-place => Use ghc/driver/ghc; i.e. you've built GHC + and you want to use it un-installed ("in-place"). + ], + [case "$withval" in + ghc* | glhc* ) + WithNoFibHc=$withval + ;; + hbc* ) WithNoFibHc=$withval + ;; + nhc* ) WithNoFibHc=$withval + ;; + in-place ) + WithNoFibHc='IN-PLACE' + ;; + *) echo "I don't understand this option: --with-hc-for-nofib=$withval" + exit 1 + ;; + esac]) + +# make sure that what they said makes sense.... set WithHappyHcType +case $WithNoFibHc in + haskell-compiler-unspecified ) # maybe they said something earlier... + if test $WithHc = 'haskell-compiler-unspecified' ; then + echo "Neither --with-hc nor --with-hc-for-nofib was properly set" + exit 1 + fi + ;; + ghc* | glhc* ) + WithNoFibHcType='HC_GLASGOW_GHC' + AC_CHECK_PROG(have_ghc,$WithNoFibHc,$ac_dir/$ac_word) + if test -z "$have_ghc"; then + echo "Can't find Glasgow Haskell to compile with: $WithNoFibHc" + exit 1 + fi + ;; + hbc* ) # Look for the dastardly competition + WithNoFibHcType='HC_CHALMERS_HBC' + AC_CHECK_PROG(have_hbc,$WithNoFibHc,YES,NO) + if test $have_hbc = 'NO' ; then + echo "Can't find Chalmers HBC to compile with: $WithNoFibHc" + exit 1 + fi + ;; + nhc* ) # Look for Niklas Rojemo's "nhc" + WithNoFibHcType='HC_ROJEMO_NHC' + AC_CHECK_PROG(have_nhc,$WithNoFibHc,YES,NO) + if test $have_nhc = 'NO' ; then + echo "Can't find Niklas Rojemo's NHC to compile with: $WithNoFibHc" + exit 1 + fi + ;; + IN-PLACE) WithNoFibHcType='HC_GLASGOW_GHC' + ;; +esac +AC_SUBST(WithNoFibHc) +AC_SUBST(WithNoFibHcType) + +dnl ** what mkworld \`setup' should be used? +AC_ARG_WITH(setup, + [ +What mkworld \`setup' should be used? +Choices: ghc, hbc, nhc +], + [case "$withval" in + ghc ) MkWorldSetup='ghc' + ;; + hbc ) MkWorldSetup='hbc' + ;; + nhc ) MkWorldSetup='nhc' + ;; + *) echo "I don't understand this option: --with-hc-for-nofib=$withval" + exit 1 + ;; + esac]) + +if test $MkWorldSetup = 'std' ; then + echo 'You must do --with-setup=... (one of: ghc, hbc, or nhc) for NoFib' + exit 1 +fi + +# --------------------------------------- +# What sets of tests should be run. +# +IncludeRealNoFibTests='YES' # defaults +IncludeSpectralNoFibTests='YES' +IncludeImaginaryNoFibTests='YES' +IncludePENDINGNoFibTests='NO' +IncludeUNUSEDNoFibTests='NO' +IncludeGHC_ONLYNoFibTests='NO' +IncludePRIVATENoFibTests='NO' +IncludeParallelNoFibTests='NO' + +dnl ** should *all* NoFib tests be run? +# special catch-all variant +AC_ARG_ENABLE(all-tests, + [Possibly turn on *all* of the possible tests (a sane choice +only if using GHC): + +--enable-all-tests do *all* tests], + [case "$enableval" in + yes) IncludePENDINGNoFibTests='YES' + IncludeUNUSEDNoFibTests='YES' + IncludeGHC_ONLYNoFibTests='YES' + IncludePRIVATENoFibTests='YES' + IncludeParallelNoFibTests='YES' + ;; + no) IncludePENDINGNoFibTests='NO' + IncludeUNUSEDNoFibTests='NO' + IncludeGHC_ONLYNoFibTests='NO' + IncludePRIVATENoFibTests='NO' + IncludeParallelNoFibTests='NO' + + IncludeRealNoFibTests='NO' + IncludeSpectralNoFibTests='NO' + IncludeImaginaryNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-all-tests=$enableval" + exit 1 + ;; + esac]) + +dnl ** turn on/off individual categories of tests... +# individual categories +AC_ARG_ENABLE(imaginary-tests, + [ +Enable/disable individual categories of tests: + +--disable-imaginary-tests do *not* include imaginary tests], + [case "$enableval" in + yes) IncludeImaginaryNoFibTests='YES' + ;; + no) IncludeImaginaryNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-imaginary-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(spectral-tests, + [--disable-spectral-tests do *not* include spectral tests], + [case "$enableval" in + yes) IncludeSpectralNoFibTests='YES' + ;; + no) IncludeSpectralNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-spectral-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(real-tests, + [--disable-real-tests do *not* include real tests], + [case "$enableval" in + yes) IncludeRealNoFibTests='YES' + ;; + no) IncludeRealNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-real-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(PENDING-tests, + [--enable-PENDING-tests include PENDING tests], + [case "$enableval" in + yes) IncludePENDINGNoFibTests='YES' + ;; + no) IncludePENDINGNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-PENDING-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(UNUSED-tests, + [--enable-UNUSED-tests include UNUSED tests], + [case "$enableval" in + yes) IncludeUNUSEDNoFibTests='YES' + ;; + no) IncludeUNUSEDNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-UNUSED-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(GHC-ONLY-tests, + [--enable-GHC-ONLY-tests include GHC_ONLY tests], + [case "$enableval" in + yes) IncludeGHC_ONLYNoFibTests='YES' + ;; + no) IncludeGHC_ONLYNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-GHC-ONLY-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(PRIVATE-tests, + [--enable-PRIVATE-tests include PRIVATE tests], + [case "$enableval" in + yes) IncludePRIVATENoFibTests='YES' + ;; + no) IncludePRIVATENoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-PRIVATE-tests=$enableval" + exit 1 + ;; + esac]) + +AC_ARG_ENABLE(parallel-tests, + [--enable-parallel-tests include parallel tests +], + [case "$enableval" in + yes) IncludeParallelNoFibTests='YES' + ;; + no) IncludeParallelNoFibTests='NO' + ;; + *) echo "I don't understand this option: --enable-parallel-tests=$enableval" + exit 1 + ;; + esac]) + +AC_SUBST(IncludeRealNoFibTests) +AC_SUBST(IncludeSpectralNoFibTests) +AC_SUBST(IncludeImaginaryNoFibTests) +AC_SUBST(IncludePENDINGNoFibTests) +AC_SUBST(IncludeUNUSEDNoFibTests) +AC_SUBST(IncludeGHC_ONLYNoFibTests) +AC_SUBST(IncludeSpecialiseNoFibTests) +AC_SUBST(IncludePRIVATENoFibTests) +AC_SUBST(IncludeParallelNoFibTests) + +# here ends a very big if DoingNoFib = 'nofib' ... +fi +# +# ------------------------------------------------------------------------- +dnl +dnl * extract non-header files with substitution (end) +# +AC_SUBST(MkWorldSetup) + +AC_OUTPUT(Makefile STARTUP mkworld/site.jm mkworld/platform.h mkworld/config.h $ghc_mkworld_site_ghc_jm $ghc_includes_platform_h $nofib_mkworld_site_nofib_jm) + +echo '************************************************' +echo '*** NOW DO: sh < STARTUP' +echo '************************************************' +exit 0 diff --git a/ghc/.gdbinit b/ghc/.gdbinit new file mode 100644 index 0000000..03a6b1e --- /dev/null +++ b/ghc/.gdbinit @@ -0,0 +1,125 @@ +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/storage +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/c-as-asm +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/io +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/main +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/prims +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/profiling +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/runtime/gmp +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/MainIO +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/PreludeErrIO +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/PreludeGlaST +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/PreludePrimIO +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/Stdio +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/PreludeDialogueIO +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/glaExts/ByteOps +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/Builtin +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/Core +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IO +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/PS +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/List +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/Prel +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/Text +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/TysBasic +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/Cls +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IArray +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IBool +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IChar +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IComplex +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IDouble +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IFloat +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IInt +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IInteger +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IList +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/IRatio +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/ITup0 +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/ITup2 +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/ITup3 +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/ITup4 +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/ITup5 +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/TyArray +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/TyBool +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/TyComplex +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/TyIO +directory /local/grasp_tmp3/partain/ghc-BUILDS/working/ghc/lib/prelude/TyRatio + +define pR1 +print (sfp) (((STGRegisterTable)MainRegTable).rR1) +end +define pR2 +print (sfp) (((STGRegisterTable)MainRegTable).rR2) +end +define pR3 +print (sfp) (((STGRegisterTable)MainRegTable).rR3) +end +define pR4 +print (sfp) (((STGRegisterTable)MainRegTable).rR4) +end +define pR5 +print (sfp) (((STGRegisterTable)MainRegTable).rR5) +end +define pR6 +print (sfp) (((STGRegisterTable)MainRegTable).rR6) +end +define pR7 +print (sfp) (((STGRegisterTable)MainRegTable).rR7) +end +define pR8 +print (sfp) (((STGRegisterTable)MainRegTable).rR8) +end +define pFlt1 +print (StgFloat) (((STGRegisterTable)MainRegTable).rFlt1) +end +define pDbl1 +print (StgDouble) (((STGRegisterTable)MainRegTable).rDbl1) +end + +define pSpA +print (sfp) (((STGRegisterTable)MainRegTable).rSpA) +end +define pSuA +print (sfp) (((STGRegisterTable)MainRegTable).rSuA) +end +define pSpB +print (sfp) (((STGRegisterTable)MainRegTable).rSpB) +end +define pSuB +print (sfp) (((STGRegisterTable)MainRegTable).rSuB) +end + +define pHp +print (sfp) (((STGRegisterTable)MainRegTable).rHp) +end + +define pHpLim +print (sfp) (((STGRegisterTable)MainRegTable) .rHpLim) +end + +define pn +call DEBUG_PRINT_NODE(Ret1) +end + +define pt +call DEBUG_TREE(Ret1) +end + +define pit +call DEBUG_INFO_TABLE(Ret1) +end + +define pr +call DEBUG_REGS() +end + +define pas +call DEBUG_ASTACK(32767) +end + +define pbs +call DEBUG_BSTACK(32767) +end + +define pus +call DEBUG_UPDATES(32767) +end diff --git a/ghc/CONTRIB/README b/ghc/CONTRIB/README new file mode 100644 index 0000000..df029e9 --- /dev/null +++ b/ghc/CONTRIB/README @@ -0,0 +1,17 @@ +This directory contains contributed software/bits related to the +Glasgow Haskell compiler. + +fptags Denis Howe + Bourne-shell script. + Create an emacs tags file for one or more functional programs. + +haskell.el A Haskell mode from Simon Marlow . + +haskel.gif Provided by Lennart Augustsson + +mira2hs Denis Howe + Bourne-shell script. + Convert Miranda code to Haskell, more-or-less. + +pphs Pretty-print Haskell code in LaTeX documents. Written by + Andrew Preece while a student at Glasgow. diff --git a/ghc/CONTRIB/fptags b/ghc/CONTRIB/fptags new file mode 100644 index 0000000..be4b5a5 --- /dev/null +++ b/ghc/CONTRIB/fptags @@ -0,0 +1,53 @@ +#!/bin/sh + +#fptags - Create an emacs tags file for functional programs + +#Please send me a copy of any modifications you make. +#Denis Howe +#0.00 20-Sep-1991 created +#0.01 09-Apr-1992 don't count ==, <=, >= as definition +#0.02 09-Feb-1994 fix bug in fix 0.01. Add /=. + +# partain: got it from wombat.doc.ic.ac.uk:pub + +#The algorithm for spotting identifiers is crude to the point of +#vulgarity. Any line containing an = is assumed to define an +#identifier. If there are no non-white characters before the = then +#the definition is assumed to start on the previous line. White +#characters are space, tab and > (for literate programs). The =s in +#the relations ==, <=, >= and /= are temporarily transformed while +#searching for =s. + +#The tags file is not in the format produced by ctags but rather, +#that produced by etags and used by GNU-Emacs's find-tag command. + +#Does not tag constructors in sum data types. + +#The tags file, TAGS, is created in the current directory. It +#contains an entry for each argument file. The entry begins with a +#line containing just ^L. The next line contains the filename, a +#comma and the number of following bytes before the next ^L or EOF. +#Subsequent lines should give the location within the argument file of +#identifier definitions. Each line contains a prefix of a line from +#the argument file, a ^?, the line number within the argument file, a +#comma and the position of the start of that line in the argument file +#(first character = 1). + +[ -z "$1" ] && echo usage: $0 files && exit 1 +exec > TAGS +tf=/tmp/fp$$ +for f +do echo " " + sed 's/==//g + s/>=/>/g + s/<=/</g + s|/=|/|g' $f | awk ' + /^[> ]*=/{ print prevline "" NR-1 "," prevpos; } + /[^> ].*=/{ print $0 "" NR "," pos; } + { prevline = $0; prevpos = pos; pos += length($0)+1; } + ' pos=1 | sed 's/[ )]*=.*// + s//=/g' > $tf + echo -n $f,; echo `wc -c < $tf` #lose spaces + cat $tf +done +rm -f $tf diff --git a/ghc/CONTRIB/haskel.gif b/ghc/CONTRIB/haskel.gif new file mode 100644 index 0000000000000000000000000000000000000000..89b20abefcd85c191c5588b06b458d5a10227ffe GIT binary patch literal 5380 zcmV+f75nN(Nk%v~VH5!)0q_6-|Ns90001li0000K0V4qb0{(=LsmtvTqnxzbi?iOm z`wxcVNS5Y_rs~SJ?hD8AOxN~}=lag~{tpZahs2`sh)gP%%%<}RjY_A~s`ZM^YPa03 z_X`e-$BRHBfKIE;2()TVjw{ymy8VvN>-Ti08=&^Y2FO=vc!-#&I4Fc@@aMp`I7z8U z68Nb1Vc3&4R|y)r_X#OSc(+sfAljD+N@#l0YNHx!3xQcvd&?WCD#^0jJ6r}S$ta6V zyj+Z|Z1T)3ec<^R98HTot*b1&seJ}M@+-bnz8Z4QP)&{EO}a6d+s!EK-1csfFHy=4 z->}aYJ`M9ys5=#p8m3;hVA12Nh={%7?%c03c$q6d+HF1Eu6@MKAo zurdi$d5WC8d#*l3YH0FLt&KJnQltsix*?4iyxDNf% zrA1gCP!?7|-F1PTx6onoePv=$Hqu66kNKVE-2_3x$ib9SqL|`0R#vGQI9qN;Ut@?mO}Z71EA2%LM3>>9djC?F$sDl zenfS`k43W87AJsnxmXh(c_sMeo}He_!#;X;SR9m4##9`C8k*%Ea&|2!=BOg@`Q@i_ zmc!vH9yLXxt8tlUC#!pe$|st)->%T$T>@T+*1n25*(7T3&Bo$e&B=?Y zbVivO?VsR^3-OWU!t2<1N6L$2zmfg=p}EugD3`V(a(Swo{0KNP$C3(*7`M#n$g9g6 zvX}6USs6%b2KHvzXpr7~d}YQf)_k0>8LoDz$Sik-9qqd<*UcuL zA+h`@E-$hjrp$(CV<*12M*jS`5ulYUR^?-q9Q7LyYu<>aE`J^$=u_~)_0Br0ZaO!p z=SljBt?R(bq9@P5`s}I}Dav-TN=8HOmZ#k%<^cDOYVtB}4V~-eurkVs&>uoG)pz|) zI1K;ZFg+#GSMrUa8TZOtDyZNBcK4(BJ*;}hYrimvt-hbKLBmDgt@?e$o?^g|gX|;! z1Wj^@(FDTolRc-AY;k=OS^$y7kc$ZqeUo}05ZD)|LdD>0?)ggRU`N0%U@$KlgdgBW zhdD}lj(?#8*WQ9xl(ulLLlXp(7gYB`++K__k}2RjTRyOLD}Q86k+EG%3CeetQX{S68M*_mT%XvRx1 zYeF%!9|gx|uQqxne@-eE{vxG6*wiYCWYQH5m86=H5wSA);{;*?2}wuhNpgz&k@#NK zm0Ug2hK5`Oks>(>G!{aNo~xuK&4M6KQHzPEJRbI5z{(YRv5Y%{)m1G;*Gx{L?{*5jhCS@(&d8YyqdPR@0C$wb)&xu@0t}4S zVinR0b`pdQ6`aI6s4nK&Z6tUbR7`zfl1!JZPf!^t3=Qb3mme>T2xT_tL5 zx+pV!I3H@p?WN9qNpya8v;$%iqpQ;@Ab%PtT+z{>VQpgdq^3MRo>6v79pMqM8OzjA zwVq6}Q3NNmEiKj6u0%-V)JTQEf0o85)=|q!`9~eJN+^tEbL&5Cda(h;l|o1p=dqMI zH?wXqU;Zo55eW%cV#e%6a6F$!B}){-Cec4BoD|w<=D5~Y43DxMn^*~mqH6+^uVrN@ zOnd(8sXVZ=jH2VMYq@#W*Xa(m{R3@m2?fgOuFheiUEm`_sa>5h?p|BXrp44rIjrg< zA#?Sc8k;#>lU^`g_MGJIoSIp2R#mmH;-JCMR*|UYmyz@JY(N2dU+Y1ax~q(4F86!0 z2=?ZB!R;vXd+9BT6jcC@qnHNY-;uVCIwPV3?ku=S;2T8M+x(hgWbmpp8E zW^`Dy!6<(4ba6{z_{xn+sXgqvv5XDNuf-GzV?z7=kWXZ~IvblPt}|+hU1Z!T#CF zHG{;iS#5vHh0dMcs%(Dxaqv!SSiRA=Xi({iprdH5Hunoa&xG*2Qi?{PMr6YT7IMf+ z6(G=hY3k+WXv-;7-Hu0;rXpx@(`su6_X*ce)idloylU}^I$Xw% z7*vZ*E|95vjrE55 zjx+@>OUdgn9fFJ-Exz)rIeF*PA_>X{Zig6SEMoxUyJ0%)w`F_8?v2gN&o=Z5yqz^u z@E}^V#&qe$SDayuT1AltzZ_@y+c3nbR5@R4mt&Xpa%7%c!;$jp9Hodi{zl)}JLWYd zvNcv!;59nFkW25nwTbhFvg#i&w~&;Z9^cx8yV8;wI?hg5p!Q`q}fwxD? zyy5y(zi8!Lin@;HU2IU}HPx>d&9Ad=<#T-YNuw_P-^X^SzAH$$%1I@6hqvY}cU>yqW=Zw_uV3pQm*w4w9e?@H ze^ZG3`&PPqO!~Kf-O_%|COw0;Jt}8<16Wo;2Yc6%fXd}(2gQKwhcL%ia9KrWLt{Yt zm3DXnJ{p&SxsfQFAzkmJV##C)Ylc(S_CnY8FM32<40lDwBRV07atv2~rqVRebr@D-Y*K@6wXHuv> z9!EmWM`0qEBNhig*!F}>kx0uIhIJQ(eoFB=U!aJQ3IKHhhv2zHj4QeeoDY)Dd>*5 zxJA_XfTua(fwUd)8cA6jV`I zN|-5Ec9;$!shGBTRIinrpSPO_=$3mXi*|l+>7{sX})$k6&q8{(RXpJSjl7Wtbg>o3V+CvXD`ExS925ZZqcG7Gp~zRDF!+!8 zMvyfX2-2CM_IGFzNt8b&T;g$^)cBvumwKlXlR!2cG?;k%7*bkATk092sYsJHnwbWe zmXVp8M95Q@PHR4F~&8g@Ognm*_^i-j~&>K6-uODDtUG~P=v~xh-zx< zF``-HT?h0#fGTl1N~yESEz$Y@YI3-6ditOAlcuStq>y(X7!wQX6s&`n?D!o*l-RPgSbfTk5msSO-aQTsqglyJoXebtt9%^%arigx7jqSN% z|46M}IA`w)mY+zP+SoG{r%zfLsGpi!JQ#zK8jd@vsbI7hg{Y;$_${60Sl5cLTB@s? zM|-g-cC0C-E!eGGDM1KVj@$*O4C{At`mD|hr_L8@faYHe%A_xeb}tw^wlQH?b&#P- zhSB<&yIP(UM^>WPEZ6?iMD=r@niO`63T{pLmMyA|D)Wl{iLUt6VO3N^a~EsdB%UW& zkyq+HXt^2!OM>6oGCcW1pLaD1YH1Yumm-^{*%+U^XhJoWVl?Vqp;s61_j1GMZmW5Z z4LPZ~CyZ^#uU!dxKM0yfTU*7Gl3OdNAG(%^$90l6C+^Z$^toW38kba8@oPyqYDO+;N@hR9*WhQiNt5{M5Yth<+J2xZ71D zs)314+q2mFu>R$WY9~gp_ffIDC2zB|hj2^0c8QXJ){~t|aZ_ib1%tC3IVMZ_qQzU3 z0Qx$TCWA5BI3_u?lDc-P$7G=!qH$U)-->N!xxahyVl0b~0gPs1ioeHou@wrv23%n@ zJA=rXyFOb45cQk&*|+~|!ds`e(1*daS8}TBZG(se1l+Kk+NoA~KPDA~j4Q6cB%F?G zZ*mBxF-5P``n~BBq^yOp4DviOYOo+RpVBv$Qk*+otV&mv1UyQ_#Fq@3k~Kgm#V&io zR3|WG{KKRRu1#wn@EeC(d&1TGs$|Av55vSwTzExHfCpQ_d^^Qz8lT_VzkrOcXkvsT zO2Uh~{;js!$2u&;8j3HIM1^<>r8mio3ihPzn8`dFw_ohR`P*2^7RnO1z%^3J=1L-( zT!zCFd`4D#-!sb5bGq}qki$70C$-efZ zkM#iSU@&47Qjts_S;ZpghfcjJ9C+glt>8`HarTDYnN9V;y#!ojYta ztIN*Xmkf=%6D`U3JfCzX%+eIdTzrx0xPj}t$ndRvg}sVScX@;Ra4w_c2>H1Y(P+Epps0MiHy>2#&J7a#;d8qAR1i+eW-s5 z)7a<2$6M5|M`LE1)shO-V?@B~1J$Yw!kA3ersrxl^^gpCf)I?#Kb^WzU6tKe)7bi7 z)0;{CShOvr*Dov7n@h**iPkL|noFH-Q=QVr*v5&yq}Ges-^HCnin;&n!s5Cym95fI zOwm>5)svTyvC7jT-O_}2U+4FZr;W%ttJKO1kzhR1jLn24H?OsPzBmfkPkh=XYR=b~ zf8WceKK9JMeXLLBq|6(^bX>{FOwSg*8qZzke6M#jU|~SKI!U*v`v} z$3yGS{y-ox^z|EzgQ_8__D!xJ(-Vr6!yD%Q*e#me+B5F6GPrc{RY|SZW_E%JiWc!hSSchu7RID+>iOGMxC_b1zLl?OiwJTe5cy8*W)0Vxzoh8sZ7v9dfd|v z>=u;jZm!+7&Vxnx;|%ESke)o3P1vGT)#qM;%vipq*4#@=#P7aDa(9|ji>yR@$Hf?!1- iFY+T#@+EKbCy(+euktI;@-6T3FAwuEFY`)J0028i;iIzv literal 0 HcmV?d00001 diff --git a/ghc/CONTRIB/haskell.el b/ghc/CONTRIB/haskell.el new file mode 100644 index 0000000..43461eb --- /dev/null +++ b/ghc/CONTRIB/haskell.el @@ -0,0 +1,185 @@ +;;; Haskell mode for emacs (c) Simon Marlow 11/1/92 + +;;; To: partain@dcs.gla.ac.uk +;;; Subject: Haskell mode for emacs +;;; Date: Mon, 14 Dec 92 17:41:56 +0000 +;;; From: Simon Marlow +;;; +;;; ... What it buys you: very little actually, but the nice things are +;;; +;;; (i) Pressing line feed indents the next line according to the +;;; previous one, +;;; (ii) Pressing Meta-; gives you a comment on the current line, +;;; (iii) For literate scripts, pressing line feed gives you a bird +;;; track on the next line if there was one on the previous +;;; line, and does the indentation +;;; (iv) For literate scripts, pressing Meta-Tab toggles a bird track +;;; on or off at the beginning of the current line, +;;; (v) There's a function for toggling bird tracks on all lines in a +;;; region. +;;; (vi) Emacs says "Haskell" or "Literate Haskell" in the mode line :-) +;;; +;;; You'll have to make the necessary changes in .emacs to load in the +;;; library automatically (you probably know what to do). ... + +(defvar haskell-mode-map () + "Keymap used in Haskell mode.") + +(defvar haskell-literate-mode-map () + "Keymap used in Haskell literate script mode.") + +(defvar haskell-mode-syntax-table () + "Syntax table for haskell mode.") + +(if haskell-mode-map + () + (setq haskell-mode-map (make-sparse-keymap)) + (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)) + +(if haskell-literate-mode-map + () + (setq haskell-literate-mode-map (make-sparse-keymap)) + (define-key haskell-literate-mode-map "\C-j" 'haskell-literate-newline-and-indent) + (define-key haskell-literate-mode-map "\M-\C-i" 'haskell-literate-toggle-bird-track-line)) + +(if haskell-mode-syntax-table + () + (let ((i 0)) + (setq haskell-mode-syntax-table (make-syntax-table)) + (while (< i ?0) + (modify-syntax-entry i "." haskell-mode-syntax-table) + (setq i (1+ i))) + (while (< i (1+ ?9)) + (modify-syntax-entry i "_" haskell-mode-syntax-table) + (setq i (1+ i))) + (while (< i ?A) + (modify-syntax-entry i "." haskell-mode-syntax-table) + (setq i (1+ i))) + (while (< i (1+ ?Z)) + (modify-syntax-entry i "w" haskell-mode-syntax-table) + (setq i (1+ i))) + (while (< i ?a) + (modify-syntax-entry i "." haskell-mode-syntax-table) + (setq i (1+ i))) + (while (< i (1+ ?z)) + (modify-syntax-entry i "w" haskell-mode-syntax-table) + (setq i (1+ i))) + (while (< i 128) + (modify-syntax-entry i "." haskell-mode-syntax-table) + (setq i (1+ i))) + (modify-syntax-entry ? " " haskell-mode-syntax-table) + (modify-syntax-entry ?\t " " haskell-mode-syntax-table) + (modify-syntax-entry ?\n ">" haskell-mode-syntax-table) + (modify-syntax-entry ?\f ">" haskell-mode-syntax-table) + (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table) + (modify-syntax-entry ?\' "w" haskell-mode-syntax-table) + (modify-syntax-entry ?_ "w" haskell-mode-syntax-table) + (modify-syntax-entry ?\\ "." haskell-mode-syntax-table) + (modify-syntax-entry ?\( "()" haskell-mode-syntax-table) + (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table) + (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table) + (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table) + (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table) + (modify-syntax-entry ?} "){4" haskell-mode-syntax-table) + (modify-syntax-entry ?- "_ 123" haskell-mode-syntax-table) + )) + +(defun haskell-vars () + (kill-all-local-variables) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'comment-start) + (setq comment-start "--") + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "--[^a-zA-Z0-9]*") + (make-local-variable 'comment-column) + (setq comment-column 40) + (make-local-variable 'comment-indent-hook) + (setq comment-indent-hook 'haskell-comment-indent)) + +(defun haskell-mode () + "Major mode for editing Haskell programs. +Blank lines separate paragraphs, Comments start with '--'. +Use Linefeed to do a newline and indent to the level of the previous line. +Tab simply inserts a TAB character. +Entry to this mode calls the value of haskell-mode-hook if non-nil." + (interactive) + (haskell-vars) + (setq major-mode 'haskell-mode) + (setq mode-name "Haskell") + (use-local-map haskell-mode-map) + (set-syntax-table haskell-mode-syntax-table) + (run-hooks 'haskell-mode-hook)) + +(defun haskell-literate-mode () + "Major mode for editing haskell programs in literate script form. +Linefeed produces a newline, indented maybe with a bird track on it. +M-TAB toggles the state of the bird track on the current-line. +Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook." + (interactive) + (haskell-vars) + (setq major-mode 'haskell-literate-mode) + (setq mode-name "Literate Haskell") + (use-local-map haskell-literate-mode-map) + (set-syntax-table haskell-mode-syntax-table) + (run-hooks 'haskell-mode-hook) + (run-hooks 'haskell-literate-mode-hook)) + +;; Find the indentation level for a comment.. +(defun haskell-comment-indent () + (skip-chars-backward " \t") + ;; if the line is blank, put the comment at the beginning, + ;; else at comment-column + (if (bolp) 0 (max (1+ (current-column)) comment-column))) + +;; Newline, and indent according to the previous line's indentation. +;; Don't forget to use 'indent-tabs-mode' if you require tabs to be used +;; for indentation. +(defun haskell-newline-and-indent () + (interactive) + (newline) + (let ((c 0)) + (save-excursion + (forward-line -1) + (back-to-indentation) + (setq c (if (eolp) 0 (current-column)))) + (indent-to c))) ;ident new line to this level + +;;; Functions for literate scripts + +;; Newline and maybe add a bird track, indent +(defun haskell-literate-newline-and-indent () + (interactive) + (newline) + (let ((bird-track nil) (indent-column 0)) + (save-excursion + (forward-line -1) + (if (= (following-char) ?>) (setq bird-track t)) + (skip-chars-forward "^ \t") + (skip-chars-forward " \t") + (setq indent-column (if (eolp) 0 (current-column)))) + (if bird-track (insert-char ?> 1)) + (indent-to indent-column))) + +;; Toggle bird-track ][ +(defun haskell-literate-toggle-bird-track-line () + (interactive) + (save-excursion + (beginning-of-line) + (if (= (following-char) ? ) + (progn (delete-char 1) (insert-char ?> 1)) + (if (= (following-char) ?>) + (progn (delete-char 1) (insert-char ? 1)) + (progn (insert-char ?> 1) (insert-char ? 1)))))) + +(defun haskell-literate-toggle-bird-track-region (start end) + (interactive "r") + (save-excursion + (goto-char start) + (while (<= (point) end) + (beginning-of-line) + (haskell-literate-toggle-bird-track-line) + (forward-line 1)))) + diff --git a/ghc/CONTRIB/haskell_poem b/ghc/CONTRIB/haskell_poem new file mode 100644 index 0000000..1f82186 --- /dev/null +++ b/ghc/CONTRIB/haskell_poem @@ -0,0 +1,58 @@ +From: dsmith@lucy.cs.waikato.ac.nz +Subject: A Haskell Lover's Plea +Date: Thu, 16 Mar 1995 21:06:35 -0500 +To: haskell-dist@dcs.gla.ac.uk + + + A Haskell Lover's Plea + +Why should I renounce for you, dear Haskell, +My much yearned for side-effects? +Why should I face the software dragons +Without my weapon, my manly spear of destruction? +They call you non-strict, oh so elegant and pure Ariel. +Yet side-effect celibacy is surely severe. + + Your flesh is too weak, you brutish beast. + The tarpit demons of software hell await you! + This sinful habit in which you indulge + Does more harm than good. + Restrain yourself! And you too will see + The wondrous and refined joys of referential transparency! + +Alas, I can do without goto, without call/cc. +But sans side-effects, I am lost and forlorn, can't you see? +Oh, lady fairer yet than admirable Miranda (tm), +Scheme's prolix, parenthetical tedium +Is no match for your elegant syntax. What's more, +Your list comprehensions outshine even Prolog for sure... + + Ah, flatter me not, you low-spirited Caliban! + Do you not know what advantages await + Those who renounce destructive update? + Start with an immaculate high-level specification, + Throw in some algebraic code transformation. + Soon you will have a provably correct and maintainable implementation. + +Show mercy on mere mortals like me! +How I dream still of the efficient pleasures of pointer manipulation! +How I too wish to mutate memory with thoughts born of von Neumann earthiness! +Relent! Relent! Let me have my assignment, my printf, my gensym. +Let me fulfill my destructive impulses. +Let me set bang. Let me update. Let me assign. Let me mutate. + + Fear not, lowly beast, I have heard your pleas. + To satisfy your low-level desire + I'll give you monads, linear types, MADTs, + Even single-threaded polymorphic lambda calculi. + My beauty may suffer, still I will aspire + To let you do (within typeful limits) what you please. + +Rejoice! Rejoice! I'm free! I'm free! +The best of both worlds is mine at last. +Oh, infinite progeny of Church, Hope, and ML, +I curry favor not when I say: +Scan me right, fold me left, +Lazy lady of many shapes, you've got class. + + Don Smith (dsmith@cs.waikato.ac.nz) diff --git a/ghc/CONTRIB/mira2hs b/ghc/CONTRIB/mira2hs new file mode 100644 index 0000000..1ad6104 --- /dev/null +++ b/ghc/CONTRIB/mira2hs @@ -0,0 +1,364 @@ +#!/bin/sh + +# mira2hs - Convert Miranda to Haskell (or Gofer) + +# usage: mira2hs [infile [outfile]] +# +# Input defaults to stdin, output defaults to .hs or stdout if +# input is stdin + +# Copyright Denis Howe 1992 +# +# Permission is granted to make and distribute verbatim or modified +# copies of this program, provided that every such copy or derived +# work carries the above copyright notice and is distributed under +# terms identical to these. +# +# Miranda is a trademark of Research Software Limited. +# (E-mail: mira-request@ukc.ac.uk). +# +# Denis Howe + +# NOTE: This program needs a sed which understands \ regular +# expressions, eg. Sun or GNU sed (gsed). + +# partain: got it from wombat.doc.ic.ac.uk:pub + +# 1.05 18 Sep 1992 zip -> zipPair +# 1.04 29 Jul 1992 Improve handling of ==, -- and whitespace round guards +# $infix -> `infix` +# 1.03 24 Apr 1992 Incorporate Lennart's miranda.hs functions +# Replace most Miranda fns & operators +# Use \ patterns, ';' -> ',' in list comprehension +# Provide example main functions +# 1.02 30 Mar 1992 Mods to header, fix handling of type,type +# Comment out String definition, Bool ops +# num -> Int, = -> == in guards +# 1.01 10 Dec 1991 Convert type names to initial capital +# 1.00 27 Sep 1991 Initial version advertised to net + +# Does NOT handle: +# continued inequalities (a < x < b) +# boolean '=' operator -> '==' (except in guards) +# main function +# multi-line type definitions +# guards on different line from body +# diagonalised list comprehensions (//) +# repeated variables in patterns (eg. LHS of function) +# filemode -> statusFile, getenv -> getEnv, read -> readFile, system +# include directives +# conflicts with prelude identifiers + +# Miranda's num type (Integral+Floating) is changed to Int so won't +# work for non-intger nums. Miranda has irrefutable ("lazy") tuple +# patterns so you may need to add a ~, like ~(x,y) in Haskell. +# Haskell functions "length" and "not" may need parentheses round +# their arguments. + +# mira2hs copes equally well with literate and illiterate scripts. It +# doesn't care what characters lines begins with - it assumes +# everything is code. It will convert code even inside comments. +# +# For literate programs you will have to turn the standard header into +# literate form and rename the output .lhs. You might want to do this +# to (a copy of) mira2hs itself if you have lots of literate progs. + +# ToDo: = inside brackets -> == + +if [ -n "$1" ] +then in=$1 + out=`basename $in .m`.hs +else in="Standard input" +fi +[ -n "$2" ] && out=$2 +tmp=/tmp/m2h$$ +script=${tmp}s + +# Prepend a standard header and some function definitions. +echo -- $in converted to Haskell by $USER on `date` > $tmp +cat << "++++" >> $tmp +module Main (main) where + +-------------------- mira2hs functions -------------------- + +cjustify :: Int -> String -> String +cjustify n s = spaces l ++ s ++ spaces r + where + m = n - length s + l = div m 2 + r = m - l + +e :: (Floating a) => a +e = exp 1 + +hugenum :: (RealFloat a) => a +hugenum = encodeFloat (r^d-1) (n-d) + where r = floatRadix hugenum + d = floatDigits hugenum + (_,n) = floatRange hugenum + +subscripts :: [a] -> [Int] -- Miranda index +subscripts xs = f xs 0 + where f [] n = [] + f (_:xs) n = n : f xs (n+1) + +integer :: (RealFrac a) => a -> Bool +integer x = x == fromIntegral (truncate x) + +lay :: [String] -> String +lay = concat . map (++"\n") + +layn :: [String] -> String +layn = concat . zipWith f [1..] + where + f :: Int -> String -> String + f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n" + +limit :: (Eq a) => [a] -> a +limit (x:y:ys) | x == y = x + | otherwise = limit (y:ys) +limit _ = error "limit: bad use" + +ljustify :: Int -> String -> String +ljustify n s = s ++ spaces (n - length s) + +member :: (Eq a) => [a] -> a -> Bool +member xs x = elem x xs + +merge :: (Ord a) => [a] -> [a] -> [a] +merge [] ys = ys +merge xs [] = xs +merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys + | otherwise = y : merge xxs ys + +numval :: (Num a) => String -> a +numval cs = read cs + +postfix :: [a] -> a -> [a] +postfix xs x = xs ++ [x] + +rep :: Int -> b -> [b] +rep n x = take n (repeat x) + +rjustify :: Int -> String -> String +rjustify n s = spaces (n - length s) ++ s + +seq :: (Eq a) => a -> b -> b +seq x y = if x == x then y else y + +shownum :: (Num a) => a -> String +shownum x = show x + +sort :: (Ord a) => [a] -> [a] +sort x | n <= 1 = x + | otherwise = merge (sort (take n2 x)) (sort (drop n2 x)) + where n = length x + n2 = div n 2 +spaces :: Int -> String +spaces 0 = "" +spaces n = ' ' : spaces (n-1) + +tinynum :: (RealFloat a) => a +tinynum = encodeFloat 1 (n-d) + where r = floatRadix tinynum + d = floatDigits tinynum + (n,_) = floatRange tinynum + +undef :: a +undef = error "undefined" + +zipPair (x,y) = zip x y + +-- Following is UNTESTED +data Sys_message = + Stdout String | Stderr String | Tofile String String | + Closefile String | Appendfile String | +-- System String | + Exit Int + +doSysMessages :: [Sys_message] -> Dialogue +doSysMessages requests responses = doMsgs requests [] + +doMsgs [] afs = [] +doMsgs ((Appendfile f):rs) afs = doMsgs rs (f:afs) +doMsgs ((Exit n) :rs) afs = [] +doMsgs (r :rs) afs + = doMsg r : doMsgs rs afs + where doMsg (Stdout s) = AppendChan stdout s + doMsg (Stderr s) = AppendChan stderr s + doMsg (Tofile f s) | elem f afs = AppendFile f s + | otherwise = WriteFile f s + doMsg (Closefile f) + = error "doSysMessages{mira2hs}: Closefile sys_message not supported" +-- doMsg (Closefile f) = CloseFile f -- optional +-- doMsg (System cmd) +-- = error "doSysMessages{mira2hs}: System sys_message not supported" + +-- Pick a main. (If I was clever main would be an overloaded fn :-). +main :: Dialogue +-- main = printString s -- s :: String +-- main = interact f -- f :: String -> String +-- main = doSysMessages l -- l :: [Sys_message] +-- main = print x -- x :: (Text a) => a + +printString :: String -> Dialogue +printString s = appendChan stdout s abort done + +-------------------- mira2hs functions end -------------------- + +++++ +# It's amazing what sed can do. +sed ' +# Type synonyms and constructed types: insert "type" or "data". Add a +# dummy :: to flag this line to the type name munging below. Beware +# ====== in comments. +/[^=]==[^=]/s/\(.*=\)=/::type \1/g +/::=/s/\(.*\)::=/::data \1=/g +# Change type variable *s to "a"s +/::/s/\*/a/g +# List length & various other renamed functions (# reused below). +s/ *# */ length /g +s/\/atan/g +s/\/ord/g +s/\/flip/g +s/\/chr/g +s/\/dropWhile/g +s/\/isDigit/g +s/\/floor/g +s/\/head/g +s/\/subscripts/g +s/\/isAlpha/g +s/\/zipWith/g +s/\/maximum/g +s/\/max/g +s/\/minimum/g +s/\/min/g +s/\/nub/g +s/\/negate/g +s/\/scanl/g +s/\/tail/g +# Miranda uncurried zip -> zipPair (above). Do before zip2->zip. +s/\/zipPair/g +# Miranda curried zip2 -> zip +s/\/zip/g +# Haskel div and mod are functions, not operators +s/\/\`div\`/g +s/\/\`mod\`/g +# Locate commas introducing guards by temporarily changing others. +# Replace comma with # when after || or unmatched ( or [ or before +# unmatched ) or ] or in string or char constants. Replace +# matched () not containing commas with _<_ _>_ and matched [] +# with _{_ _}_ and repeat until no substitutions. +: comma +s/\(||.*\),/\1#/g +s/\([[(][^])]*\),/\1#/g +s/,\([^[(]*[])]\)/#\1/g +s/(\([^),]*\))/_<_\1_>_/g +s/\[\([^],]*\)\]/_{_\1_}_/g +s/"\(.*\),\(.*\)"/"\1#\2"/g +'"#change quotes +s/','/'#'/g +"'#change quotes +t comma +# Restore () and [] +s/_<_/(/g +s/_>_/)/g +s/_{_/[/g +s/_}_/]/g +# The only commas left now introduce guards, remove optional "if" +s/,[ ]*if/,/g +s/[ ]*,[ ]*/,/g +# Temporarily change ~=, <=, >=. +s%~=%/_eq_%g +s/<=/<_eq_/g +s/>=/>_eq_/g +# Replace every = in guard with == (do after type synonyms) +: neq +s/\(,.*[^=]\)=\([^=]\)/\1==\2/ +t neq +# Fix other equals +s/_eq_/=/g +# Replace = , with | () = +s/=\(..*\),\(..*\)/| (\2) =\1/g +s/(otherwise)/otherwise/g +# Restore other commas +s/#/,/g +# List difference. Beware ------ in comments. +s/\([^-]\)--\([^-]\)/\1\\\\\2/g +# Comments (do after list diff) +s/||/--/g +s/--|/---/g +# Boolean not, or, and (do after comments) +s/ *~ */ not /g +s% *\\/ *% || %g +s/&/&&/g +# list indexing +s/!/!!/g +# Locate semicolon in list comprehensions by temporarily replacing ones +# in string or char constants with #. Replace matched [] not +# containing semicolon with _{_ _}_ and repeat until no substitutions. +: semico +s/\[\([^];]*\)\]/_{_\1_}_/g +s/"\([^;"]*\);\([^;"]*\)"/"\1#\2"/g +'"#change quotes +s/';'/'#'/g +"'# change quotes +t semico +# Remaining [ ] must contain semicolons which we change to comas. +: lcomp +s/\(\[[^;]*\);/\1,/g +s/;\([^;]*\]\)/,\1/g +t lcomp +# Restore [] and other semicolons +s/_{_/[/g +s/_}_/]/g +s/#/;/g +# Miranda dollar turns a function into an infix operator +s/\$\([_A-Za-z0-9'\'']\{1,\}\)/`\1`/g +' $1 >> $tmp + +# Create a sed script to change the first letter of each type name to +# upper case. +# Dummy definitions for predefined types (num is special). +( + echo ::type char = + echo ::type bool = + echo ::type sys_message = + cat $tmp +) | \ +# Find type definitions & extract type names +sed -n '/::data[ ].*=/{ +h;s/::data[ ]*\([^ =]\).*/\1/p +y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p +g;s/::data[ ]*[^ =]\([^ =]*\).*=.*/\1/p +} +/::type[ ].*=/{ +h;s/::type[ ]*\([^ =]\).*/\1/p +y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/;p +g;s/::type[ ]*[^ =]\([^ =]*\).*=.*/\1/p +}' | \ +# Read lower case initial, upper case inital and rest of type name. +# Type is always after "::". +( +echo ": loop" +while read h; read H; read t +do echo "/::/s/\<$h$t\>/$H$t/g" +done +cat << "++++" +# num -> Int +/::/s/\/Int/g +# Loop round to catch type,type,.. +t loop +# Remove the dummy :: flags from type definitions. +s/::type/type/ +s/::data/data/ +# Comment out string type if defined. +s/\(type[ ]*String[ ]*=\)/-- \1/ +++++ +) > $script + +if [ "$out" ] +then exec > $out +fi +sed -f $script $tmp +rm -f ${tmp}* diff --git a/ghc/CONTRIB/pphs/Jmakefile b/ghc/CONTRIB/pphs/Jmakefile new file mode 100644 index 0000000..24d546c --- /dev/null +++ b/ghc/CONTRIB/pphs/Jmakefile @@ -0,0 +1,16 @@ +SuffixRule_c_o() + +BuildPgmFromOneCFile(pphs) + +InstallBinaryTarget(pphs,$(INSTBINDIR_GHC)) + +/* These .dvi-ish rules are not right, but so what? [WDP 94/09] */ + +docs/UserGuide.dvi: docs/UserGuide.tex + $(RM) $@ + (cd docs && ../$(LTX) UserGuide.tex) + +/* Student project final report */ +docs/Report.dvi: docs/Report.tex + $(RM) $@ + (cd docs && ../$(LTX) Report.tex) diff --git a/ghc/CONTRIB/pphs/README b/ghc/CONTRIB/pphs/README new file mode 100644 index 0000000..a99d81e --- /dev/null +++ b/ghc/CONTRIB/pphs/README @@ -0,0 +1,18 @@ +"pphs" is a Haskell code pretty-printer, written by Andrew Preece as a +senior honours project at Glasgow. + +== original README ======================================== + +* * RELEASE directory * * + +To find out how to use pphs read the User Guide by +typing xdvi User_Guide + +If you put the output of pphs into a file called Haskell.tex +then you can use Wrapper.tex to produce a ``stand alone'' +dvi file of your program. Just run latex on Wrapper.tex +by typing latex Wrapper then view with xdvi Wrapper + +* * MAINTENANCE directory * * + +Code for pphs program, LaTeX file, report, Makefile, etc. diff --git a/ghc/CONTRIB/pphs/docs/Code.tex b/ghc/CONTRIB/pphs/docs/Code.tex new file mode 100644 index 0000000..5437457 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Code.tex @@ -0,0 +1,53 @@ +\chapter{Project code} + +\section{The program code - {\tt pphs.c}} \label{prog-code} + +\newpage % 8 pages of code a2ps (21.4.94) +\setcounter{page}{50} + +\section{The style file - {\tt pphs.sty}} \label{style-code} + +\begin{verbatim} +% ========================================= +% Definitions for use with the pphs program +% ========================================= + +\typeout{For use with the pphs program} + +% Definitions of commands used by pphs + +\newbox\foo +\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo} +\def\plusplus{\hbox{$+\mkern-7.5mu+$}} +\def\xspa#1{\hskip#1ex} +\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}} + +% User-redefinable commands - typefaces + +\def\keyword{\bf} +\def\iden{\it} +\def\stri{\rm} +\def\com{\rm} +\def\numb{\rm} + +% User-redefinable commands - quote marks + +\def\forquo{\hbox{\rm '}} +\def\escquo{\hbox{\rm '}} +\end{verbatim} + +\section{The make file - {\tt Makefile}} \label{make-code} + +\begin{verbatim} +# Makefile for A Preece's program... etc. + +default: + @echo "Type make pphs to create the program." + +pphs: pphs.c + cc -o pphs pphs.c + +test: pphs + pphs test + latex test.tex +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Error_Messages.tex b/ghc/CONTRIB/pphs/docs/Error_Messages.tex new file mode 100644 index 0000000..e53c960 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Error_Messages.tex @@ -0,0 +1,36 @@ +\chapter{Error messages given} + +The {\tt pphs} program generates error messages to {\tt stderr}, +with error codes. Normal operation of the program will be +indicated by error code {\tt 0}. + +\section{\tt Call with one file name} + +Error code {\tt 1} is produced when {\tt pphs} is not called with +exactly one filename. Either no filename was given, or too many +filenames were given. Call {\tt pphs} again with one filename. + +\section{\tt File could not be opened} + +Error code {\tt 2} is produced when the filename given when {\tt pphs} +was called could not be opened. This could be because it did not exist, +or was read-protected. Call {\tt pphs} again with a filename that exists +and is readable. + +\section{\tt Stack is too big} + +Error code {\tt 3} is produced when the program has used up too much of +the computer's memory. It is not possible to run {\tt pphs} on this file +without getting more memory for the computer to use. + +\section{\tt Queue is too big} + +Error code {\tt 4} is produced when the program has used up too much of +the computer's memory. It is not possible to run {\tt pphs} on this file +without getting more memory for the computer to use. + +\section{\tt Stack underflow} + +Error code {\tt 5} is produced when the program attempts to remove an item +from a stack in memory that doesn't exist. This should not happen in the +{\tt pphs} program. diff --git a/ghc/CONTRIB/pphs/docs/External_Specification.tex b/ghc/CONTRIB/pphs/docs/External_Specification.tex new file mode 100644 index 0000000..4190680 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/External_Specification.tex @@ -0,0 +1,117 @@ +\section{External specification} + +The program is to be run in UNIX by typing {\tt pphs} followed by the +filename containing the Haskell code requiring to be typeset. This will +produce the \LaTeX\ code to stdout. If there is some error, +a suitable error message is to be printed to stderr. The user may, if +desired, direct the output to another file by typing {\tt pphs infilename > outfilename}. +In this case, any error messages must still go to the screen and not the file. + +The input filename may be given in its entirety or the {\tt .hs} extension may be omitted. +In the case where there are two files with the same name, except that one has the +{\tt .hs} extension, to run the program on the file with the extension to its name +the complete filename will be typed. + +The output will consist of the \LaTeX\ code to produce the typeset Haskell +code. As this is to be made easily insertable into another \LaTeX\ document, the output +will not contain any header information such as declarations or definitions. These, +however, can +be contained in a style file which the user will include in their main document. + +Keywords and identifiers are to be distinguished in the result as typeset. +The default for keywords is to be boldface and for identifiers italics. +Numbers not forming part of an identifier are to be in roman by default +while math is to be used where appropriate. + +Haskell uses ASCII characters and combinations of ASCII characters +to substitute for mathematical characters not present on the +keyboard. Where this happens, the program is to replace the ASCII character(s) +with the corresponding mathematical character using the special \LaTeX\ commands +to generate them. The single characters are: +\begin{quote} +\begin{tabular}[t]{@{}cc@{}} +Haskell & Math\\ +{\tt *} & $\times$ +\end{tabular} +\end{quote} +The double characters are: +\begin{quote} +\begin{tabular}[t]{@{}cc@{}} +Haskell & Math\\ +{\tt ++} & {\hbox{$+\mkern-7.5mu+$}}\\ +{\tt :+} & {:}{+}\\ +{\tt <=} & $\leq$\\ +{\tt >=} & $\geq$\\ +{\tt <-} & $\leftarrow$\\ +{\tt ->} & $\rightarrow$\\ +{\tt =>} & $\Rightarrow$ +\end{tabular} +\end{quote} + +The \LaTeX\ system uses special characters to aid with the typesetting. +They are: +\begin{quote} +\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) +\end{quote} +These characters may +appear in the input, so the program must generate the correct \LaTeX\ code to +print them and +avoid having them mess up the typesetting process. + +As the output when typeset must have the same layout as the input, the program +must get the linebreaks and indentation right. As \LaTeX\ is primarily designed for normal +text, it would ignore the linebreaks and indentation in the Haskell file. Therefore +the program must insert them using the correct typesetting commands. In the case of +linebreaks it must recognise where these occur, but for indentation it must also work out +how much space needs to be inserted. + +There are two types of indentation in Haskell programs: left-hand and internal. +For the former, the program must work out what the start of the line is aligned +under in the input file. It then has to calculate how much space is required +to get the line of text to line up with this in the output once typeset. +Take, for instance, the following Haskell example input: +\begin{quote} +\begin{verbatim} +foobar a b = c + where + c = (a, b) +\end{verbatim} +\end{quote} +Notice that the {\tt w} of {\tt where} on the second line lines up +under the {\tt =} on +the first line. Similarly, the {\tt c} on the third line is aligned under the +final letter of {\tt where} on the second line. The result as typeset must +get the indentation correct like this: +\begin{quote} +\begin{tabbing} +foobar a b = c\\ +\newbox\foo +{\setbox\foo\hbox{foobar a b }\hskip\wd\foo}where\\ +{\setbox\foo\hbox{foobar a b wher}\hskip\wd\foo}c = (a, b) +\end{tabbing} +\end{quote} + +For internal indentation, the program must first recognise where it has +occurred. It must then insert the correct amount of space to get alignment +in the output. As \LaTeX\ uses variable-width characters, extra space +may be needed in lines preceding a line within an internal alignment section. +This is necessary if a lower line which +aligns in the input file is longer up to the alignment point, +due to the variable-width characters, than its predecessors +once it has been properly typeset. For example: +\begin{quote} +\begin{verbatim} +lilli :: a +wmwm :: b +\end{verbatim} +\end{quote} +becomes +\begin{quote} +\begin{tabular}[t]{@{}l@{\ }c@{\ }l} +lilli & :: & a\\ +wmwm & :: & b\\ +\end{tabular} +\end{quote} +Notice how {\tt lilli} is longer than {\tt wmwm} in the input file style +using fixed-width font but shorter when using the variable-width font +of the typeset output. diff --git a/ghc/CONTRIB/pphs/docs/Faults.tex b/ghc/CONTRIB/pphs/docs/Faults.tex new file mode 100644 index 0000000..1c38984 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Faults.tex @@ -0,0 +1,66 @@ +\chapter{Things that don't work} \label{faults} + +The {\tt pphs} program has some deficiencies that cause it to not always produce the +correct code. These are detailed in this chapter. + +\section{Internal alignment} + +The program can deal only with simple internal alignment. It cannot deal with a +situation where there is more than one column where internal alignment is occurring +on the same line. This can occur when two sections of internal +alignment overlap by having lines in common or where one section is wholly within another. +When this happens, {\tt pphs} will only +line up one occurrence of internal alignment on each line. + +Related is left alignment under a section of internal alignment. Take this earlier example. +\begin{quote} +\input{Haskell_leftindent1} +\end{quote} +This is how this code is typeset by {\tt pphs}: +\begin{quote} +\input{LaTeX_leftindent1} +\end{quote} +Notice how the {\bf where} on the third line doesn't line up under the {\it gcd\/}$'$ on +the second. The reason for this +is the \LaTeX\ {\tt tabular} section does not respect any spaces that occur at the end +of the right hand edge of the left hand column such as those after +{\tt gcd x y} and instead moves the central column left +so it is only one space away from the longest piece of text in the left hand column, +in this case {\iden gcd\/}\xspa1 {\iden x\/}\xspa1 {\iden y\/}. +The left indentation of the lines under the internal alignment section does not take this +movement into account and so if a line is indented beyond the end of the text in the first +column of the last line of the internal alignment section then it may be incorrectly +positioned and therefore will not align with what it was aligned with in the original +program. Should a piece of text in the left hand column be longer once typeset than what was +previously the longest, due to the variable-width characters used by \LaTeX , +then the second and third columns will get moved to the right, and so, similarly, +any code indented under the other columns will be wrongly positioned. + +Where a section of internal alignment coincides with the bottom of the user's page, +it can run off the bottom of the page. This is because the {\tt tabular} environment +used for internal alignment sections does not allow pagebreaks. Therefore the pagebreak +will come after the section has been completed. + +\section{Mathematical symbols} + +Mathematical symbols are always written in math font. This means that where, say, +comments are re-defined to be in typewriter font, as in the following +example, any mathematical symbols in the comments +will appear in math font, rather than typewriter font. +\begin{quote} +\def\com{\tt} +\input{LaTeX_comment} +\end{quote} + +\section{Left indentation} + +Where a line is indented beyond the end of its predecessor and aligns under another +line, but when typeset, the predecessor becomes longer than the indentation level +due to the variable-width characters, the line's indentation will appear to be under the +predecessor line. + +\section{Floating point numbers} + +Currently {\tt pphs} will recognise strings such as {\tt 3.} or {\tt 5.6e} as +valid floating point numbers. This needs rectifying so only valid floating +point numbers are recognised. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Future_Work.tex b/ghc/CONTRIB/pphs/docs/Future_Work.tex new file mode 100644 index 0000000..4bf7b89 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Future_Work.tex @@ -0,0 +1,30 @@ +\chapter{Things remaining to be implemented} + +Due to pressure of time, not everything that was planned to be included in +{\tt pphs} was implemented. This chapter details these things. + +\section{Faults} + +The faults detailed in Chapter~\ref{faults} remain to be rectified. The fault +regarding multiple columns of internal alignment would, it seems, require a +major rethink on the way internal alignment is handled by {\tt pphs}, perhaps +using the {\tt tabbing} environment with tabs and tabstops, rather than the +{\tt tabular} environment as at present. This could also +be extended to left indentation to solve the problem with indentation under +internal alignment section. Elimination of the {\tt tabular} sections would solve +the problem of pagebreaks during internal alignment sections. + +\section{Parsing} + +Currently, {\tt pphs} only does limited parsing. This could be altered to +give a full parse by restructuring into Lex. This would be better because +it would allow sections of code to be classified more easily once they were +broken down. + +\section{Literate Haskell} + +It has been suggested that {\tt pphs} be extended to accept Literate Haskell +files as input. This is where the program code lines all start with {\tt >} +and plain text is written between sections of code to document the file. +This would be called by an additional option, say {\tt -l}, and would typeset +the sections of Haskell code, whilst leaving the text sections alone. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_char.tex b/ghc/CONTRIB/pphs/docs/Haskell_char.tex new file mode 100644 index 0000000..265b063 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_char.tex @@ -0,0 +1,7 @@ +\begin{verbatim} +-- Character functions + +minChar, maxChar :: Char +minChar = '\0' +maxChar = '\255' +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex b/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex new file mode 100644 index 0000000..b4942bb --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_internalalign1.tex @@ -0,0 +1,12 @@ +% From Haskell report PreludeComlex.hs +\begin{verbatim} +instance (RealFloat a) => Num (Complex a) where + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex b/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex new file mode 100644 index 0000000..80d17b6 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_internalalign2.tex @@ -0,0 +1,4 @@ +\begin{verbatim} +fst :: (a,b) -> a +fst (x,_) = x +\end{verbatim} diff --git a/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex b/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex new file mode 100644 index 0000000..aac11d8 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_leftindent1.tex @@ -0,0 +1,7 @@ +\begin{verbatim} +gcd :: Int -> Int -> Int +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) +\end{verbatim} + diff --git a/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex b/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex new file mode 100644 index 0000000..09533c8 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_leftindent2.tex @@ -0,0 +1,9 @@ +% From cvh/Public/GBC/Source/Gm7.hs +\begin{verbatim} +eval :: GmState -> [GmState] +eval state = state: restStates + where + restStates | gmFinal state = [] + | otherwise = eval nextState + nextState = doAdmin (step state) +\end{verbatim} diff --git a/ghc/CONTRIB/pphs/docs/Haskell_math.tex b/ghc/CONTRIB/pphs/docs/Haskell_math.tex new file mode 100644 index 0000000..2e67e31 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_math.tex @@ -0,0 +1,5 @@ +\begin{verbatim} +-- list concatenation (right-associative) +(++) :: [a] -> [a] -> [a] +xs ++ ys = foldr (:) ys xs +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_simple.tex b/ghc/CONTRIB/pphs/docs/Haskell_simple.tex new file mode 100644 index 0000000..4ca2bb5 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_simple.tex @@ -0,0 +1,5 @@ +\begin{verbatim} +foobar a b = c + where + c = a + b +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_string1.tex b/ghc/CONTRIB/pphs/docs/Haskell_string1.tex new file mode 100644 index 0000000..0284da1 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_string1.tex @@ -0,0 +1,8 @@ +\begin{verbatim} +-- File and channel names: + +stdin = "stdin" +stdout = "stdout" +stderr = "stderr" +stdecho = "stdecho" +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex b/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex new file mode 100644 index 0000000..a8518c3 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Haskell_typewriter.tex @@ -0,0 +1,7 @@ +\begin{verbatim} +Horrible typewriter font + where + everything is the same + fixed width characters + no highlighting +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/How.tex b/ghc/CONTRIB/pphs/docs/How.tex new file mode 100644 index 0000000..1012013 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/How.tex @@ -0,0 +1,465 @@ +\chapter{How it does it} + +This chapter explains in detail how the program {\tt pphs} was implemented +from a programmer's viewpoint. It was implemented in the C programming +language, as this is a commonly used language often used for writing UNIX tools. +The program code is shown in Appendix~\ref{prog-code} and the makefile in +Appendix~\ref{make-code}. + +\section{General sequence of events} + +When the {\tt pphs} program is run, the program first finds out what, if any, +options it has been called with. If any have been specified, the appropriate +variables are set. The program then checks it has been called with exactly one +further argument. If not, the program terminates with an +explanatory error message. If called correctly, the program then checks that the +supplied argument is the name of a file that exists and is readable. +The program is normally used +on files ending with a {\tt .hs} extension. When called with a filename +with no extension and that file is not found, then it appends the extension and searches +for that file. If no file with that name is found or the file is unreadable, an +error message is produced and the program terminates. If the file is found, the +program starts the typesetting process by writing out the opening +\LaTeX\ command to {\tt stdout}. +This defines the \LaTeX\ environment which the program exploits to do the typesetting. +It then initialises the variables used in the program. + +This done, the first character is read. The program enters a loop and keeps +reading characters until the end of the file is reached. As each character is read +in, its typeface is established and it is stored with its typeface in something +called the {\em line store\/}. If any left indentation is +encountered, the correct characters to be skipped are identified from the {\em left +indentation stack} and copied into the line store. Internal alignment is checked +for and if any is found, appropriate variables are set accordingly. Each stored line is +added to both the left indentation stack and the {\em writing queue}. When the value of the +internal alignment changes, or it has been established that the first line in the writing +queue is not part of any internal alignment section, the lines in the queue are written out. + +Once all the lines are written out, {\tt pphs} then writes the closing \LaTeX\ command +and terminates. + +\section{Basic storage unit for a line of code} \label{line-store} + +The basic storage unit used in {\tt pphs} is the line store unit. +This stores the details of one line of Haskell code. These are +the characters on the line, the typeface associated with each +character, the length of the line, the indentation level and the position of +any internal alignment in the line. + +In the C program, {\tt ElementType} is the structure used for this type. This has +five parts: +\begin{itemize} +\item {\tt chars} which stores the characters used on the line of Haskell +code + +\item {\tt typeface} which stores the typeface values associated with the +characters on that line + +\item {\tt indentation} which stores the level of the line's indentation + +\item {\tt length} which stores the length of the line + +\item {\tt col} which stores the column where any internal alignment occurs or +is set to {\tt 0} if there is none +\end{itemize} +The variable {\tt store} in the main program is of type {\tt ElementType} and +is used as the basic storage unit for the current line. Its C declaration is +\begin{quote} +\begin{verbatim} +typedef struct ElementType_Tag { + char chars[MAXLINELENGTH]; + enum face typeface[MAXLINELENGTH]; + int indentation, length, col; +} ElementType; +\end{verbatim} +\end{quote} + +\section{Stack of lines for left indentation} + +Due to \LaTeX 's variable width characters, {\tt pphs} cannot simply uses spaces +for the left indentation as in the input Haskell file. It has to work out how far +each line is indented by finding out what it is indented under. As each line is +completed, it is added to a stack of lines, each line being stored in a basic +storage unit. If the line at the top of the stack is of a greater or equal +indentation level and of a lesser or equal length, then it is no +longer required for calculating typeset indentation +and can be disposed of. Once all lines of greater indentation level have been removed +from the top of the stack, the current line can then be added. + +When a line's indentation level, in terms of the number of spaces used in the +input, has been determined, {\tt pphs} has to find +out the characters that determine the actual typeset length of the indentation. To get this, +{\tt pphs} looks down the stack until it comes to a line whose indentation is less than +that of the current line and whose length is greater than the indentation level of the +current line. Once a suitable line is found, its characters and typefaces are copied +into the line store of the current line; then the rest of the current line is read in, +overwriting the characters beyond the indentation level. If there is no line preceding +the current one that is as long as the indentation level of the current line, spaces +are placed in the line store instead. + +A special case has been made for left indentation. Most of the time, the left-hand edge +of the characters will be aligned, but where a {\tt |} is aligned under an {\tt =} sign, it is +centered under the sign. This will be the case for any further {\tt |} symbols aligned +under this {\tt =} sign. + +The type {\tt StackType} is used in the program for the stack. This makes a stack of +the basic line storage units of {\tt ElementType}, together with a set of functions available +for use with stacks. These are {\tt CreateStack}, which returns an empty stack; +{\tt IsEmptyStack}, which returns {\tt 1} if the stack which it is called with is empty, +{\tt 0} otherwise; {\tt Push}, which takes a stack and an element and returns the stack +with the element pushed onto the top; {\tt Top}, which takes a stack and returns the top +element of the stack; {\tt Pop}, which takes a stack and returns it with the top element +removed; and {\tt PopSym}, which is the same as {\tt Pop} except that it does not free the +memory used by the top element - this function was found necessary to fix a fault caused by +returning to a stack's previous state, having popped off elements in the interim period. + +\section{Internal alignment identification} + +Internal alignment is deemed to have occurred when a character matches the one +immediately above it, the preceding characters in both lines are spaces, and there is +more than one space preceding the character on at least one of the lines. + +To check for this in {\tt pphs}, the current position on the line, indicated by +the linecounter, must be greater than one because either the current line or +the previous line will be required to have two spaces before the current position. The current +line will be located in the line store and the previous line will be at the rear of the queue +of lines waiting to be written out. + +One special case has been implemented for internal alignment. This is to allow Haskell +type declarations, such as in the example below, to align with their corresponding function +definitions. +\begin{quote} +\input{Haskell_internalalign2} +\end{quote} +The {\tt =} sign can be under either the first or second {\tt :} symbol for the +internal alignment to be recognised. + +\section{Typefaces and mathematical characters} + +Each character has a typeface value associated with it. Normally, this will +indicate the type of token the character is part of, either keyword, identifier, +string, comment, number or maths symbol, but where Haskell uses an ASCII character +simulation of a mathematical character or some other special symbol, the typeface +value will indicate this as well. + +In the program, the typeface values are of the +enumerated type called {\tt face}, which has the values shown in Table~\ref{tf-val}. +They are used in the basic storage unit {\tt ElementType} in the {\tt typeface} part. + +\begin{table} +\begin{center} +\begin{tabular}{|c|l|} \hline +{\em value\/} & {\em indicates\/} \\ \hline +{\tt KW} & keyword \\ +{\tt ID} & identifier \\ +{\tt IE} & exponent identifier \\ +{\tt ST} & string \\ +{\tt SE} & exponent string \\ +{\tt CO} & comment \\ +{\tt CE} & exponent comment \\ +{\tt NU} & number \\ +{\tt NE} & exponent number \\ +{\tt MA} & maths \\ +{\tt SP} & space \\ +{\tt LC} & line comment \\ +{\tt RC} & regional comment begin \\ +{\tt CR} & regional comment end \\ +{\tt BF} & backwards/forwards quote \\ +{\tt FQ} & forwards quote \\ +{\tt EQ} & escape quote \\ +{\tt DQ} & double quote begin \\ +{\tt QD} & double quote end \\ +{\tt EE} & escape double quote \\ +{\tt DC} & second part of double character \\ +{\tt DP} & double plus \\ +{\tt CP} & colon plus \\ +{\tt LE} & less than or equal to \\ +{\tt GE} & greater than or equal to \\ +{\tt LA} & left arrow \\ +{\tt RA} & right arrow \\ +{\tt RR} & double right arrow \\ +{\tt TI} & times \\ +{\tt EX} & double exponent character \\ +{\tt XP} & exponent \\ +{\tt BE} & bar aligned under equals \\ \hline +\end{tabular} +\end{center} +\caption{Typeface values} \label{tf-val} +\end{table} + +\subsection{Current character and retrospective update} + +The {\tt pphs} program has to determine the typeface of a character without knowledge of the +characters to follow. Therefore it allocates the value depending on the status +of various boolean variables. This may subsequently be found to be wrong once the remaining +characters of that token have been read. + +In the case of keywords and double characters, these are only identifiable +as such once all the characters of the token have been read in. Having established +the existence of a keyword or double character, {\tt pphs} then goes back and changes +the typeface values for the appropriate characters. + +The functions {\tt CheckForDoubleChar} and {\tt CheckForKeyword} perform this in the +program. + +\section{Writing lines out} + +Lines are written to {\tt stdout}, but not immediately on being read in. Instead they +are held back while it is established whether or not they form part of a section of +internal alignment. + +Before any typeset Haskell code is written, {\tt pphs} writes an opening \LaTeX\ command +{\tt \char'134 begin\char'173 tabbing\char'175 } to {\tt stdout}. This defines the +\LaTeX\ environment that the typeset code will be written in. At the end, +{\tt \char'134 end\char'173 tabbing\char'175 } is written to terminate this +environment. + +\subsection{The line queue} + +Lines are stored in a queue while they are waiting to be written out. +The elements of the queue are the basic line storage units described in +Section~\ref{line-store}. + +In the program, the queue is of type {\tt QueueType} +and a set of functions related to queues is available. This set consists of +{\tt CreateQueue}, which returns an empty queue; {\tt IsEmptyQueue}, which takes +a queue and returns {\tt 1} if the queue is empty, {\tt 0} otherwise; {\tt LengthOfQueue}, +which takes a queue and returns its length; {\tt FrontOfQueue}, which takes a queue and +returns a pointer to its front element; {\tt RearOfQueue}, which takes a queue and returns +a pointer to its rear element; {\tt AddToQueue}, which takes a queue and an element and +returns the queue with the element added to the rear; {\tt TakeFromQueue}, which takes +a queue and returns the queue with the front element removed. + +The last line in the queue is inspected to search +for internal alignment; if any is found, the internal alignment variable of that +line is altered accordingly. + +\subsection{When lines are written} + +The queue is written out by the function {\tt WriteQueue} when a section of internal +alignment is commenced or terminated +or when it has been established that there is no internal alignment involving the first line +in the queue. If the section being written out has been found to have +no internal alignment, then the last line is retained +in the queue because it may form part of the next section of internal alignment. + +At the end of the input, {\tt WriteRestOfQueue} writes all the lines remaining in the queue. +This is because the last line of Haskell code will not form part of any further section of +internal alignment and can therefore be written out. Facilities +are provided in the function {\tt WriteLine} to avoid writing the last newline +character at the end of the Haskell +file, as this would create an unwanted blank line in the final document. + +\subsection{Writing a line} + +The function {\tt WriteLine} is used in {\tt pphs} to write out one line. This is +called from either {\tt WriteQueue} or {\tt WriteRestOfQueue} and is supplied with +a basic line storage unit containing the line needing to be written out together with a +flag stating whether or not a \LaTeX\ newline character is required. + +If a line has any left indentation, this is written out first by calling the function +{\tt WriteSkipover}. The rest of the line is then written out by {\tt WriteWords} +followed if necessary by the newline character. Both these functions are given +the current line in the line store. + +\subsection{Writing left indentation} + +As \LaTeX\ uses variable width characters, fixed width spaces cannot be used for the +left indentation. Instead, the width of the characters above the current line needs +to be skipped. The {\tt \char'134 skipover} command, defined in the {\tt pphs.sty} +style file (see Section~\ref{style-file}), is used by the function {\tt WriteSkipover} +to get \LaTeX\ to do this. The command is supplied with the typefaces and characters +in the lines above, and, with this, \LaTeX\ creates the correct amount of +indentation in the typeset result. The typefaces and characters are written in +braces as the argument to {\tt \char'134 skipover} by calling {\tt WriteStartFace}, +{\tt WriteChar}, {\tt WriteSpaces} and {\tt WriteFinishFace}. The typeface functions +are called with the typeface value whereas the other two are given the line store, +current position and where the end of the skipover section is. + +Using this specially defined {\tt \char'134 skipover} command avoids having to get +information back from \LaTeX , therefore keeping the information flow unidirectional. + +\subsection{Writing the rest of a line} + +The function {\tt WriteWords} writes out the indented line once any left indentation +has been dealt with. Starting at the indentation level of the line, it uses the functions +{\tt WriteStartFace}, {\tt WriteChar}, {\tt WriteSpaces} and {\tt WriteFinishFace} to +write out each character and its typeface. The typeface functions are called with +the typeface value whereas the other two are given the line store, current position +and where the end of the line is. + +\subsection{Writing \LaTeX\ typeface commands} + +Every character has a typeface associated with it, so at the start and finish of every +line and every time the current typeface changes, typeface commands have to be written +out. This is done by the functions {\tt WriteStartFace} and {\tt WriteFinishFace}. +They write the appropriate \LaTeX\ typeface commands according to the typeface values +given as shown in Table~\ref{tf-comms}. To avoid complications, double characters have +their typefaces written out as part of the character command, therefore they need no +further typeface commands. Similarly, the user-redefinable quote mark characters +have their typeface defined in their definitions, so do not need any more typeface +commands. + +\begin{table} +\begin{center} +\begin{tabular}{|c|l|l|} \hline % ``commands'' to be over two columns +{\em value\/} & \multicolumn{2}{c|}{\em commands\/} \\ \cline{2-3} + & {\em begin\/} & {\em end\/} \\ \hline +{\tt KW} & {\tt \char'173 \char'134 keyword} & {\tt \char'134 /\char'175 }\\ +{\tt ID} & {\tt \char'173 \char'134 iden} & {\tt \char'134 /\char'175 }\\ +{\tt IE} & {\tt \char'173 \char'134 iden} & {\tt \char'134 /\char'175 \$ }\\ +{\tt ST} & {\tt \char'173 \char'134 stri} & {\tt \char'134 /\char'175 }\\ +{\tt SE} & {\tt \char'173 \char'134 stri} & {\tt \char'134 /\char'175 \$ }\\ +{\tt CO} & {\tt \char'173 \char'134 com} & {\tt \char'134 /\char'175 }\\ +{\tt CE} & {\tt \char'173 \char'134 com} & {\tt \char'134 /\char'175 \$ }\\ +{\tt NU} & {\tt \char'173 \char'134 numb} & {\tt \char'134 /\char'175 }\\ +{\tt NE} & {\tt \char'173 \char'134 numb} & {\tt \char'134 /\char'175 \$ }\\ +{\tt MA} & {\tt \$ } & {\tt \$ }\\ +{\tt SP} & & \\ +{\tt LC} & & \\ +{\tt RC} & & \\ +{\tt CR} & & \\ +{\tt BF} & & \\ +{\tt FQ} & & \\ \hline +\end{tabular} \hskip3mm \begin{tabular}{|c|l|l|} \hline +{\em value\/} & \multicolumn{2}{c|}{\em commands\/} \\ \cline{2-3} + & {\em begin\/} & {\em end\/} \\ \hline +{\tt EQ} & & \\ +{\tt DQ} & & \\ +{\tt QD} & & \\ +{\tt EE} & & \\ +{\tt DC} & & \\ +{\tt DP} & & \\ +{\tt CP} & & \\ +{\tt LE} & & \\ +{\tt GE} & & \\ +{\tt LA} & & \\ +{\tt RA} & & \\ +{\tt RR} & & \\ +{\tt TI} & {\tt \$ } & {\tt \$ } \\ +{\tt EX} & {\tt \$ } & \\ +{\tt XP} & {\tt \$ } & \\ +{\tt BE} & & \\ \hline +\end{tabular} +\end{center} +\caption{Typeface values and related \LaTeX\ commands} \label{tf-comms} +\end{table} + +\subsection{Writing characters} + +{\tt WriteChar} is the function which handles writing characters. It takes the line store, +the current position on the line and the end of the current section - either the skipover +section or the writing section - and returns the current position on the line which will +have been incremented if a double character has been written. If the first character of +a double character is the last character of a skipover section, it will not be written +so the indentation for that line will fall instead, below the start of the double +character in a line above. Most characters are written out as they were inputted, +but many require special \LaTeX\ code. + +As \LaTeX\ uses embedded typesetting commands, some characters are reserved for this +purpose. Should any of these characters appear in the input Haskell code, {\tt pphs} +has to produce the appropriate \LaTeX\ code to avoid these characters upsetting the typesetting +process. The characters and the replacement \LaTeX\ code are shown in Table~\ref{rep-chars}. +\begin{table} +\begin{center} +\begin{tabular}{|c|l|} \hline +{\em input\/} & {\em \LaTeX\ code output } \\ \hline +{\tt \#} & {\tt \char'134 \#} \\ +{\tt \$} & {\tt \char'134 \$} \\ +{\tt \%} & {\tt \char'134 \%} \\ +{\tt \&} & {\tt \char'134 \&} \\ +{\tt \char'176 } & {\tt \char'134 char'176 } \\ +{\tt \_} & {\tt \char'134 \_} \\ +{\tt \char'134} & {\tt \char'134 hbox\char'173 \$setminus\$\char'175 } \\ +{\tt \char'173} & {\tt \char'134 hbox\char'173 \$\char'134 cal \char'134 char'146 \$\char'175 } \\ +{\tt \char'175} & {\tt \char'134 hbox\char'173 \$\char'134 cal \char'134 char'147 \$\char'175 } \\ +{\tt *} & {\tt \char'134 times}\\ \hline +\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline +{\em input\/} & {\em \LaTeX\ code output } \\ \hline +{\tt ++} & {\tt \char'134 plusplus}\\ +{\tt :+} & {\tt \char'173 :\char'175 \char'173 +\char'175}\\ +{\tt <=} & {\tt \$\char'134 leq\$}\\ +{\tt >=} & {\tt \$\char'134 geq\$}\\ +{\tt <-} & {\tt \$\char'134 leftarrow\$}\\ +{\tt ->} & {\tt \$\char'134 rightarrow\$}\\ +{\tt =>} & {\tt \$\char'134 Rightarrow\$}\\ +{\tt \char'173 -} & {\tt \char'173 \char'134 com \char'134 \char'173 -\char'134 /\char'175 }\\ +{\tt -\char'175 } & {\tt \char'173 \char'134 com -\char'134 \char'175 \char'134 /\char'175 }\\ +{\tt --} & {\tt \char'173 \char'134 rm -\char'175 \char'173 \char'134 rm -\char'175 }\\ \hline +\end{tabular} +\end{center} +\caption{Haskell input and replacement \LaTeX\ code} \label{rep-chars} +\end{table} + +When a mathematical character needs written, {\tt WriteChar} outputs the \LaTeX\ code for +the character rather than the Haskell ASCII character simulation. Some of these +simulations use more than one character, so this could cause problems if some left +indentation is aligned under the second character of such a simulation. It has been +decided that in this case, the output from {\tt pphs} will cause the indented line +to align under the start of the double character rather than the centre or end of it. +The Haskell ASCII simulations and the \LaTeX\ codes that replaces them are shown in +Table~\ref{rep-chars}. The non-standard command {\tt \char'134 plusplus} is defined +in the {\tt pphs.sty} style file (see Section~\ref{style-file}). + +When a {\tt |} symbol is aligned under an {\tt =} sign at the left indentation, +{\tt \char'134 bareq} is output. This command is defined in the {\tt pphs.sty} +style file explained in Section~\ref{style-file} and causes \LaTeX\ to write the bar symbol +centrally in the space it would have taken to write an equals sign, thereby causing +the bar to be positioned centrally under the equals sign it is aligned under and the text +following the bar to align with that after the equals sign. + +For writing spaces, {\tt WriteSpaces}, called with the line store, current position and the +position of the end of the current section, first counts the number of consecutive spaces +to be written before writing out a {\tt \char'134 xspa} command with an argument of +the number of spaces needed. This makes the output code easier to read. The +{\tt \char'134 xspa} command is defined in the {\tt pphs.sty} style file explained +in Section~\ref{style-file}. Any tab characters are treated as spaces by {\tt pphs} +with the number of spaces they represent being calculated from the current position +on the line and the {\tt tablength} variable, which may have been changed from its +default of 8 by the {\tt -t} option at the program call. + +Numbers are written by {\tt WriteChar}, including floating point numbers. + +As \LaTeX\ provides several different quote marks, it was decided that the user +should be able to choose a preferred symbol. An input quote mark {\tt '} can +either be a prime or a quote mark in the output. This requires the program to +determine which it is. In program code this is fine, but in comments or strings +the marks won't necessarily be used in a manner from which it can easily be +determined which symbol is required. In program code, an input {\tt '} is deemed +to be a quote mark if either it is preceded by punctuation or a quote has +already been opened; otherwise it is a prime. Of the quote marks, these can +either be for actual quotes or an escape quote where a quote mark is being quoted. +Special cases has been implemented when the input file contains a quote within a comment +started with a backquote and ended with a forwards quote, and for \LaTeX\ style +quotes in comments started with two backquotes and ended with two forwards quote +marks. All input {\tt '} in strings, other than escape quotes, are treated +as primes. In strings, an input {\tt '} may be an apostrophe, however, there is +little way of telling this.\label{string-apostrophe} One of five different pieces +of \LaTeX\ code can be produced having received {\tt '} as input. +\begin{itemize} +\item {\tt \char'134 forquo} for a forwards quote mark +\item {\tt \char'134 escquo} for an escape (quoted) quote mark +\item {\tt \char'173 \char'134 com '\char'134 /\char'175 } for a forward quote ending a quote +in a comment opened by a backquote +\item {\tt \char'173 \char'134 com ''\char'134 /\char'175 } for two forward quotes ending a quote +in a comment opened by two backquotes +\item {\tt '} for a prime which will be in the math font +\end{itemize} +The first two are commands defined in the {\tt pphs.sty} style file and are +thus user-redefinable as described in Section~\ref{user-adj}. Backquotes, input +as {\tt `}, are either in the comment typeface for backquotes in comments or in +math font elsewhere. + +\subsection{Writing internal alignment} + +To commence a section of internal alignment, either of the functions {\tt WriteQueue} +or {\tt WriteRestOfQueue} write out +{\tt \char'134 begin\char'173 tabular\char'175 \char'173 @\char'173 \char'175 l@\char'173 \char'134 xspa1\char'175 c@\char'173 \char'175 l\char'175 } +before writing the first line of the section. This provides an environment +with three columns. The first column accommodates the Haskell code to the left of the +internal alignment, the second has the symbols that line up vertically, while the third +has the Haskell code to the right. The Haskell code is written complete with its \LaTeX\ +typesetting commands with the addition of {\tt \&} symbols denoting the breaks between +columns. Once the internal alignment section has been completed, the +{\tt \char'134 end\char'173 tabular\char'175 } command is written to terminate the +environment. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Introduction.tex b/ghc/CONTRIB/pphs/docs/Introduction.tex new file mode 100644 index 0000000..141fb59 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Introduction.tex @@ -0,0 +1,137 @@ +\chapter{Introduction} + +Documents, such as papers for publication, often include sections +of program code. These have to be specially typeset, as default +typesetting modes are generally intended for plain prose. +It is therefore useful to have a special-purpose system for typesetting +programs for inserting into documents. +Haskell \cite{Haskell-report} is a fairly new functional programming language and does not +yet have a full range of tools available to use with the language, +including one to do typesetting. +The goal of this project, therefore, is to provide a tool to automatically +typeset Haskell programs. + +Many people use the \LaTeX\ system \cite{LaTeX-book} +for typesetting. This uses +embedded typesetting commands in the input to arrange the typesetting. +The typeset result has variable-width characters with a choice of +font styles and sizes available. The page-size, margins and layout +are also controllable by the user. Because \LaTeX\ is so widely used and +so flexible, the tool to be created will be +for use with the \LaTeX\ system. + +Haskell programs are generally written with editors that produce ASCII +text. This has fixed-width characters and one plain font. +Indentation and vertical alignment are simple because +fixed-width characters line up in columns, one below the other. +Haskell avoids having compulsory expression terminators +by using such indentation to delimit expressions. It is thus crucial +that this indentation is retained when the text is typeset. + +The \LaTeX\ system, however, uses variable-width characters, so the indentation +level becomes dependent on the characters under which the text is aligned. +The tabs and spaces that went to make +up the indentation in the original file have to be replaced with a +suitable amount of space to make the text line up with the position +it is aligned with in the original file. + +It is also desirable to have formatting improvements, such as +highlighting keywords and identifiers, as well as to have +proper mathematical characters inserted in place of the +Haskell ASCII approximations. A tool could do this as well. + +Currently the only way of typesetting Haskell program code is to +labouriously insert formatting +commands into the text by hand. The alternative is to print out the programs +verbatim with a plain ASCII-style fixed-width font, but it would be far better +if there were a tool to do the proper typesetting. + +\subsection*{Goals} + +The proposed tool is required to comply to the following requirements: +\begin{itemize} +\item The program must take a file with a Haskell program in it and produce +\LaTeX\ code to stdout. This code must produce the input Haskell program in +typeset style when run through +the \LaTeX\ program. The typeset result must be recognisable as having the same +layout as the input file's Haskell program had. + +\item The typeset result must preserve the parse of the program. + +\item The input file will contain only Haskell code. Any documentation in the file +will be in the form of comments. + +\item The input file will not have any embedded typesetting commands, so +the program must analyse the input and decide for itself what needs to be +done to produce the correct \LaTeX\ code. + +\item The \LaTeX\ code produced must be easy to incorporate into a \LaTeX\ +document such as a paper or book. Thus the produced code must be able +to be incorporated into documents of different page and font sizes. + +\item Keywords and identifiers must be highlightable so as to distinguish +them from the rest of the Haskell program. +The user should be allowed some choice in the typeface used for +highlighting. + +\item Proper mathematical symbols must replace ASCII approximations in the +typeset output. + +\item The program must accept as input +a file of any name and thus not use an inflexible built-in filename. + +\item The program must be in keeping with conventional UNIX style to fit in with +Haskell and \LaTeX , which are also run under UNIX. +\end{itemize} + +\noindent This report describes a program written to satisfy these needs. + +\subsection*{Background} + +Haskell, being a functional programming language, uses functions as its +sole means of programming. This is unlike traditional programming +languages such as C or Pascal, where assignments and procedures are also used. +Haskell also does not normally use expression terminators, such as semi-colons, +but instead relies on the layout of the +program and, in particular, the indentation to determine the context of +lines of code. Lines of code are positioned so they are aligned under particular +points on preceding lines, and this delimits expressions. It is thus +imperative that this indentation be replicated in any attempt to pretty-print +the program code. + +\LaTeX\ is a typesetting program that takes a file with embedded typesetting +commands and produces a file containing typeset text. This is commonly used when +writing documents such as papers and books for publication. Users of \LaTeX\ +can do many things, but anything fancy requires lots of typesetting commands to +be embedded into the input file. Thus typesetting a Haskell program in the +desired way is a considerable task. More simply, a +Haskell program can be displayed in \LaTeX's verbatim mode, but this uses a fixed-width +typewriter font. Verbatim mode does not recognise tab characters, however these can be +replaced with spaces. + +It will be assumed that the user is familiar with Haskell and at least familiar with +preparing basic textual documents with \LaTeX, although it is not required for the +user to understand many of the more involved parts of typesetting with \LaTeX. + +Already in existence is a program called `Phinew' written by Phil Wadler. +This can be found in {\tt \char'176 wadler/bin}. This required the user to supply +typesetting commands embedded in their Haskell programs, meaning that the +user would have to manually pre-process their Haskell code before using +Phinew. Although simpler +than typesetting in \LaTeX, it is still better to have a program +to do all the typesetting automatically, taking an unprepared Haskell +program as input. + +\subsection*{Outline} + +In the remaining sections of this report the functionality of the program written +are discussed; in particular, how all the various layout arrangements are dealt with. The way +in which the program goes about working out what to do is explained, +along with descriptions of the algorithm and data-structures used. Examples +of the input and resulting output are used to illustrate the capabilities +of the program. The various possibilities for the user to decide what happens +are explained, along with details on how to exploit them. The user will +need to know how to incorporate the results into a document so this +is also explained. Finally, the limitations and deficiencies of the +program are detailed complete with an outline of further possible work +which could rectify these problems and make the program more complete. diff --git a/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex b/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex new file mode 100644 index 0000000..8110ca4 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX-code_simple.tex @@ -0,0 +1,12 @@ +\begin{verbatim} +\begin{tabbing} +{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/} + \xspa{1}$=$\xspa{1}{\iden c\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1} + {\iden b\/}\xspa{1}}{\keyword where\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1} + {\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/} + \xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1} + {\iden b\/} +\end{tabbing} +\end{verbatim} \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex b/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex new file mode 100644 index 0000000..1c1a67f --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_blankline.tex @@ -0,0 +1,6 @@ +\begin{tabbing} +{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}$=$\xspa{1}{\iden c\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}}{\keyword where\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/}\xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1}{\iden b\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_char.tex b/ghc/CONTRIB/pphs/docs/LaTeX_char.tex new file mode 100644 index 0000000..7b5a7c8 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_char.tex @@ -0,0 +1,9 @@ +\begin{tabbing} +{\rm -}{\rm -}\xspa{1}{\com Character\/}\xspa{1}{\com functions\/}\\ +\\ +\begin{tabular}{@{}l@{\xspa1}c@{}l} +{\iden minChar\/}$,$\xspa{1}{\iden maxChar\/}\xspa{8} & $::$ & \xspa{1}{\iden Char\/}\\ +{\iden minChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 0\/}\forquo \\ +{\iden maxChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 255\/}\forquo +\end{tabular} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex b/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex new file mode 100644 index 0000000..324be0b --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_comment.tex @@ -0,0 +1,3 @@ +\begin{tabbing} +{\rm -}{\rm -}\xspa{1}{\com note\/}\xspa{1}{\com that\/}\xspa{1}{\com x\/}\xspa{1}$+$\xspa{1}{\com y\/}\xspa{1}$=$\xspa{1}{\com z\/} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex new file mode 100644 index 0000000..069691a --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_internalalign1.tex @@ -0,0 +1,13 @@ +\begin{tabbing} +\begin{tabular}{@{}l@{\xspa1}c@{}l} +{\keyword instance\/}\xspa{2}$(${\iden RealFloat\/}\xspa{1}{\iden a\/}$)$\xspa{1} & $\Rightarrow$ & \xspa{1}{\iden Num\/}\xspa{1}$(${\iden Complex\/}\xspa{1}{\iden a\/}$)$\xspa{2}{\keyword where\/}\\ +\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$+$\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$+${\iden x\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden y\/}$+${\iden y\/}$')$\\ +\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$-$\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$-${\iden x\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden y\/}$-${\iden y\/}$')$\\ +\skipover{{\keyword inst\/}}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{1}$\times $\xspa{1}$(${\iden x\/}$'${:}{+}{\iden y\/}$')$\xspa{3} & $=$ & \xspa{2}$(${\iden x\/}$\times ${\iden x\/}$'-${\iden y\/}$\times ${\iden y\/}$')$\xspa{1}{:}{+}\xspa{1}$(${\iden x\/}$\times ${\iden y\/}$'+${\iden y\/}$\times ${\iden x\/}$')$\\ +\skipover{{\keyword inst\/}}{\iden negate\/}\xspa{1}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{7} & $=$ & \xspa{2}{\iden negate\/}\xspa{1}{\iden x\/}\xspa{1}{:}{+}\xspa{1}{\iden negate\/}\xspa{1}{\iden y\/}\\ +\skipover{{\keyword inst\/}}{\iden abs\/}\xspa{1}{\iden z\/}\xspa{15} & $=$ & \xspa{2}{\iden magnitude\/}\xspa{1}{\iden z\/}\xspa{1}{:}{+}\xspa{1}{\numb 0\/}\\ +\skipover{{\keyword inst\/}}{\iden signum\/}\xspa{1}{\numb 0\/}\xspa{12} & $=$ & \xspa{2}{\numb 0\/}\\ +\skipover{{\keyword inst\/}}{\iden signum\/}\xspa{1}{\iden z@\/}$(${\iden x\/}{:}{+}{\iden y\/}$)$\xspa{5} & $=$ & \xspa{2}{\iden x\/}$/${\iden r\/}\xspa{1}{:}{+}\xspa{1}{\iden y\/}$/${\iden r\/}\xspa{2}{\keyword where\/}\xspa{1}{\iden r\/}\xspa{1}$=$\xspa{1}{\iden magnitude\/}\xspa{1}{\iden z\/}\\ +\skipover{{\keyword inst\/}}{\iden fromInteger\/}\xspa{1}{\iden n\/}\xspa{7} & $=$ & \xspa{2}{\iden fromInteger\/}\xspa{1}{\iden n\/}\xspa{1}{:}{+}\xspa{1}{\numb 0\/} +\end{tabular} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex new file mode 100644 index 0000000..e668990 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent1.tex @@ -0,0 +1,8 @@ +\begin{tabbing} +\begin{tabular}{@{}l@{\xspa1}c@{}l} +{\iden gcd\/}\xspa{7} & $::$ & \xspa{1}{\iden Int\/}\xspa{1}$\rightarrow$\xspa{1}{\iden Int\/}\xspa{1}$\rightarrow$\xspa{1}{\iden Int\/}\\ +{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4} & $=$ & \xspa{1}{\iden gcd\/}$'$\xspa{1}$(${\iden abs\/}\xspa{1}{\iden x\/}$)$\xspa{1}$(${\iden abs\/}\xspa{1}{\iden y\/}$)$\\ +\end{tabular}\\ +\skipover{{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4}$=$\xspa{1}}{\keyword where\/}\xspa{1}{\iden gcd\/}$'$\xspa{1}{\iden x\/}\xspa{1}{\numb 0\/}\xspa{1}$=$\xspa{1}{\iden x\/}\\ +\skipover{{\iden gcd\/}\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{4}$=$\xspa{1}{\keyword where\/}\xspa{1}}{\iden gcd\/}$'$\xspa{1}{\iden x\/}\xspa{1}{\iden y\/}\xspa{1}$=$\xspa{1}{\iden gcd\/}$'$\xspa{1}{\iden y\/}\xspa{1}$(${\iden x\/}\xspa{1}$`${\iden rem\/}$`$\xspa{1}{\iden y\/}$)$ +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex new file mode 100644 index 0000000..d175774 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_leftindent2.tex @@ -0,0 +1,8 @@ +\begin{tabbing} +{\iden eval\/}\xspa{1}$::$\xspa{1}{\iden GmState\/}\xspa{1}$\rightarrow$\xspa{1}$[${\iden GmState\/}$]$\\ +{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}{\iden state\/}$:$\xspa{1}{\iden restStates\/}\\ +\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\keyword where\/}\\ +\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\iden restStates\/}\xspa{1}$|$\xspa{1}{\iden gmFinal\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}$[]$\\ +\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}{\iden restStates\/}\xspa{1}}$|$\xspa{1}{\iden otherwise\/}\xspa{1}$=$\xspa{1}{\iden eval\/}\xspa{1}{\iden nextState\/}\\ +\skipover{{\iden eval\/}\xspa{1}{\iden state\/}\xspa{1}$=$\xspa{1}}{\iden nextState\/}\xspa{2}$=$\xspa{1}{\iden doAdmin\/}\xspa{1}$(${\iden step\/}\xspa{1}{\iden state\/}$)$ +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_math.tex b/ghc/CONTRIB/pphs/docs/LaTeX_math.tex new file mode 100644 index 0000000..4b4198d --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_math.tex @@ -0,0 +1,7 @@ +\begin{tabbing} +{\rm -}{\rm -}\xspa{1}{\com list\/}\xspa{1}{\com concatenation\/}\xspa{1}$(${\com right\/}$-${\com associative\/}$)$\\ +\begin{tabular}{@{}l@{\xspa1}c@{}l} +$($\plusplus$)$\xspa{20} & $::$ & \xspa{1}$[${\iden a\/}$]$\xspa{1}$\rightarrow$\xspa{1}$[${\iden a\/}$]$\xspa{1}$\rightarrow$\xspa{1}$[${\iden a\/}$]$\\ +{\iden xs\/}\xspa{1}\plusplus\xspa{1}{\iden ys\/}\xspa{16} & $=$ & \xspa{2}{\iden foldr\/}\xspa{1}$(:)$\xspa{1}{\iden ys\/}\xspa{1}{\iden xs\/} +\end{tabular} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex b/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex new file mode 100644 index 0000000..956fc49 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_simple.tex @@ -0,0 +1,5 @@ +\begin{tabbing} +{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}$=$\xspa{1}{\iden c\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}}{\keyword where\/}\\ +\skipover{{\iden foobar\/}\xspa{1}{\iden a\/}\xspa{1}{\iden b\/}\xspa{1}{\keyword wher\/}}{\iden c\/}\xspa{1}$=$\xspa{1}{\iden a\/}\xspa{1}$+$\xspa{1}{\iden b\/} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex b/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex new file mode 100644 index 0000000..6472e1d --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_string1.tex @@ -0,0 +1,10 @@ +\begin{tabbing} +{\rm -}{\rm -}\xspa{1}{\com File\/}\xspa{1}{\com and\/}\xspa{1}{\com channel\/}\xspa{1}{\com names\/}$:$\\ +\\ +\begin{tabular}{@{}l@{\xspa1}c@{}l} +{\iden stdin\/}\xspa{7} & $=$ & \xspa{2}{\rm ``}{\stri stdin\/}{\rm "}\\ +{\iden stdout\/}\xspa{6} & $=$ & \xspa{2}{\rm ``}{\stri stdout\/}{\rm "}\\ +{\iden stderr\/}\xspa{6} & $=$ & \xspa{2}{\rm ``}{\stri stderr\/}{\rm "}\\ +{\iden stdecho\/}\xspa{5} & $=$ & \xspa{2}{\rm ``}{\stri stdecho\/}{\rm "} +\end{tabular} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex b/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex new file mode 100644 index 0000000..696a2b6 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_string2.tex @@ -0,0 +1,10 @@ +\begin{tabbing} +{\iden main\/}\xspa{1}$=$\xspa{1}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\rm ``}{\stri please\/}\xspa{1}{\stri type\/}\xspa{1}{\stri a\/}\xspa{1}{\stri filename\hbox{$\setminus$}n\/}{\rm "}\xspa{1}{\iden exit\/}\xspa{1}$($\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden readChan\/}\xspa{1}{\iden stdin\/}\xspa{1}{\iden exit\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden userInput\/}\xspa{1}$\rightarrow$\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\keyword let\/}\xspa{1}$(${\iden name\/}\xspa{1}$:$\xspa{1}{\iden \_\/}$)$\xspa{1}$=$\xspa{1}{\iden lines\/}\xspa{1}{\iden userInput\/}\xspa{1}{\keyword in\/}\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\iden name\/}\xspa{1}{\iden exit\/}\xspa{1}$($\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden ioerror\/}\xspa{1}$\rightarrow$\xspa{1}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden ioerror\/}\xspa{1}$\rightarrow$\xspa{1}}{\rm ``}{\stri can\/}$'${\stri t\/}\xspa{1}{\stri open\/}\xspa{1}{\stri file\/}{\rm "}\xspa{1}{\iden exit\/}\xspa{1}{\iden done\/}$)$\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}{\iden readFile\/}\xspa{1}{\iden name\/}\xspa{1}}$(${\iden \hbox{$\setminus$}\/}\xspa{1}{\iden contents\/}\xspa{1}$\rightarrow$\\ +\skipover{{\iden main\/}\xspa{1}$=$\xspa{1}}{\iden appendChan\/}\xspa{1}{\iden stdout\/}\xspa{1}{\iden contents\/}\xspa{1}{\iden exit\/}\xspa{1}{\iden done\/}$))))$ +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex b/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex new file mode 100644 index 0000000..668ce57 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/LaTeX_wide-colons.tex @@ -0,0 +1,9 @@ +\begin{tabbing} +{\rm -}{\rm -}\xspa{1}{\com Character\/}\xspa{1}{\com functions\/}\\ +\\ +\begin{tabular}{@{}l@{\xspa1}c@{}l} +{\iden minChar\/}$,$\xspa{1}{\iden maxChar\/}\xspa{8} & $:\,:$ & \xspa{1}{\iden Char\/}\\ +{\iden minChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 0\/}\forquo \\ +{\iden maxChar\/}\xspa{17} & $=$ & \xspa{1}\forquo {\stri \hbox{$\setminus$}\/}{\numb 255\/}\forquo +\end{tabular} +\end{tabbing} diff --git a/ghc/CONTRIB/pphs/docs/Problem_Definition.tex b/ghc/CONTRIB/pphs/docs/Problem_Definition.tex new file mode 100644 index 0000000..8659bcc --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Problem_Definition.tex @@ -0,0 +1,37 @@ +\section{Problem definition} + +The problem is that a system is needed to typeset Haskell programs +to be inserted into documents. This would be useful in, for +instance, preparing papers for publication that are to include +Haskell programs. + +Haskell is a fairly new functional programming language and does not +as yet have a full range of tools available to use with the language. + +Many people use the \LaTeX\ system for typesetting. This uses +embedded typesetting commands in the input to arrange the typesetting. +The result as typeset has variable-width characters with a choice of +font styles and sizes available. The page-size, margins and layout +are also controllable by the user. + +Haskell programs are generally written on editors that produce ASCII +text. This has fixed-width characters and one plain font. + +In Haskell, the language avoids using +line terminators by having indentation to indicate the contextual meaning of +each line. It is thus crucial that this indentation is retained +when the text is put into \LaTeX. However as the \LaTeX\ system uses +variable width characters, the indentation +level is dependent on the characters under which the text is aligned. +The tabs and spaces that went to make +up the indentation in the original file have to be replaced with a +suitable amount of space to make the text line up with the position with which it +is aligned in the original file. + +It is also desirable to have +formatting improvements such as highlighting keywords and identifiers as well as +inserting proper mathematical characters in place of the Haskell-ASCII simulations. + +Currently the only way of doing this is by labouriously inserting formatting +commands into the text by hand. The alternative is to print out the programs +verbatim with plain ASCII-style fixed-width font. diff --git a/ghc/CONTRIB/pphs/docs/Project_Documents.tex b/ghc/CONTRIB/pphs/docs/Project_Documents.tex new file mode 100644 index 0000000..5833c2a --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Project_Documents.tex @@ -0,0 +1,7 @@ +\chapter{Project documents} + +These are the original project documents from 19th January 1994. + +\input{Problem_Definition} +\input{Statement_Of_Requirements} +\input{External_Specification} diff --git a/ghc/CONTRIB/pphs/docs/Report.tex b/ghc/CONTRIB/pphs/docs/Report.tex new file mode 100644 index 0000000..d37dd0d --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Report.tex @@ -0,0 +1,49 @@ +\documentstyle[12pt,fleqn,rep,pphs]{report} +\renewcommand{August 1994} +\begin{document} + +\def\sect{\section} +\def\subsect{\subsection} + +% Title page +\title{Literate Haskell} +\author{A. Preece \\\\ University of Glasgow} +\maketitle + +\setcounter{page}{2} +\tableofcontents + +\input{Introduction} +\input{What} +\input{How} +\input{Uses} +\input{Error_Messages} +\input{Faults} +\input{Future_Work} + +\appendix + +\input{Project_Documents} +\input{User_Documents} +\input{Code} + +\begin{thebibliography}{9} +\addcontentsline{toc}{chapter}{Bibliography} + +\bibitem{Haskell-report} +Hudak, P., Peyton Jones, S., Wadler, P., et al., {\em Haskell, Report on the Programming Language\/} +(1992) + +\bibitem{LaTeX-book} +Lamport, L., {\em \LaTeX : A Document Preparation System\/} +(Addison-Wesley, 1986) + +\end{thebibliography} + +\chapter*{Acknowledgements} +\addcontentsline{toc}{chapter}{Acknowledgements} + +I am very grateful for the help and advise of Project Supervisor Tom Melham, +and also for the suggestions of Phil Wadler, Richard McPhee, and Mark Pollock. + +\end{document} diff --git a/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex b/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex new file mode 100644 index 0000000..00b8fd5 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Statement_Of_Requirements.tex @@ -0,0 +1,32 @@ +\section{Statement of requirements} + +There are various things that are required of the solution to the +problem described previously. +\begin{itemize} +\item The program must take a file with a Haskell program in it and produce +\LaTeX\ code to stdout. This code must produce that Haskell program in +typeset style when run through +the \LaTeX\ program. The result as typeset must be recognisable as having the same +layout as the input file's Haskell program had. + +\item The input file will contain only Haskell code. Any documentation in the file +will be in the form of comments. + +\item The input file will not have any embedded typesetting characters in it so +the program must analyse the input and decide for itself what needs to be +done to produce the correct \LaTeX\ code. + +\item The \LaTeX\ code produced must be easy to incorporate into a \LaTeX\ +document such as a paper or book. Thus the produced code must be able +to be incorporated into documents of different page and font size. + +\item Keywords and identifiers must be highlightable so as to distinguish +them from the rest of the Haskell program. +The user should be allowed some choice in the typeface used for +highlighting. + +\item Generality of use must be retained so as to allow the program to be used in conjunction +with a file of any name and thus not use an inflexible built-in filename. + +\item The program must be in keeping with conventional UNIX style. +\end{itemize} diff --git a/ghc/CONTRIB/pphs/docs/Title.tex b/ghc/CONTRIB/pphs/docs/Title.tex new file mode 100644 index 0000000..e69de29 diff --git a/ghc/CONTRIB/pphs/docs/UserGuide.tex b/ghc/CONTRIB/pphs/docs/UserGuide.tex new file mode 100644 index 0000000..5f46b08 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/UserGuide.tex @@ -0,0 +1,9 @@ +\documentstyle[12pt,fleqn,a4,pphs]{report} +\begin{document} + +\def\sect{\section*} +\def\subsect{\subsection*} + +\input{UserGuide_Text} + +\end{document} diff --git a/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex b/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex new file mode 100644 index 0000000..5dc6999 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/UserGuide_Text.tex @@ -0,0 +1,231 @@ +\sect{User guide to {\tt pphs}} + +The program {\tt pphs} typesets programs in the Haskell programming +language for use with the \LaTeX\ intensional text formatting +and typesetting system. It takes +as input a file containing a Haskell program and produces \LaTeX\ +code to {\tt stdout}. There are various different features of this +process. + +\subsect{Left indentation} + +It is in the nature of Haskell programs that indentation is heavily used. As the +indentation is vital to the parsing of the program, any attempt at typesetting +Haskell code must replicate this indentation. Take, for example, the following piece of code. +\begin{quote} +\input{Haskell_leftindent2} +\end{quote} +Note how the third, fifth and sixth lines start at different levels of indentation. +The {\tt pphs} program produces the correct \LaTeX\ code to align these under the +correct position in the preceding lines once typeset. It also selects the correct +line to line up under. Note how the sixth line does not line up +under its predecessor, but under the fourth line. +The code necessary to typeset this is produced, preserving the parsing +order. Once typeset, it will look like this: +\begin{quote} +\input{LaTeX_leftindent2} +\end{quote} +Note that this +example of possible input had no `extra' typesetting commands. + +A line of Haskell code may be indented beyond the end of its predecessor. +Here, {\tt pphs} aligns it with whichever line it is lined up underneath in the +original file, or, if longer than any preceding line, inserts space to correspond +to that in the input file. + +\subsect{Internal alignment} + +Another form of alignment used in Haskell is {\em internal alignment}. This is where +there is vertical alignment of columns other than at the left-hand edge of the +Haskell code. This is typically characterised with a column of the same character +appearing in the program code, and it is this case, along with a +special case, that {\tt pphs} recognises for internal alignment having occurred. +\begin{quote} +\input{Haskell_internalalign1} +\end{quote} +In this example, see how the {\tt =} signs line up, one below the other. This makes +the program more readable, although it does not affect the parsing of the program. +As the purpose of {\tt pphs} is to make Haskell programs even more readable, it +retains this alignment. This example would be typeset to produce the following: +\begin{quote} +\input{LaTeX_internalalign1} +\end{quote} +The special case for internal alignment is a $=$ aligned under a $::$. +This will cause the same effect as would have happened if they were the same +character. + +\subsect{Token highlighting} + +To increase the readability of Haskell programs, {\tt pphs} allows various tokens +to be highlighted. By using different typefaces for some pieces of code, this +distinguishes them from the rest. The user can specify the details of +the highlighting, but the default settings are {\bf bold} for +keywords, {\it italics} for identifiers and {\rm roman} for everything else. +Strings, comments and numbers are also highlightable. + +Note that in the previous example, the keywords {\bf instance} and {\bf where} +are highlighted in bold, whereas the various identifiers are in italics. + +\subsect{Mathematical symbols} + +Rather than simply replicate the ASCII approximations of mathematical symbols +used in Haskell, {\tt pphs} +substitutes the proper symbols in the output. These are shown below. +\begin{center} +\begin{tabular}[t]{|c|c|} \hline +{\em Haskell\/} & {\em Math\/} \\ \hline +{\tt *} & $\times$ \\ +{\tt ++} & {\hbox{$+\mkern-7.5mu+$}} \\ +{\tt :+} & {:}{+} \\ +{\tt <=} & $\leq$ \\ \hline +\end{tabular} \hskip3mm \begin{tabular}[t]{|c|c|} \hline +{\em Haskell\/} & {\em Math\/} \\ \hline +{\tt >=} & $\geq$ \\ +{\tt <-} & $\leftarrow$ \\ +{\tt ->} & $\rightarrow$ \\ +{\tt =>} & $\Rightarrow$ \\ \hline +\end{tabular} +\end{center} + +\subsect{\LaTeX\ typesetting characters} + +\LaTeX\ uses embedded typesetting commands, so {\tt pphs} has to ensure that if +any of the characters used by \LaTeX\ appear in the input Haskell code, the correct +\LaTeX\ code is outputted to typeset them, rather than have the characters interfere +with the typesetting process. The characters used by \LaTeX\ for typesetting are: +\begin{quote} +\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) +\end{quote} +The user of {\tt pphs} need not worry about using any of these characters in Haskell +programs, as this will be dealt with by {\tt pphs} before \LaTeX\ gets to see the code. + +\subsect{How to call it} + +The program is called by typing {\tt pphs} followed by the name of +the file containing the Haskell program to be typeset. If the +filename ends with a {\tt .hs} extension, this may be omitted, +unless another file exists with the same name but no extension. +When no extension is specified, the program will look for a +filename with no extension before looking for a file with the +{\tt .hs} extension. + +For example, if the Haskell program was in a file called {\tt Haskell.hs}, +the program would be called by +\begin{quote} +\tt pphs Haskell.hs +\end{quote} +As the filename ends with a {\tt .hs} extension, the extension may be omitted, provided +there is no file already existing called {\tt Haskell}. If there is no such file +\begin{quote} +\tt pphs Haskell +\end{quote} +would produce the same effect as the original call. + +As the program outputs to {\tt stdout}, the code produced may be +directed to a file by using a {\tt >} symbol after the call, followed by +the name of the file to contain the \LaTeX\ code produced by the +program. Continuing the above example, if the output code is to be in +a file called {\tt Haskell.tex}, the call would now be +\begin{quote} +\tt pphs Haskell.hs > Haskell.tex +\end{quote} +It must be noted that if the file {\tt Haskell.tex} already exists, it must be +renamed or removed before making this call. + +There are three options that can be specified in the program call. +If it is desired that double colon symbols should look like $:\,:$ rather than $::$, +use {\tt -w} in the call. The length of the tab characters in the input file can +be specified with {\tt -t} followed by the length. The default tablength is 8. +If identifiers with subscripts are wanted, eg {\iden ident$_1$\/}, then use {\tt -s}. +These are written in the Haskell file as {\tt ident\_1}. + +If the length of the tabs are 4 and +the wide double colons are required, the example call above would become as follows. +\begin{quote} +\tt pphs -t4w Haskell.hs > Haskell.tex +\end{quote} + +\subsect{What to do with the produced code} + +Before including the \LaTeX\ code in the document, it is necessary +to include definitions of the \LaTeX\ commands used by {\tt pphs}. +This can be done simply by including the style file {\tt pphs.sty} +by adding {\tt pphs} to the option list of the documentstyle +command like thus: +\begin{quote} +\begin{verbatim} +\documentstyle[12pt,a4,pphs]{article} +\end{verbatim} +\end{quote} + +Once this has been done, the file containing the \LaTeX\ code +of the Haskell program code can be included. This is done +using the {\tt \char'134 input} command. If the \LaTeX\ +code is located in a file called {\tt Haskell.tex} then the +command is: +\begin{quote} +\begin{verbatim} +\input{Haskell} +\end{verbatim} +\end{quote} +This can be used in various \LaTeX\ environments such as {\tt quote}, +{\tt figure} or {\tt table} to produce different effects. An example +of possible code is: +\begin{quote} +\begin{verbatim} +\begin{quote} +\input{Haskell} +\end{quote} +\end{verbatim} +\end{quote} +See Lamport, L., {\em \LaTeX : A Document Preparation System\/} +(Addison-Wesley, 1986) for more details. + +\subsect{How to make adjustments to the output} + +The {\tt pphs} program is flexible in that it allows user choice on some aspects +of the appearance of the final result. User choice is allowed in two areas, typefaces +and qoute marks. + +The default settings for typefaces are bold for keywords, italics for identifiers and +roman for everything else that is not in the math typeface. However, keywords, identifiers, +strings, comments and numbers may be in whatever typeface the user chooses. +This is done using the {\tt \char'134 def} command to redefine the typeface commands +used by {\tt pphs}. These are {\tt \char'134 keyword}, {\tt \char'134 iden}, +{\tt \char'134 stri}, {\tt \char'134 com} and {\tt \char'134 numb} respectively. + +For example, to put all comments into typewriter font, use +{\tt \char'134 def\char'134 com\char'173 \char'134 tt\char'175} in +the document. The scope of the declaration will be from the point of introduction to +the end of the document. To cancel a redefinition, use {\tt \char'134 def} to +redefine it back to what it was originally. The different typefaces available in \LaTeX\ are +\begin{center} +\begin{tabular}{|c|l|} \hline +{\em code\/} & {\em meaning\/} \\ \hline +{\tt \char'134 bf} & {\bf Boldface} \\ +{\tt \char'134 em} & {\em Emphatic\/} \\ +{\tt \char'134 it} & {\it Italics\/} \\ +{\tt \char'134 rm} & {\rm Roman} \\ \hline +\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline +{\em code\/} & {\em meaning\/} \\ \hline +{\tt \char'134 sc} & {\sc Small Caps} \\ +{\tt \char'134 sf} & {\sf Sans Serif} \\ +{\tt \char'134 sl} & {\sl Slanted\/} \\ +{\tt \char'134 tt} & {\tt Typewriter} \\ \hline +\end{tabular} +\end{center} +It should be noted that the emphatic typeface is just the same as italics, although +nesting emphatic sections will alternate between italics and roman. + +Two types of quote mark are redefinable, forwards quotes and escape quotes. +The default for both of them is ' but if it is wished to redefine one or +both of them, use the {\tt \char'134 def} with either {\tt \char'134 forquo} +or {\tt \char'134 escquo}. For example, to make escape quotes be +printed as {\sf '} use {\tt \char'134 def\char'134 escquo\char'173 \char'134 hbox\char'173 \char'134 sf '\char'175 \char'175} in the document. + +\subsect{Altering the output} + +As {\tt pphs} produces code which is subsequently run through \LaTeX , it is possible +to alter the code before it is run through \LaTeX . This is useful for correcting +mistakes made by {\tt pphs}. However, it is recommended that only those experienced +in \LaTeX\ try this. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/User_Documents.tex b/ghc/CONTRIB/pphs/docs/User_Documents.tex new file mode 100644 index 0000000..0680e62 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/User_Documents.tex @@ -0,0 +1,5 @@ +\chapter{User documentation} + +This document is intended to be read by users of {\tt pphs}. + +\input{UserGuide_Text} diff --git a/ghc/CONTRIB/pphs/docs/Uses.tex b/ghc/CONTRIB/pphs/docs/Uses.tex new file mode 100644 index 0000000..c488bb4 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Uses.tex @@ -0,0 +1,262 @@ +\chapter{Uses for output} + +This chapter describes how the output from {\tt pphs} can be used. First, +examples of the capabilities of {\tt pphs} are shown, then it is explained how +the output is incorporated into \LaTeX\ documents, and how the user can alter +the output using built in methods or by editing the output. + +\section{Examples of output} \label{examples} + +Up until now, only examples of input have been shown. Let us now see what +{\tt pphs} actually does to this input. Take this earlier example. +\begin{quote} +\input{Haskell_leftindent2} +\end{quote} +This is how this code is typeset by {\tt pphs}. +\begin{quote} +\input{LaTeX_leftindent2} +\end{quote} +Probably the most obvious thing about the typeset code is the highlighting +of the identifiers. The reserved identifier or keyword {\keyword where} has been +highlighted in boldface while all the other identifiers are in italics. +The various symbols are in roman or math font as appropriate, these do not +get put in italics. Less obvious is the indentation. Notice how the starts +of the third, fourth and sixth lines all line up under {\iden state\/} on the +second line, just like they do in the input. Similarly, the start of the fifth +line is under the $|$ on the fourth. This demonstrates {\tt pphs}'s ability to +recreate left indentation in \LaTeX. But note how the $=$ on the sixth line does +not align under the $|$ on the fifth as it does in the input. This is because +they are different characters and so {\tt pphs} does not recognise this as internal +alignment. The only special case made in this part of the program was for $::$ and $=$. +Alignment would have occurred by coincidence had the preceding characters on both lines +been of the same width. + +To illustrate internal alignment, recall this earlier example. +\begin{quote} +\input{Haskell_internalalign1} +\end{quote} +This code gets typeset like this. +\begin{quote} +\input{LaTeX_internalalign1} +\end{quote} +Notice here how the $=$ signs are aligned in a column, despite being preceded +be characters that may be of different widths. This demonstrates the ability of +{\tt pphs} to recreate internal alignment. Notice also how the {\tt '} signs +have been interpreted as primes. This is because they are immediately preceded +by identifiers. The {\tt *} signs have been transformed into multiplication signs, +while the {\tt =>} has been replaced with $\Rightarrow$. + +Here is a new example, this time illustrating a comment and strings. +\begin{quote} +\input{Haskell_string1} +\end{quote} +This example gets typeset as follows. +\begin{quote} +\input{LaTeX_string1} +\end{quote} +Note how {\tt pphs} puts the correct inverted commas at each end of the strings +and how the strings themselves and the comment are in roman typeface. +The $=$ signs show internal alignment. + +This next example demonstrates a comment, character quotes and the special case +with internal alignment where {\tt =} are aligned under {\tt ::}. +\begin{quote} +\input{Haskell_char} +\end{quote} +Typeset, this becomes +\begin{quote} +\input{LaTeX_char} +\end{quote} +The comment is typeset in roman, as are the character quotes. This example has +the default double colon. Using the {\tt -w} option, the colons can be positioned +further apart as illustrated below. +\begin{quote} +\input{LaTeX_wide-colons} +\end{quote} +It is a matter of taste which is used. + +\section{Incorporating output into \LaTeX\ documents} + +The motivation behind typesetting Haskell programs was so they could be incorporated +into \LaTeX\ documents. This section describes how to do this with the output +of {\tt pphs}. + +\subsection{The style file} \label{style-file} + +Before using the output generated by {\tt pphs}, it is necessary to incorporate the +{\tt pphs.sty} style file (see Appendix~\ref{style-code}) into the document. +This provides definitions of the non-standard +commands produced by the program. The use of the style file is announced +by adding {\tt pphs} to the option list of the documentstyle +command like thus: +\begin{quote} +\begin{verbatim} +\documentstyle[12pt,a4,pphs]{article} +\end{verbatim} +\end{quote} +Without {\tt pphs} in the option list, errors will occur when \LaTeX\ is run, +unless all the non-standard commands used by {\tt pphs} have been defined elsewhere +in the document. + +\subsection{Including the output file} + +To include the file containing the code output by {\tt pphs}, the \LaTeX\ +{\tt \char'134 input} command is used. If the file containing the output is called +{\tt output.tex} then the following command is used. +\begin{quote} +\begin{verbatim} +\input{output} +\end{verbatim} +\end{quote} +The code will appear at the left margin like this: +\input{LaTeX_simple} +This is useful for code listings. + +By using various different \LaTeX\ environments, the typeset Haskell code +can be arranged differently. +To have the code indented like the examples in Section~\ref{examples}, the +{\tt quote} environment should be used. The code +\begin{quote} +\begin{verbatim} +\begin{quote} +\input{output} +\end{quote} +\end{verbatim} +\end{quote} +would produce +\begin{quote} +\input{LaTeX_simple} +\end{quote} +The {\tt table} environment can be used to put the typeset Haskell code +into a table and also allows the code to be captioned. +The table will appear at the top of the current or next page depending on what +space is available in the document. The \LaTeX\ code used to produce this is +\begin{quote} +\begin{verbatim} +\begin{table} +\begin{center} +\begin{minipage}{5cm} +\input{output} +\end{minipage} +\end{center} +\caption{Typeset code in a table} \label{output-table} +\end{table} +\end{verbatim} +\end{quote} +and this will produce a table, in this case Table~\ref{simple-table}. +The {\tt minipage} environment is required because \LaTeX\ interprets the {\tt tabbing} +environment as occupying the full page width, even if the text doesn't actually +use all that space. The width argument, here {\tt 5cm}, is set to the width of the typeset +Haskell code. If centering is not required, omit the {\tt center} and +{\tt minipage} environments. +The table can be referenced if it is labelled with the {\tt \char'134 label} +command, as above, and can be referred to in the text by using the code +{\tt Table\char'176 \char'134 ref\char'173 output-table\char'175} which will +keep the table number consistent with the numbering of the chapter and other tables. +\begin{table} +\begin{center} +\begin{minipage}{5cm} +\input{LaTeX_simple} +\end{minipage} +\end{center} +\caption{Typeset code in a table} \label{simple-table} +\end{table} +Similarly, the {\tt figure} environment can be used. The code is +\begin{quote} +\begin{verbatim} +\begin{figure} +\begin{center} +\begin{minipage}{5cm} +\input{output} +\end{minipage} +\end{center} +\caption{Typeset code in a figure} \label{output-figure} +\end{figure} +\end{verbatim} +\end{quote} +which produces a figure, in this case Figure~\ref{simple-figure}. +Again, it can be captioned and referenced, as with tables. +\begin{figure} +\begin{center} +\begin{minipage}{5cm} +\input{LaTeX_simple} +\end{minipage} +\end{center} +\caption{Typeset code in a figure} \label{simple-figure} +\end{figure} + +The result, once included in the final document, may have too +much blank space under the typeset code such as is the case in +this next example. +\begin{quote} +\input{LaTeX_blankline} +\end{quote} +This means there were extra blank lines at the end of the input file, caused +by extra return characters. This can be +rectified by removing the extra return characters and running {\tt pphs} again. + +\subsection{Lengthy lines} + +It is always possible that the lines of typeset Haskell code will run off +the right-hand edge of the user's page in the final document. Where this happens, +it is necessary to edit the input file and re-run {\tt pphs}. Be careful not to +change the parse of the program by wrongly indenting the second part of the line. + +\section{User adjustments} \label{user-adj} + +The user is able to have some say on what the output looks like. +This makes the program more flexible and doesn't dictate what a +Haskell program should look like when typeset. There are two areas in which user +choice is allowed, other than the double colon symbol described in Chapter~\ref{wide-colons}. + +\subsection{Typefaces} + +The default settings for typefaces are bold for keywords, italics for identifiers and +roman for everything else that is not in the math typeface. However, keywords, identifiers, +strings, comments and numbers may be in whatever typeface the user chooses. +This is done using the {\tt \char'134 def} command to redefine the typeface commands +used by {\tt pphs}. These are {\tt \char'134 keyword}, {\tt \char'134 iden}, +{\tt \char'134 stri}, {\tt \char'134 com} and {\tt \char'134 numb} respectively. + +For example, to put all comments into typewriter font, use +{\tt \char'134 def\char'134 com\char'173 \char'134 tt\char'175} in +the document. The scope of the declaration will be from the point of introduction to +the end of the document. To cancel a redefinition, use {\tt \char'134 def} to +redefine it back to what it was originally. + +The different typefaces available in \LaTeX\ are shown in Table~\ref{fonts}. +It should be noted that the emphatic typeface is just the same as italics, although +nesting emphatic sections will alternate between italics and roman. +\begin{table} +\begin{center} +\begin{tabular}{|c|l|} \hline +{\em code\/} & {\em meaning\/} \\ \hline +{\tt \char'134 bf} & {\bf Boldface} \\ +{\tt \char'134 em} & {\em Emphatic\/} \\ +{\tt \char'134 it} & {\it Italics\/} \\ +{\tt \char'134 rm} & {\rm Roman} \\ \hline +\end{tabular} \hskip3mm \begin{tabular}{|c|l|} \hline +{\em code\/} & {\em meaning\/} \\ \hline +{\tt \char'134 sc} & {\sc Small Caps} \\ +{\tt \char'134 sf} & {\sf Sans Serif} \\ +{\tt \char'134 sl} & {\sl Slanted\/} \\ +{\tt \char'134 tt} & {\tt Typewriter} \\ \hline +\end{tabular} +\end{center} +\caption{Typefaces available in \LaTeX } \label{fonts} +\end{table} + +\subsection{Quote marks} + +Two types of quote mark are redefinable, forwards quotes and escape quotes. +The default for both of them is ' but if it is wished to redefine one or +both of them, use the {\tt \char'134 def} with either {\tt \char'134 forquo} +or {\tt \char'134 escquo}. For example, to make escape quotes be +printed as {\sf '} use {\tt \char'134 def\char'134 escquo\char'173 \char'134 hbox\char'173 \char'134 sf '\char'175 \char'175} in the document. + +\section{Altering the output} + +As {\tt pphs} produces code which is subsequently run through \LaTeX , it is possible +to alter the code before it is run through \LaTeX . This is useful for correcting +mistakes made by {\tt pphs}. However, it is recommended that only those experienced +in \LaTeX\ try this. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/What.tex b/ghc/CONTRIB/pphs/docs/What.tex new file mode 100644 index 0000000..741c822 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/What.tex @@ -0,0 +1,136 @@ +\chapter{What {\tt pphs} does} + +This chapter describes a program called {\tt pphs} which implements the typesetting +requirements described in the previous chapter. The description is from the user's viewpoint, +later chapters going on to describe it from that of the programmer. + +The {\tt pphs} program typesets Haskell programs for use with the \LaTeX\ +typesetting program. It takes as input a file containing a Haskell +program and produces the Haskell code to {\tt stdout}. It is called by +typing {\tt pphs}, followed by the name of the file containing the Haskell +program. For example, if the Haskell program was in a file called {\tt Haskell.hs}, +the program would be called by +\begin{quote} +\tt pphs Haskell.hs +\end{quote} + +If the filename ends with a {\tt .hs} extension, the extension may be omitted, provided +there is no file already existing with the same name but with no extension. If no +extension is given with the filename when called, the program will look for a file of +that name with no extension. If this is not found, the program will add a {\tt .hs} +extension. The above example, therefore, may be simplified to +\begin{quote} +\tt pphs Haskell +\end{quote} +unless the file {\tt Haskell} exists, in which case the original call must be made. + +As the output of {\tt pphs} is to {\tt stdout}, it may be directed to a file by using +the {\tt >} command after the call, followed by the name of the file to contain +the \LaTeX\ code. Continuing the above example, if the output code is to be put into +a file called {\tt Haskell.tex}, the call would now be +\begin{quote} +\tt pphs Haskell.hs > Haskell.tex +\end{quote} +It must be noted that if the file {\tt Haskell.tex} already exists, it should be +renamed or removed before making this call. + +Two options are allowed with the call. In the output, some people prefer \label{wide-colons} +the {\tt ::} symbol to be written $:\,:$ rather than $::$. To obtain the former, use +{\tt -w} for wide colons. A call on {\tt Haskell.hs} requiring wide colons would be +\begin{quote} +\tt pphs -w Haskell.hs +\end{quote} +When the input file's tab characters are not of the standard 8 spaces, this can be +specified with the {\tt -t} command. For example, if the tabs were 4 spaces long, type +\begin{quote} +\tt pphs -t4 Haskell.hs +\end{quote} +Both options can be used at the same time by calling +\begin{quote} +\tt pphs -t4w Haskell.hs +\end{quote} +or +\begin{quote} +\tt pphs -wt4 Haskell.hs +\end{quote} +Any positive integer can be specified for the tablength. + +\section{Left indentation} + +It is in the nature of Haskell programs that indentation is heavily used. As the +indentation is vital to the parsing of the program, any attempt at typesetting +Haskell code must replicate this indentation. Take, for example, the following piece of code. +\begin{quote} +\input{Haskell_leftindent1} +\end{quote} +Note how the third and fourth lines both start at different levels of indentation. +The {\tt pphs} program produces the correct \LaTeX\ code to align these under the +correct position in the preceding lines once typeset. It also selects the correct +line to line up under. Note how, in the following example, the sixth line does not line up +under its predecessor, but under the fourth line. +\begin{quote} +\input{Haskell_leftindent2} +\end{quote} +Again, {\tt pphs} produces the code necessary to typeset this, preserving the parsing +order. A line of Haskell code may be indented beyond the end of its predecessor. +Here, {\tt pphs} aligns it with whichever line it is lined up underneath in the +original file. Note that these +examples of possible input have no `extra' typesetting commands. + +\section{Internal alignment} + +Another form of alignment used in Haskell is {\em internal alignment}. This is where +there is vertical alignment of columns other than at the left-hand edge of the +Haskell code. +\begin{quote} +\input{Haskell_internalalign1} +\end{quote} +In this example, see how the {\tt =} signs line up, one below the other. This makes +the program more readable, although it does not affect the parsing of the program. +As the purpose of {\tt pphs} is to make Haskell programs even more readable, it +retains this alignment. + +\section{Token highlighting} + +To increase the readability of Haskell programs, {\tt pphs} allows various tokens +to be highlighted. By using different typefaces for some pieces of code, this +distinguishes them from the rest. The user can specify the details of the highlighting as +described in Section~\ref{user-adj}, but the default settings are {\bf bold} for +keywords, {\it italics} for identifiers and {\rm roman} for everything else. Strings, +comments and numbers are also highlightable (see Section~\ref{user-adj}). + +\section{Mathematical symbols} + +Rather than simply replicate the ASCII approximations of mathematical symbols +used in Haskell, {\tt pphs} +substitutes the proper symbols in the output. These are shown in Table~\ref{maths-sym}. +\begin{table} +\begin{center} +\begin{tabular}[t]{|c|c|} \hline +{\em Haskell\/} & {\em Math\/} \\ \hline +{\tt *} & $\times$ \\ +{\tt ++} & {\hbox{$+\mkern-7.5mu+$}} \\ +{\tt :+} & {:}{+} \\ +{\tt <=} & $\leq$ \\ \hline +\end{tabular} \hskip3mm \begin{tabular}[t]{|c|c|} \hline +{\em Haskell\/} & {\em Math\/} \\ \hline +{\tt >=} & $\geq$ \\ +{\tt <-} & $\leftarrow$ \\ +{\tt ->} & $\rightarrow$ \\ +{\tt =>} & $\Rightarrow$ \\ \hline +\end{tabular} +\end{center} +\caption{Haskell ASCII approximations to mathematical characters} \label{maths-sym} +\end{table} + +\section{\LaTeX\ typesetting characters} + +\LaTeX\ uses embedded typesetting commands, so {\tt pphs} has to ensure that if +any of the characters used by \LaTeX\ appear in the input Haskell code, the correct +\LaTeX\ code is outputted to typeset them, rather than have the characters interfere +with the typesetting process. The characters used by \LaTeX\ for typesetting are: +\begin{quote} +\(\#\ \$\ \%\ \&\ \char'176\ \_\ \char'136\ \hbox{$\setminus$}\ \hbox{$\cal \char'146\ \char'147$}\) +\end{quote} +The user of {\tt pphs} need not worry about using any of these characters in Haskell +programs, as this will be dealt with by {\tt pphs} before \LaTeX\ gets to see the code. \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/Wrapper.tex b/ghc/CONTRIB/pphs/docs/Wrapper.tex new file mode 100644 index 0000000..c780cd8 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/Wrapper.tex @@ -0,0 +1,6 @@ +\documentstyle[12pt,fleqn,a4,pphs]{article} +\begin{document} + +\input{Haskell} + +\end{document} diff --git a/ghc/CONTRIB/pphs/docs/char.hs b/ghc/CONTRIB/pphs/docs/char.hs new file mode 100644 index 0000000..0aa661e --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/char.hs @@ -0,0 +1,5 @@ +-- Character functions + +minChar, maxChar :: Char +minChar = '\0' +maxChar = '\255' \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/comment.hs b/ghc/CONTRIB/pphs/docs/comment.hs new file mode 100644 index 0000000..694cc4a --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/comment.hs @@ -0,0 +1 @@ +-- note that x + y = z \ No newline at end of file diff --git a/ghc/CONTRIB/pphs/docs/internalalign1.hs b/ghc/CONTRIB/pphs/docs/internalalign1.hs new file mode 100644 index 0000000..dad2f14 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/internalalign1.hs @@ -0,0 +1,9 @@ +instance (RealFloat a) => Num (Complex a) where + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 diff --git a/ghc/CONTRIB/pphs/docs/leftindent1.hs b/ghc/CONTRIB/pphs/docs/leftindent1.hs new file mode 100644 index 0000000..43a7cf4 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/leftindent1.hs @@ -0,0 +1,4 @@ +gcd :: Int -> Int -> Int +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) diff --git a/ghc/CONTRIB/pphs/docs/leftindent2.hs b/ghc/CONTRIB/pphs/docs/leftindent2.hs new file mode 100644 index 0000000..9d9fcd0 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/leftindent2.hs @@ -0,0 +1,6 @@ +eval :: GmState -> [GmState] +eval state = state: restStates + where + restStates | gmFinal state = [] + | otherwise = eval nextState + nextState = doAdmin (step state) diff --git a/ghc/CONTRIB/pphs/docs/math.hs b/ghc/CONTRIB/pphs/docs/math.hs new file mode 100644 index 0000000..4906527 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/math.hs @@ -0,0 +1,3 @@ +-- list concatenation (right-associative) +(++) :: [a] -> [a] -> [a] +xs ++ ys = foldr (:) ys xs diff --git a/ghc/CONTRIB/pphs/docs/pphs.sty b/ghc/CONTRIB/pphs/docs/pphs.sty new file mode 100644 index 0000000..298a58e --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/pphs.sty @@ -0,0 +1,26 @@ +% ========================================= +% Definitions for use with the pphs program +% ========================================= + +\typeout{For use with the pphs program} + +% Definitions of commands used by pphs + +\newbox\foo +\def\skipover#1{\setbox\foo\hbox{#1}\hskip\wd\foo} +\def\plusplus{\hbox{$+\mkern-7.5mu+$}} +\def\xspa#1{\hskip#1ex} +\def\bareq{\setbox\foo\hbox{$=$}\makebox[\wd\foo]{$|$}} + +% User-redefinable commands - typefaces + +\def\keyword{\bf} +\def\iden{\it} +\def\stri{\rm} +\def\com{\rm} +\def\numb{\rm} + +% User-redefinable commands - quote marks + +\def\forquo{\hbox{\rm '}} +\def\escquo{\hbox{\rm '}} diff --git a/ghc/CONTRIB/pphs/docs/rep.sty b/ghc/CONTRIB/pphs/docs/rep.sty new file mode 100644 index 0000000..bb4242d --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/rep.sty @@ -0,0 +1,80 @@ +% ===================================================================== +% A4 layout file for documents with big left margins - for folders. +% ===================================================================== + +\typeout{A4 with big left margin document layout} + +% --------------------------------------------------------------------- +% make "@" a letter +% --------------------------------------------------------------------- +\makeatletter + +% --------------------------------------------------------------------- +% PAPER SIZE +% +% TeX expects 1 inch margins all around (1 inch = 25.4 mm). +% a4 is exactly 297mm high by 208mm wide. +% --------------------------------------------------------------------- + +\hsize=157.2truemm +\vsize=246.2truemm + +% --------------------------------------------------------------------- +% PAGE LAYOUT +% +% text size = 144.5mm wide by 231.1mm high +% +% Top Margin: 1in +% Left margin: 1.5in +% Right Margin: 1in +% --------------------------------------------------------------------- + +\textwidth 144.5truemm +\textheight 231.1truemm + +\oddsidemargin=12.7truemm +\evensidemargin=0truemm +\topmargin=0truemm + +% --------------------------------------------------------------------- +% RUNNING HEAD: none +% --------------------------------------------------------------------- +\headheight 0mm +\headsep 0mm + +% --------------------------------------------------------------------- +% FOOT: page number and other information. +% --------------------------------------------------------------------- +\footheight 12pt +\footskip 18truemm +\addtolength{\footskip}{\footheight} + +% --------------------------------------------------------------------- +% INDENTATION +% +% 5mm indentation +% --------------------------------------------------------------------- +\parindent 5truemm + +% --------------------------------------------------------------------- +% math indentation. +% --------------------------------------------------------------------- +\mathindent 10.0truemm + +% --------------------------------------------------------------------- +% FOOTNOTES +% +% Footnotes are in 10 point font. +% +% put 12+1-1 points between text and rule +% put 10pt between at start of footnote +% foot note rule 40mm long +% --------------------------------------------------------------------- +\skip\footins 12pt plus 2pt minus 2pt +\footnotesep 10pt +\def\footnoterule{\kern-3\p@ \hrule width 40mm \kern 2.6\p@} + +% --------------------------------------------------------------------- +% make "@" an other +% --------------------------------------------------------------------- +\makeatother diff --git a/ghc/CONTRIB/pphs/docs/simple.hs b/ghc/CONTRIB/pphs/docs/simple.hs new file mode 100644 index 0000000..b31d023 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/simple.hs @@ -0,0 +1,3 @@ +foobar a b = c + where + c = a + b diff --git a/ghc/CONTRIB/pphs/docs/string1.hs b/ghc/CONTRIB/pphs/docs/string1.hs new file mode 100644 index 0000000..4375732 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/string1.hs @@ -0,0 +1,6 @@ +-- File and channel names: + +stdin = "stdin" +stdout = "stdout" +stderr = "stderr" +stdecho = "stdecho" diff --git a/ghc/CONTRIB/pphs/docs/string2.hs b/ghc/CONTRIB/pphs/docs/string2.hs new file mode 100644 index 0000000..c3a0637 --- /dev/null +++ b/ghc/CONTRIB/pphs/docs/string2.hs @@ -0,0 +1,8 @@ +main = appendChan stdout "please type a filename\n" exit ( + readChan stdin exit (\ userInput -> + let (name : _) = lines userInput in + appendChan stdout name exit ( + readFile name (\ ioerror -> appendChan stdout + "can't open file" exit done) + (\ contents -> + appendChan stdout contents exit done)))) diff --git a/ghc/CONTRIB/pphs/pphs.c b/ghc/CONTRIB/pphs/pphs.c new file mode 100644 index 0000000..aa31a3e --- /dev/null +++ b/ghc/CONTRIB/pphs/pphs.c @@ -0,0 +1,1030 @@ + /* pphs - a pretty printer for Haskell code */ +#include +#include +#include +#define MAXLINELENGTH 256 + +enum face {KW, ID, IS, SU, ST, CO, NU, MA, SP, LC, RC, CR, BF, FQ, EQ, DQ, QD, EE, DC, DP, CP, LE, GE, LA, RA, RR, TI, BE}; + /* Possible values of typeface */ + +int widecolons = 0; /* User may want space between double colons */ +int subscripts = 0; /* User may want subscripts after '_' in identifiers */ +int tablength = 8; /* User's input file tablength */ + +typedef struct ElementType_Tag { /* Basic storage unit */ + char chars[MAXLINELENGTH]; /* Characters */ + enum face typeface[MAXLINELENGTH]; /* Typefaces */ + int indentation, length, col; /* Indentation level, non-empty length, column level */ +} ElementType; + +typedef struct StackNodeType_Tag *Link; /* Stack-related types */ +typedef struct StackNodeType_Tag { + ElementType Element; /* Stack item */ + Link Next; /* Link to next node */ +} StackNodeType; +typedef StackNodeType *StackNodePtr; +typedef StackNodePtr StackType; + +typedef int QueueSizeType; /* Queue-related types */ +typedef struct QueueNodeType_Tag *Connection; +typedef struct QueueNodeType_Tag { + ElementType Element; /* Queue item */ + Connection Next; /* Link to next node */ +} QueueNodeType; +typedef QueueNodeType *QueueNodePtr; +typedef struct QueueType_Tag { + QueueNodePtr Front, Rear; + QueueSizeType Length; +} QueueType; + +FILE *ifptr; /* input file pointer */ + + /* * * STACK FUNCTIONS * * */ +StackType + CreateStack() /* Returns an empty stack */ +{ + return(NULL); +} + +int + IsEmptyStack(s) /* Returns 1 if s is empty, 0 otherwise */ +StackType s; +{ + return(s == NULL); +} + +StackType + Push(s, x) /* Returns stack with x pushed onto s */ +StackType s; +ElementType x; +{ + StackType p; + + p = (StackNodeType *) malloc(sizeof(StackNodeType)); + if (p == NULL) { + fprintf(stderr, "pphs: Stack is too big\n"); + exit(3); + } + else { + (*p).Element = x; + (*p).Next = s; + return(p); + } +} + +ElementType + Top(s) /* Returns value of top element in s */ +StackType s; +{ + return((*s).Element); +} + +StackType + Pop(s) /* Returns stack with top element of s popped off */ +StackType s; +{ + StackType t; + + t = (*s).Next; + free(s); + return(t); +} + +StackType + PopSym(s) /* Returns stack with top element of s popped off without freeing */ +StackType s; +{ + StackType t; + + t = (*s).Next; +/* free(s); As PopSym is called within a function, free would free space needed later */ + return(t); +} + /* * * QUEUE FUNCTIONS * * */ +QueueType + CreateQueue() /* Returns an empty queue */ +{ + QueueType q; + + q.Front = NULL; + q.Rear = NULL; + q.Length = 0; + return(q); +} + +int + IsEmptyQueue(q) /* Returns 1 if q is empty, 0 otherwise */ +QueueType q; +{ + return(q.Front == NULL); +} + +int + LengthOfQueue(q) /* Returns length of q */ +QueueType q; +{ + return(q.Length); +} + +QueueNodePtr + FrontOfQueue(q) /* Returns pointer to front of q */ +QueueType q; +{ + return(q.Front); +} + +QueueNodePtr + RearOfQueue(q) /* Returns pointer to rear of q */ +QueueType q; +{ + return(q.Rear); +} + +QueueType + AddToQueue(q, x) /* Adds item x to rear of queue q */ +QueueType q; +ElementType x; +{ + QueueNodePtr p; + + p = (QueueNodeType *) malloc(sizeof(QueueNodeType)); + if (p == NULL) { + fprintf(stderr, "pphs: Queue is too big\n"); + exit(4); + } + else { + (*p).Element = x; + (*p).Next = NULL; + if (q.Front == NULL) + q.Front = p; + else + (*(q.Rear)).Next = p; + q.Rear = p; + q.Length++; + return(q); + } +} + +QueueType + TakeFromQueue(q) /* Removes front item from queue */ +QueueType q; +{ + QueueNodePtr p; + + if (q.Front == NULL) { + fprintf(stderr, "pphs: Stack underflow\n"); + exit(5); + } + else { + p = q.Front; + q.Front = (*(q.Front)).Next; + if (q.Front == NULL) + q.Rear = NULL; + q.Length--; + free(p); + return(q); + } +} + /* * * TYPEFACE FUNCTIONS * * */ +int + IsMathsChar(c) /* Returns 1 if c is a character to be in maths */ +char c; +{ + return((c == '[') || (c == ']') || (c == '/') || (c == ',') || (c == '!') + || (c == ':') || (c == ';') || (c == '(') || (c == ')') || (c == '&') + || (c == '#') || (c == '+') || (c == '-') || (c == '<') || (c == '>') + || (c == '{') || (c == '}') || (c == '=') || (c == '|') || (c == '\'') + || (c == '^')); +} + +ElementType + ChangeTypeface(store, length, finish, tf) /* Changes the typeface to tf in store + for length until finish */ +ElementType store; +int length, finish; +enum face tf; +{ + int counter; + + for (counter = (finish - length); counter < finish; counter++) + store.typeface[counter] = tf; + return(store); +} + +ElementType + CheckForDoubleChar(store, position) /* Checks for double character + in store.chars[position - 2..position - 1], + if found alters typeface */ +ElementType store; +int position; +{ + if ((position >= 2) && (store.typeface[position - 2] != DC)) { + if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '-')) { + store.typeface[position - 2] = LC; /* Haskell "--" line comment */ + store.typeface[position - 1] = LC; + } + else if ((store.chars[position - 2] == '{') && (store.chars[position - 1] == '-')) { + store.typeface[position - 2] = RC; /* Haskell "{-" regional comment begin */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '}')) { + store.typeface[position - 2] = CR; /* Haskell "-}" regional comment end */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '+') && (store.chars[position - 1] == '+')) { + store.typeface[position - 2] = DP; /* Double plus */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == ':') && (store.chars[position - 1] == '+')) { + store.typeface[position - 2] = CP; /* Colon plus */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '<') && (store.chars[position - 1] == '=')) { + store.typeface[position - 2] = LE; /* Less than or equal to */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '>') && (store.chars[position - 1] == '=')) { + store.typeface[position - 2] = GE; /* Greater than or equal to */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '<') && (store.chars[position - 1] == '-')) { + store.typeface[position - 2] = LA; /* Leftarrow */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '-') && (store.chars[position - 1] == '>')) { + store.typeface[position - 2] = RA; /* Rightarrow */ + store.typeface[position - 1] = DC; + } + else if ((store.chars[position - 2] == '=') && (store.chars[position - 1] == '>')) { + store.typeface[position - 2] = RR; /* Double rightarrow */ + store.typeface[position - 1] = DC; + } + else if (((store.chars[position - 2] == '*') && (store.chars[position - 1] == '*')) + || ((store.chars[position - 2] == '^') && (store.chars[position - 1] == '^'))) { + store.typeface[position - 2] = MA; /* Exponent, ie not Times */ + store.typeface[position - 1] = MA; + } + } + return(store); +} + +int + IsHaskellPunc(c) /* Returns 1 if c is a punctuation mark not part of identifier */ +char c; +{ + return((c == ' ') || (c == ',') || (c == '@') || (c == '#') || (c == '$') + || (c == '%') || (c == '&') || (c == '*') || (c == '(') || (c == ')') + || (c == '-') || (c == '+') || (c == '=') || (c == '\\') || (c == '|') + || (c == '[') || (c == ']') || (c == '{') || (c == '}') || (c == ':') + || (c == ';') || (c == '"') || (c == '~') || (c == '?') || (c == '/') + || (c == '<') || (c == '>') || (c == '^')); +} + +int + IsKeyWord(str) /* Returns 1 if str is a keyword to be in keyword font */ +char str[MAXLINELENGTH]; +{ + return((!(strcmp(str, "case"))) || (!(strcmp(str, "class"))) + || (!(strcmp(str, "data"))) || (!(strcmp(str, "default"))) + || (!(strcmp(str, "deriving"))) || (!(strcmp(str, "else"))) + || (!(strcmp(str, "hiding"))) || (!(strcmp(str, "if"))) + || (!(strcmp(str, "import"))) || (!(strcmp(str, "in"))) + || (!(strcmp(str, "infix"))) || (!(strcmp(str, "infixl"))) + || (!(strcmp(str, "infixr"))) || (!(strcmp(str, "instance"))) + || (!(strcmp(str, "interface"))) || (!(strcmp(str, "let"))) + || (!(strcmp(str, "module"))) || (!(strcmp(str, "of"))) + || (!(strcmp(str, "renaming"))) || (!(strcmp(str, "then"))) + || (!(strcmp(str, "to"))) || (!(strcmp(str, "type"))) + || (!(strcmp(str, "where")))); +} + +int + KeyWord(c, store, position) /* Returns length of keyword if a keyword ends + at store.chars[position - 1] */ +char c; +ElementType store; +int position; +{ + int counter, start, end = position - 1, keywordlen = 0; + char str[MAXLINELENGTH]; + + if ((!isalpha(c)) && (c != '_') && (c != '\'') && (position)) { + for (counter = end; (counter >= 0) && ((isalpha(store.chars[counter])) + || (c == '_') || (c == '\'')) + && (counter >= store.indentation); counter--) { + ; /* Just count letters */ + } + start = ++counter; + for (counter = 0; counter + start <= end; counter++) { + str[counter] = store.chars[counter + start]; /* Copy letters into str */ + } + str[counter] = '\0'; /* Add null character to end */ + if (IsKeyWord(str)) /* Checks word in str is keyword */ + keywordlen = strlen(str); /* and measures it */ + } + return(keywordlen); +} + +ElementType + CheckForKeyword(c, store, position) /* Returns store with any possible keyword + ending at store.chars[position - 1] + identified as such in store.typeface */ +char c; +ElementType store; +int position; +{ + if (KeyWord(c, store, position)) + store = ChangeTypeface(store, KeyWord(c, store, position), position, KW); + return(store); +} + +int + IsNumber(c, store, position, statesok) /* Returns 1 if c forms part of a number */ +char c; +ElementType store; +int position, statesok; +{ + int counter, foundident = 0, foundpunc = 0; + + if (((isdigit(c)) || (c == 'e') || (c == 'E') || (c == '|') || (c == '.')) + && (statesok)) { + counter = position - 1; + while ((isdigit(store.chars[counter])) && (counter >= 0)) + counter--; + if (((store.chars[counter] == '+') || (store.chars[counter] == '-')) + && ((store.chars[counter - 1] == 'e') || (store.chars[counter - 1] == 'E')) + && (counter > 2)) + counter -= 2; + else if (((store.chars[counter] == 'e') || (store.chars[counter] == 'E')) + && (counter > 1)) + counter--; + while ((isdigit(store.chars[counter])) && (counter >= 0)) + counter--; + if ((store.chars[counter] == '.') && (counter > 1)) + counter--; + while ((isdigit(store.chars[counter])) && (counter >= 0)) + counter--; + if ((isalpha(store.chars[counter])) && (counter >= 0)) + foundident = 1; /* ie not number */ + else if ((IsHaskellPunc(store.chars[counter])) || (counter < 0)) + foundpunc = 1; /* ie is number */ + } + return(foundpunc); +} + /* * * LINE SELECTION FUNCTIONS * * */ +ElementType + SelectSkipLine(s, store, linecounter) /* Returns store containing line for skipover */ +StackType s; +ElementType store; +int linecounter; +{ + ElementType temp; + int counter; + + if (!(IsEmptyStack(s))) { + while (((Top(s)).length <= linecounter) || ((Top(s)).indentation >= linecounter)) { + temp = Top(s); + s = PopSym(s); + if (IsEmptyStack(s)) { + counter = temp.length; + while (counter < linecounter) { + temp.chars[counter] = ' '; + temp.typeface[counter++] = SP; + } + temp.chars[counter] = '\0'; /* Add null character to end */ + s = Push(s, temp); + break; + } + } + store = Top(s); + } + else { /* Stack is empty */ + counter = store.length; + while (counter < linecounter) { + store.chars[counter] = ' '; + store.typeface[counter++] = SP; + } + store.chars[counter] = '\0'; /* Add null character to end */ + } + return(store); +} + /* * * STORING FUNCTIONS * * */ +ElementType + CreateStore() /* Returns an empty store */ +{ + ElementType store; + + strcpy(store.chars, ""); + store.length = 0; + store.indentation = 0; + store.col = 0; + return(store); +} + +ElementType + StoreSpace(store, position) /* Stores a space in the store at current position */ +ElementType store; +int position; +{ + store.chars[position] = ' '; + store.typeface[position] = SP; + return(store); +} + /* * * WRITING FUNCTIONS * * */ +void + WriteStartFace(tf) /* Writes LaTeX typeface commands for start of section */ +enum face tf; +{ + if (tf == KW) /* Keywords */ + printf("{\\keyword "); + else if ((tf == ID) || (tf == IS)) /* Identifiers */ + printf("{\\iden "); + else if (tf == ST) /* Strings */ + printf("{\\stri "); + else if (tf == CO) /* Comments */ + printf("{\\com "); + else if (tf == NU) /* Numbers */ + printf("{\\numb "); + else if ((tf == MA) || (tf == TI)) /* Various maths */ + printf("$"); +} + +void + WriteFinishFace(tf) /* Writes LaTeX typeface commands for end of section */ +enum face tf; +{ + if ((tf == KW) || (tf == ID) || (tf == ST) || (tf == CO) + || (tf == NU)) /* Keywords, identifiers, strings, comments or numbers */ + printf("\\/}"); + else if ((tf == MA) || (tf == TI)) /* Various maths */ + printf("$"); + else if (tf == IS) /* Subscripts in identifiers */ + printf("\\/}$"); +} + +int + WriteSpaces(store, counter, finish) /* Writes consecutive spaces, + returning new counter value */ +ElementType store; +int counter, finish; +{ + int spaces = 0; /* The number of spaces found */ + + for (; (store.typeface[counter] == SP) && (counter < finish); counter++) + spaces++; + printf("\\xspa{%d}", spaces); + return(--counter); +} + +int + WriteChar(store, counter, finish) /* Writes charater, returning new counter value */ +ElementType store; +int counter, finish; +{ + if (store.typeface[counter] == SP) /* Space */ + printf("\\xspa1"); /* Redundant */ + else if (store.typeface[counter] == BE) /* Bar under equals sign */ + printf("\\bareq"); + else if (store.typeface[counter] == DP) { /* Double plus */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("\\plusplus"); + counter++; + } + } + else if (store.typeface[counter] == CP) { /* Colon plus */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("{:}{+}"); + counter++; + } + } + else if (store.typeface[counter] == LE) { /* Less than or equal to */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("$\\leq$"); + counter++; + } + } + else if (store.typeface[counter] == GE) { /* Greater than or equal to */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("$\\geq$"); + counter++; + } + } + else if (store.typeface[counter] == LA) { /* Leftarrow */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("$\\leftarrow$"); + counter++; + } + } + else if (store.typeface[counter] == RA) { /* Rightarrow */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("$\\rightarrow$"); + counter++; + } + } + else if (store.typeface[counter] == RR) { /* Double rightarrow */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("$\\Rightarrow$"); + counter++; + } + } + else if (store.typeface[counter] == RC) { /* Regional comment begin */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("{\\com \\{-\\/}"); + counter++; + } + else + printf("{\\com \\{\\/}"); + } + else if (store.typeface[counter] == CR) { /* Regional comment end */ + if ((counter < finish - 1) && (store.typeface[counter + 1] == DC)) { + printf("{\\com -\\}\\/}"); + counter++; + } + else + printf("{\\com -\\/}"); + } + else if ((store.typeface[counter] == LC) && (store.chars[counter] == '-')) + printf("{\\rm -}"); /* Comment - problem: "--" becomes "-" in LaTeX so fix done */ + else if (store.chars[counter] == '\\') + printf("\\hbox{$\\setminus$}"); /* Backslash */ + else if (store.chars[counter] == '*') { + if (store.typeface[counter] == TI) + printf("\\times "); /* Multiplication */ + else + printf("*"); /* Other star symbols, eg Exponent */ + } + else if ((store.chars[counter] == '_') && (store.typeface[counter] == SU)) { + if ((counter < finish - 1) && (store.typeface[counter + 1] == IS)) + printf("$_"); /* Subscript character */ + } + else if (store.chars[counter] == '^') + printf("\\char'136 "); /* Up-arrow */ + else if (store.chars[counter] == '~') + printf("\\char'176 "); /* Tilda */ + else if ((store.chars[counter] == ':') && (store.chars[counter - 1] == ':') + && (widecolons)) + printf("\\,:"); /* Double colon */ + else if (store.chars[counter] == '"') { + if ((counter) && ((store.chars[counter - 1] == '"') + || (store.chars[counter - 1] == '\''))) + printf("\\,"); /* If previous character was a quote, leave a little space */ + if (store.typeface[counter] == DQ) + printf("{\\rm ``}"); /* Open doublequote */ + else if (store.typeface[counter] == QD) + printf("{\\rm \"}"); /* Close doublequote */ + else + printf("{\\rm \\char'175}"); /* Escape doublequote in string */ + } + else if (store.chars[counter] == '\'') { + if ((counter) && ((store.chars[counter - 1] == '"') + || ((store.chars[counter - 1] == '\'') + && ((store.typeface[counter - 1] != MA) + || (store.typeface[counter] != MA))))) + printf("\\,"); /* If previous character was a quote, leave a little space + except when it's a double prime */ + if (store.typeface[counter] == FQ) + printf("\\forquo "); /* Forward single quote */ + else if (store.typeface[counter] == EQ) + printf("\\escquo "); /* Escape single quote */ + else if (store.typeface[counter] == BF) { + if ((counter + 1 < store.length) && (store.typeface[counter + 1] == BF) + && (counter + 1 != store.indentation)) { + printf("{\\com \'\'\\/}"); /* Closing LaTeX style quote */ + counter++; + } + else + printf("{\\com \'\\/}"); /* Single quote following backquote in comment */ + } + else + printf("\'"); /* Prime */ + } + else if (store.chars[counter] == '{') + printf("\\hbox{$\\cal \\char'146$}"); /* Open curly bracket */ + else if (store.chars[counter] == '}') + printf("\\hbox{$\\cal \\char'147$}"); /* Close curly bracket */ + else if ((counter) && (store.chars[counter - 1] == '[') && (store.chars[counter] == ']')) + printf("\\,]"); /* Leave small gap between adjacent square brackets */ + else if ((store.chars[counter] == '$') || (store.chars[counter] == '%') + || (store.chars[counter] == '_') || (store.chars[counter] == '#') + || (store.chars[counter] == '&')) /* Various characters needing '\' for LaTeX */ + printf("\\%c", store.chars[counter]); + else /* Other characters */ + printf("%c", store.chars[counter]); + return(counter); +} + +void + WriteSkipover(store) /* Writes the skipover portion of line in store */ +ElementType store; +{ + int counter = 0; + + printf("\\skipover{"); /* Write opening LaTeX skipover command */ + WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ + if (store.typeface[counter] == SP) + counter = WriteSpaces(store, counter, store.indentation); /* Write spaces */ + else + counter = WriteChar(store, counter, store.indentation); /* Write character */ + for (counter++; counter < store.indentation; counter++){ /* until end of skipover */ + if (store.typeface[counter - 1] != store.typeface[counter]) { /* If typeface change */ + WriteFinishFace(store.typeface[counter - 1]); /* write closing typeface command */ + WriteStartFace(store.typeface[counter]); /* write opening LaTeX typeface command */ + } + if (store.typeface[counter] == SP) + counter = WriteSpaces(store, counter, store.indentation); /* Write spaces */ + else + counter = WriteChar(store, counter, store.indentation); /* Write character */ + } + if (store.typeface[counter - 1] == SU) + ; /* If indentation is under subscript don't open math section */ + else + WriteFinishFace(store.typeface[counter - 1]); /* Write closing LaTeX typeface command */ + printf("}"); /* Write closing LaTeX skipover command */ +} + +void + WriteWords(store) /* Writes rest of line, starting at indentation level */ +ElementType store; +{ + int counter = store.indentation; + int intabular = 0; /* Boolean: is in tabular section for internal alignment */ + + WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ + if (store.typeface[counter] == SP) + counter = WriteSpaces(store, counter, store.length); /* Write spaces */ + else + counter = WriteChar(store, counter, store.length); /* Write character */ + for (counter++; counter < store.length; counter++){ /* until end of word */ + if ((store.col) && (store.col == counter)) { + printf(" & "); + if (store.chars[counter - 1] == ':') + printf("$:"); + intabular = 1; + } + if (store.typeface[counter - 1] != store.typeface[counter]) /* If typeface change */ + WriteFinishFace(store.typeface[counter - 1]); /* Write closing typeface command */ + if ((store.typeface[counter] == SP) && (intabular)) { + printf(" & "); + intabular = 0; + } + if ((store.typeface[counter - 1] != store.typeface[counter]) /* If typeface change */ + && ((store.chars[counter] != ':') || (store.col != counter + 1))) + WriteStartFace(store.typeface[counter]); /* Write opening LaTeX typeface command */ + if (store.typeface[counter] == SP) + counter = WriteSpaces(store, counter, store.length); /* Write spaces */ + else if ((store.chars[counter] != ':') || (!store.col) || (store.col != counter + 1)) + counter = WriteChar(store, counter, store.length); /* Write character */ + } + WriteFinishFace(store.typeface[counter - 1]); /* Write closing LaTeX typeface command */ +} + +void + WriteLine(store, needed) /* Writes the line in store, + only writing LaTeX newline if needed */ +ElementType store; +int needed; +{ + if (store.indentation) + WriteSkipover(store); + if (store.indentation < store.length) + WriteWords(store); + if (needed) + printf("\\\\"); /* LaTeX newline character */ + printf("\n"); +} + +QueueType + WriteQueue(q) /* Writes lines, removing them from queue, + leaves last line in queue if not in tabular section */ +QueueType q; +{ + int intabular = 0; + + if ((!(IsEmptyQueue(q))) && ((*(FrontOfQueue(q))).Element.col)) { + printf("\\begin{tabular}{@{}l@{\\xspa1}c@{}l}\n"); + intabular = 1; + } + while (LengthOfQueue(q) > !intabular) { + WriteLine((*(FrontOfQueue(q))).Element, 1); /* LaTeX newline character is needed */ + q = TakeFromQueue(q); + } + if (intabular) + printf("\\end{tabular}\\\\\n"); + return(q); +} + +QueueType + WriteRestOfQueue(q) /* Writes all lines, removing them from queue, + doesn't have LaTeX newline after last line */ +QueueType q; +{ + int intabular = 0; + + if ((!(IsEmptyQueue(q))) && ((*(FrontOfQueue(q))).Element.col)) { + printf("\\begin{tabular}{@{}l@{\\xspa1}c@{}l}\n"); + intabular = 1; + } + while (!(IsEmptyQueue(q))) { + WriteLine((*(FrontOfQueue(q))).Element, (LengthOfQueue(q) > 1)); /* Last line doesn't + need LaTeX newline character */ + q = TakeFromQueue(q); + } + if (intabular) { + printf("\\end{tabular}"); + if (!IsEmptyQueue(q)) /* Last line doesn't need LaTeX newline character */ + printf("\\\\"); + printf("\n"); + } + return(q); +} + +int +main (argc, argv) /* * * MAIN PROGRAM * * */ + int argc; + char *argv[]; +{ + int tripped = 1, instring = 0, instringincomment = 0, inlinecomment = 0; + int incharquote = 0, incharquoteincomment = 0, inbackquoteincomment = 0; + int insub = 0; + /* Booleans - just taken new line, in string, in string inside comment, in line comment, + in character quote, in character quote inside comment, in backquote inside comment, + in subscript */ + int linecounter = 0, indentcounter = 0, inregcomment = 0, pos; + /* Counters: current position on line, indentation of current line, + nesting level of regional comments, position marker */ + char c; /* Character */ + StackType s; /* Stack of previous longest lines */ + QueueType q; /* Queue of lines waiting to be printed */ + ElementType store; /* Store of letters, typefaces and non-empty length */ + + if ((argc == 3) && (argv[1][0] == '-')) { /* If options specified with call */ + if (strstr(argv[1], "s")) /* if -s option, subscripts in identifiers wanted */ + subscripts = 1; + if (strstr(argv[1], "t")) { /* if -tX option, tab characters are X spaces */ + for (pos = 1; (argv[1][pos] != 't'); pos++) /* find 't' */ + ; + for (pos++, tablength = 0; isdigit(argv[1][pos]); pos++) /* read number */ + tablength = (tablength * 10) + (argv[1][pos] - '0'); + } + if (strstr(argv[1], "w")) /* if -w option called, wide double colons wanted */ + widecolons = 1; + } + else if (argc == 2) /* If no options */ + ; + else { /* If not called with pphs and a filename */ + fprintf(stderr, "pphs: Call with one file name\n"); + exit(1); + } + + if ((strcspn(argv[argc - 1], ".") == strlen(argv[argc - 1])) /* If filename has no extention */ + && ((ifptr = fopen(argv[argc - 1], "r")) == NULL)) /* and no plain file of that name */ + strcat(argv[argc - 1], ".hs"); /* add a ".hs" extention */ + if ((ifptr = fopen(argv[argc - 1], "r")) == NULL) { /* Open input file */ + fprintf(stderr, "pphs: File could not be opened\n"); /* eg isn't there */ + exit(2); + } + else { + + printf("\\begin{tabbing}\n"); /* Start of Haskell program */ + + store = CreateStore(); /* an empty one */ + s = CreateStack(); /* an empty one */ + q = CreateQueue(); /* an empty one */ + + fscanf(ifptr, "%c", &c); /* Read character */ + while (!feof(ifptr)) { /* While not at end of input file */ + while ((isspace(c)) && (!(feof(ifptr)))) { /* Read blank characters */ + if (c == ' ') { + if (tripped) + linecounter++; /* Count leading spaces */ + else { /* or */ + store = StoreSpace(store, linecounter++); /* Store intermediate + or trailing space */ + if (store.length < linecounter) + store.chars[linecounter] = '\0'; /* Add null character to end */ + } + fscanf(ifptr, "%c", &c); /* Read next character */ + } + else if (c == '\t') { + if (tripped) + linecounter += (tablength - (linecounter % tablength)); + else { + store = StoreSpace(store, linecounter++); + for (; linecounter % tablength; linecounter++) + store = StoreSpace(store, linecounter); + if (store.length < linecounter) + store.chars[linecounter] = '\0'; /* Add null character to end */ + } + fscanf(ifptr, "%c", &c); /* Read next character */ + } + else if (c == '\n') { + tripped = 1; /* Just taken a new line */ + inlinecomment = 0; + if (!(IsEmptyStack(s))) + while (((Top(s)).length <= store.length) + && ((Top(s)).indentation >= store.length)) { + s = Pop(s); + if (IsEmptyStack(s)) + break; + } + if (store.length > 0) { /* Push non-empty line onto indentation stack */ + store.indentation = indentcounter; + s = Push(s, store); + } + if (!(IsEmptyQueue(q))) { + if ((store.col != (*(FrontOfQueue(q))).Element.col) + || (!(*(FrontOfQueue(q))).Element.col)) + q = WriteQueue(q); /* If internal alignment changes or there is none + write out lines */ + } + q = AddToQueue(q, store); /* Add to writing queue */ + linecounter = 0; /* Get ready to count leading spaces */ + store.length = linecounter; + fscanf(ifptr, "%c", &c); /* Read next character */ + } + else break; + } + if (tripped) { + indentcounter = linecounter; + store.indentation = linecounter; + store.col = 0; + } + if ((tripped) && (linecounter)) { /* Skipover necessary for indentation */ + store = SelectSkipLine(s, store, linecounter); + store.indentation = linecounter; + store.col = 0; + } + if (!feof(ifptr)) + tripped = 0; /* No longer just taken new line */ + while ((!(isspace(c))) && (!(feof(ifptr)))) { /* Read word */ + if ((linecounter > 1) && (!IsEmptyQueue(q)) + && ((*(RearOfQueue(q))).Element.length >= linecounter) + && (linecounter > store.indentation) + && (linecounter > (*(RearOfQueue(q))).Element.indentation) + && (store.chars[linecounter - 1] == ' ') + && ((((*(RearOfQueue(q))).Element.chars[linecounter - 1] == ' ') + && ((c == (*(RearOfQueue(q))).Element.chars[linecounter]) + || ((c == '=') + && ((*(RearOfQueue(q))).Element.chars[linecounter] == ':') + && ((*(RearOfQueue(q))).Element.chars[linecounter + 1] == ':')))) + || (((*(RearOfQueue(q))).Element.chars[linecounter - 1] == ':') + && ((*(RearOfQueue(q))).Element.chars[linecounter] == ':') + && (c == '='))) + && ((store.chars[linecounter - 2] == ' ') + || ((*(RearOfQueue(q))).Element.chars[linecounter - 2] == ' ')) + && (((*(RearOfQueue(q))).Element.col == 0) + || ((*(RearOfQueue(q))).Element.col == linecounter))) { + store.col = linecounter; /* Identify any internal alignment */ + (*(RearOfQueue(q))).Element.col = linecounter; + } + if ((c == '"') && (!incharquote) /* String outside comments */ + && (!inregcomment) && (!inlinecomment)) { + if (((linecounter) && (store.chars[linecounter - 1] != '\\')) + || (!linecounter)) + instring = !instring; + } + else if ((c == '"') && (!incharquoteincomment) /* String inside comment */ + && (!inbackquoteincomment) + && ((inregcomment) || (inlinecomment))) { + if (((linecounter) && (store.chars[linecounter - 1] != '\\')) + || (!linecounter)) + instringincomment = !instringincomment; + } + else if ((c == '`') && ((inlinecomment) || (inregcomment))) { + if ((linecounter) && (store.chars[linecounter - 1] == '`')) + inbackquoteincomment = 2; /* Opening LaTeX style quote in comment */ + else + inbackquoteincomment = !inbackquoteincomment; /* Backquote in comment */ + } + else if ((linecounter) && (!inlinecomment) && (!instring)) { + if ((store.chars[linecounter - 1] == '{') && (c == '-')) + inregcomment++; /* Haskell "{-" regional comment begin */ + else if ((store.chars[linecounter - 1] == '-') && (c == '}')) { + inregcomment--; /* Haskell "-}" regional comment end */ + instringincomment = 0; + incharquoteincomment = 0; + inbackquoteincomment = 0; + } + } + if (c == '|') { + if ((!IsEmptyQueue(q)) + && ((((*(RearOfQueue(q))).Element.chars[linecounter] == '=') + && (linecounter == store.indentation)) + || ((*(RearOfQueue(q))).Element.typeface[linecounter] == BE))) + store.typeface[linecounter] = BE; + else + store.typeface[linecounter] = MA; + } + else if ((c == '\'') && (linecounter) && (store.chars[linecounter - 1] == '\\')) + store.typeface[linecounter] = EQ; /* Escape character quote */ + else if ((c == '\'') && (!instring) && (!inregcomment) && (!inlinecomment)) { + if (((linecounter) && (store.chars[linecounter - 1] != '\\') + && ((IsHaskellPunc(store.chars[linecounter - 1])) || (incharquote))) + || (!linecounter)) { + incharquote = !incharquote; + store.typeface[linecounter] = FQ; /* Character quote */ + } + else + store.typeface[linecounter] = MA; /* Prime */ + } + else if ((c == '\'') && (!instringincomment) + && ((inregcomment) || (inlinecomment))) { + if (((linecounter) && (store.chars[linecounter - 1] != '\\') + && ((IsHaskellPunc(store.chars[linecounter - 1])) + || (incharquoteincomment))) + || (!linecounter)) { + incharquoteincomment = !incharquoteincomment; + store.typeface[linecounter] = FQ; /* Character quote in comment */ + } + else if (inbackquoteincomment) { + inbackquoteincomment--; + store.typeface[linecounter] = BF; /* `x' character quote in comment */ + } + else + store.typeface[linecounter] = MA; /* Prime */ + } + else if (c == '"') { + if ((!incharquote) && (!incharquoteincomment) && (!inbackquoteincomment) + && ((instring) || (instringincomment))) { + if (((linecounter) && (store.chars[linecounter - 1] != '\\')) + || (!linecounter)) + store.typeface[linecounter] = DQ; /* Open doublequote */ + else if (store.chars[linecounter - 1] == '\\') + store.typeface[linecounter] = EE; /* Escape doublequote */ + } + else if ((!incharquote) && (!incharquoteincomment) && (!inbackquoteincomment)) { + if (((linecounter) && (store.chars[linecounter - 1] != '\\')) + || (!linecounter)) + store.typeface[linecounter] = QD; /* Close doublequote */ + else if (store.chars[linecounter - 1] == '\\') + store.typeface[linecounter] = EE; /* Escape doublequote */ + } + else + store.typeface[linecounter] = EE; /* Character quote of doublequote */ + } + else if (c == '`') { + if ((inlinecomment) || (inregcomment)) + store.typeface[linecounter] = CO; + else + store.typeface[linecounter] = MA; + } + else if ((linecounter) && (subscripts) && (c == '_') + && (store.typeface[linecounter - 1] == ID)) + store.typeface[linecounter] = SU; /* Subscript in identifier */ + else if (c == '*') + store.typeface[linecounter] = TI; /* Times - may be changed by double char */ + else if (IsMathsChar(c)) + store.typeface[linecounter] = MA; /* Maths characters */ + else if (IsNumber(c, store, linecounter, + ((!inregcomment) && (!instring) && (!inlinecomment)))) + store.typeface[linecounter] = NU; /* Numbers */ + else if ((instring) || (incharquote)) + store.typeface[linecounter] = ST; /* Characters in strings */ + else if ((inlinecomment) || (inregcomment)) + store.typeface[linecounter] = CO; /* Characters in comments */ + else { + if (insub) + store.typeface[linecounter] = IS; /* Subscript identifiers */ + else + store.typeface[linecounter] = ID; /* Others */ + } + if (linecounter) + if ((store.typeface[linecounter - 1] == IS) + && (store.typeface[linecounter] != IS)) + insub = 0; /* End of subscript identifier */ + store.chars[linecounter++] = c; /* Place character in store */ + if (linecounter > store.indentation + 1) + store = CheckForDoubleChar(store, linecounter); + if ((store.typeface[linecounter - 1] == LC) && (!inregcomment) + && (!instring) && (!incharquote)) { + instringincomment = 0; + incharquoteincomment = 0; + inbackquoteincomment = 0; + inlinecomment = 1; + } + else if ((store.typeface[linecounter - 1] == SU) + && (linecounter != store.indentation)) + insub = 1; + fscanf(ifptr, "%c", &c); /* Read next character */ + if (feof(ifptr)) + c = ' '; + if ((!inregcomment) && (!inlinecomment) && (!instring)) + store = CheckForKeyword(c, store, linecounter); /* Keywords not in comments or + strings to be in keyword typeface */ + } + insub = 0; + store.chars[linecounter] = '\0'; /* String terminating null character */ + store.length = linecounter; + } + if ((!tripped) && (!store.col)) /* If last line not in internal alignment */ + q = WriteQueue(q); /* write previous lines which might */ + if (!tripped) /* Put final line in queue if non-empty */ + q = AddToQueue(q, store); + if (feof(ifptr)) /* Write remaining lines */ + q = WriteRestOfQueue(q); + + printf("\\end{tabbing}\n"); /* End of Haskell program */ + + exit(0); + } +} diff --git a/ghc/Jmakefile b/ghc/Jmakefile new file mode 100644 index 0000000..e2d68ee --- /dev/null +++ b/ghc/Jmakefile @@ -0,0 +1,47 @@ +#define IHaveSubdirs + +MsubNeededHere( ./glue_TAGS_files ) + +/* order in SUBDIRS is not supposed to be important but ... + "compiler" must be before "lib", because we use + the compiler just built to compile pieces of "lib". + + "includes" also needs to be v early, to ensure that + GhcConstants.h is made before needed. + + if we're building from .hc files, we do the libraries + first, then the compiler; otherwise the other way around + +*/ +#if HaskellCompilerType == HC_USE_HC_FILES +#define __compiler_and_lib lib compiler +#else +#define __compiler_and_lib compiler lib +#endif + +SUBDIRS = includes \ + utils \ + driver \ + runtime \ + docs \ + __compiler_and_lib + +/*OUT: parsers */ + +#undef __compiler_and_lib + +/* "CONTRIB" is also a SUBDIR, but there is nothing to build there. + */ + +/* the standard "whoami" target will give the basic info. */ +/* this target adds to it. */ +whoami:: + @echo using a \`$(BUILDPLATFORM)\' host to build a Haskell compiler to run on a + @echo \`$(HOSTPLATFORM)\' host that will generate \`C\' target code + +fulltags : ./glue_TAGS_files + $(RM) ./TAGS + ./glue_TAGS_files `find . -type f -name TAGS -print` + +/* this line makes sure perl gets picked up from the right place */ +MsubProgramScriptTarget(PerlCmd,./glue_TAGS_files,./glue_TAGS_files.prl,,) diff --git a/ghc/Makefile.BOOT b/ghc/Makefile.BOOT new file mode 100644 index 0000000..8d0e797 --- /dev/null +++ b/ghc/Makefile.BOOT @@ -0,0 +1,59 @@ +# hand-hacked Makefile to boot the "make world" process +#--------------------------------------------------------------------- + +# Platform-specific configuration stuff was read from: sun.cf + +SHELL = /bin/sh +PATHSEP = / + +#******** NB: TOP setting +TOP = .. +CURRENT_DIR = ./ghc + +RM=rm -f +MV=mv -f +BOOTSTRAPCFLAGS = + +# Project identification -- name, version, and stuff + +PROJECTNAME = Booting the Make World System +PROJECTVERSION = none +PROJECTLABEL = generic +SETUPLABEL = std + +PROJECTCONFIGDIR = + +########################################################################### +# Configuration stuff (jmake, its friends and templates) + +JMKMF = jmkmf_used_only_with_installed_utils +JRESTOREDEPS = $(JMAKESRC)/jrestoredeps +JMAKE = $(JMAKESRC)/jmake +JMAKE_DEFINES = + +JMAKESRC = $(TOP)/mkworld + +JMAKE_CMD = $(NEWTOP)$(JMAKE) -I$(NEWTOP)$(JMAKESRC) $(BOOTSTRAPCFLAGS) -DTopDir=$(TOP) -DCurDir=$(CURRENT_DIR) $(BOOT_DEFINES) + +########################################################################### + +Makefile:: $(JMAKE) + +$(JMAKE): + @(cd $(JMAKESRC); if [ -f Makefile ]; then \ + echo "checking $@ in $(JMAKESRC) first..."; $(MAKE) all; else \ + echo "bootstrapping $@ from Makefile.BOOT in $(JMAKESRC) first..."; \ + $(MAKE) -f Makefile.BOOT BOOTSTRAPCFLAGS=$(BOOTSTRAPCFLAGS); fi; \ + echo "okay, continuing in $(CURRENT_DIR)") + +Makefile:: + -@if [ -f Makefile ]; then \ + echo " $(RM) Makefile.bak; $(MV) Makefile Makefile.bak"; \ + $(RM) Makefile.bak; $(MV) Makefile Makefile.bak; \ + else exit 0; fi + $(JMAKE_CMD) + $(JRESTOREDEPS) + @if cmp -s Makefile Makefile.bak; then $(RM) Makefile.bak ; else exit 0 ; fi + @chmod 444 Makefile + @echo ==== The new Makefile is for\: ==== + @$(MAKE) whoami diff --git a/ghc/PATCHLEVEL b/ghc/PATCHLEVEL new file mode 100644 index 0000000..4ea8e69 --- /dev/null +++ b/ghc/PATCHLEVEL @@ -0,0 +1 @@ +The Glamorous Glasgow Haskell Compiler, version 0.26, patchlevel 0 diff --git a/ghc/README b/ghc/README new file mode 100644 index 0000000..ccc3edb --- /dev/null +++ b/ghc/README @@ -0,0 +1,78 @@ +This is version 0.26 of the Glorious Glasgow Haskell compilation +system (GHC). This is a major public release. The top-level file +"ANNOUNCE-0.26" says more. + +Haskell is "the" standard lazy functional programming language [see +SIGPLAN Notices, May 1992]. Some general merits of GHC are given at +the end of this file. + +Documentation of interest: + +* docs/install_guide/installing.{dvi,info,html}: How to configure, + build, and install the system. + + The document, as with many others, is in TeX-produced DVI format + (.dvi suffix), or GNU Info format (.info); the latter is close to + plain ASCII, if that's what you want. + +* docs/users_guide/user.{dvi,info,html}: How to use GHC; e.g., what + options are available, how to cope with common problems, how to use + the profiling facilities, etc. + +* docs/release_notes/release{dvi,info,html}: Release notes for this + release (and all previous releases). + +* docs/README: About the other documentation in this release. + +We welcome your comments and suggestions about this software! Please +do not suffer or grumble in silence. The "bug reports" section of the +User's Guide (docs/users_guide/user.{dvi,info,html}) says what we +would like to know when you report a problem. + +Current AQUA team (all @dcs.glasgow.ac.uk): + + Sigbjorn Finne (sof) [PhD student] + Andy Gill (andy) [PhD student] + Kevin Hammond (kh) [GRASP; now a research fellow] + Simon Marlow (simonm) [PhD student] + Darren Moffat (moffatd) [slave, summer '95] + Will Partain (partain) [hired hand, GRASP/AQUA] + Simon Peyton Jones (simonpj) [our Fearless Leader] + Patrick Sansom (sansom) [hired hand, "Bidirectional Analyses"] + Andr\'e Santos (andre) [PhD student] + +Past contributors and/or continuing advisors: + Cordy Hall (cvh) [GRASP; now at Open University] + John Launchbury (jl) [AQUA; now at OGI] + Jim Mattson (mattson) [hired hand, AQUA; just moved to HP] + Bryan O'Sullivan (bos) [visiting slave, summer '94; at Sun] + Alastair Reid (areid) [GHCI god, now working at Yale] + Phil Wadler (wadler) [GRASP] + +Cool people who've let us use their machines: + hppa1.1-hp-hpux Sam Nelson, Stirling University + mips-sgi-irix5 Tim Niblett, Turing Institute, Glasgow + sparc-sun-solaris2 Durham University + +Simon's projects' acronyms: + GRIP ('87-'90): Graph reduction in parallel + GRASP ('90-'92): Graph reduction applications support project + AQUA ('93- ): Declarative systems architecture: a quantitative approach + +Dated: 95/07/24 + +GHC WWW page: http://www.dcs.glasgow.ac.uk/fp/software/ghc.html + +E-mail contacts: + glasgow-haskell-request@dcs.glasgow.ac.uk (general queries) + + glasgow-haskell-bugs@dcs.glasgow.ac.uk (bug reports mailing list) + glasgow-haskell-users@dcs.glasgow.ac.uk (users' mailing list) + + glasgow-haskell-bugs-request@... to join, send mail *here* + glasgow-haskell-users-request@... to join, send mail *here* + +Anonymous FTP site: ftp.dcs.glasgow.ac.uk:pub/haskell/glasgow. Mostly +mirrored by ftp.cs.chalmers.se and nebula.cs.yale.edu (same +directory). Also: src.doc.ic.ac.uk, in +computing/programming/languages/haskell/glasgow/. diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h new file mode 100644 index 0000000..ef14e63 --- /dev/null +++ b/ghc/compiler/HsVersions.h @@ -0,0 +1,178 @@ +#ifndef HSVERSIONS_H +#define HSVERSIONS_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) + +#endif + +#define MkInt I# +#define MkChar C# +#define MkArray _Array + +#ifdef __GLASGOW_HASKELL__ +#define TAG_ Int# +#define LT_ -1# +#define EQ_ 0# +#define GT_ 1# +#endif +#define GT__ _ + +#ifdef __HBC__ +#define IMPORT_Trace import Trace +#define BSCC(l) ( +#define ESCC ) +#else +#define IMPORT_Trace {--} +#define BSCC(l) (_scc_ l ( +#define ESCC )) +#endif + +-- these are overridable +#ifndef BIND +#define BIND case +#endif /* BIND */ +#ifndef _TO_ +#define _TO_ of { +#endif /* _TO_ */ +#ifndef BEND +#define BEND } +#endif /* BEND */ +#ifndef RETN +#define RETN {--} +#endif /* RETN */ +#ifndef RETN_TYPE +#define RETN_TYPE {--} +#endif /* RETN_TYPE */ + +#define COMMA , + +#ifdef DEBUG +#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else +#else +#define ASSERT(e) +#endif + +-- ToDo: ghci needs to load far too many bits of the backend because +-- this ATTACK_PRAGMA stuff encourages Utils.lhs to tell +-- everyone about everyone else. I guess we need to add some +-- more conditional stuff in. +#ifdef USE_ATTACK_PRAGMAS +#define IF_ATTACK_PRAGMAS(x) x +#else +#define IF_ATTACK_PRAGMAS(x) {--} +#endif + +#if GHCI +#define IF_GHCI(stuff) stuff +#else +#define IF_GHCI(stuff) {-nothing-} +#endif + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26 +#define trace _trace +#endif + +#if defined(__GLASGOW_HASKELL__) +#define FAST_INT Int# +#define ILIT(x) (x#) +#define IBOX(x) (I# (x)) +#define _ADD_ `plusInt#` +#define _SUB_ `minusInt#` +#define _MUL_ `timesInt#` +#define _DIV_ `divInt#` +#define _QUOT_ `quotInt#` +#define _NEG_ negateInt# +#define _EQ_ `eqInt#` +#define _LT_ `ltInt#` +#define _LE_ `leInt#` +#define _GE_ `geInt#` +#define _GT_ `gtInt#` + +#define FAST_BOOL Int# +#define _TRUE_ 1# +#define _FALSE_ 0# +#define _IS_TRUE_(x) ((x) `eqInt#` 1#) + +#else {- ! __GLASGOW_HASKELL__ -} + +#define FAST_INT Int +#define ILIT(x) (x) +#define IBOX(x) (x) +#define _ADD_ + +#define _SUB_ - +#define _MUL_ * +#define _DIV_ `div` +#define _QUOT_ `quot` +#define _NEG_ - +#define _EQ_ == +#define _LT_ < +#define _LE_ <= +#define _GE_ >= +#define _GT_ > + +#define FAST_BOOL Bool +#define _TRUE_ True +#define _FALSE_ False +#define _IS_TRUE_(x) (x) + +#endif {- ! __GLASGOW_HASKELL__ -} + +#if __GLASGOW_HASKELL__ >= 23 +#define USE_FAST_STRINGS 1 +#define FAST_STRING _PackedString +#define SLIT(x) (_packCString (A# x#)) +#define _CMP_STRING_ cmpPString +#define _NULL_ _nullPS +#define _NIL_ _nilPS +#define _CONS_ _consPS +#define _HEAD_ _headPS +#define _TAIL_ _tailPS +#define _LENGTH_ _lengthPS +#define _PK_ _packString +#define _UNPK_ _unpackPS +#define _SUBSTR_ _substrPS +#define _APPEND_ `_appendPS` +#define _CONCAT_ _concatPS +#else +#define FAST_STRING String +#define SLIT(x) (x) +#define _CMP_STRING_ cmpString +#define _NULL_ null +#define _NIL_ "" +#define _CONS_ (:) +#define _HEAD_ head +#define _TAIL_ tail +#define _LENGTH_ length +#define _PK_ (\x->x) +#define _UNPK_ (\x->x) +#define _SUBSTR_ substr{-from Utils-} +#define _APPEND_ ++ +#define _CONCAT_ concat +#endif + +#if __HASKELL1__ < 3 +{- To avoid confusion with Haskell 1.3, we use Swahili. + + data Maybe a = Nothing | Just a + data Labda a = Hamna | Ni a + + Should we ever need to increase confusion with HBC, we will + use Swedish: + + data Kanske a = Ingenting | Bara a +-} +# define Maybe Labda +# define Just Ni +# define Nothing Hamna +#else +# define MAYBE Labda +# define JUST Ni +# define NOTHING Hamna +#endif + +#endif diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile new file mode 100644 index 0000000..6d8f4c0 --- /dev/null +++ b/ghc/compiler/Jmakefile @@ -0,0 +1,1355 @@ +/* preliminaries */ + +/* (only subdir is the test suite) */ + +#if IncludeTestDirsInBuild == YES +# define IHaveSubdirs + +# define __ghc_compiler_tests_dir tests +#else +# define __ghc_compiler_tests_dir /* nothing */ +#endif +SUBDIRS = __ghc_compiler_tests_dir +#undef __ghc_compiler_tests_dir +/* ?????? ToDo: something about test dirs underneath yaccParser ????? */ + +#if BuildDataParallelHaskell != YES + /* DPH likes to play around in subdirs */ +# define NoAllTargetForSubdirs +# define NoDocsTargetForSubdirs +# define NoInstallDocsTargetForSubdirs +# define NoDependTargetForSubdirs +#endif + /* these always apply */ +# define NoInstallTargetForSubdirs +#define NoTagTargetForSubdirs + +/* Suffix rules: we do not use them much at all in GHC. + We need some magic stuff (from suffixes-GEN.ljm) for + the parser files. +*/ +SuffixRules_flexish() +SuffixRule_c_o() +LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */ + +/* assume ALL source is in subdirectories one level below + they don't have Jmakefiles; this Jmakefile controls everything +*/ + +SUBDIR_LIST = \ /* here they are, colon separated (for mkdependHS) */ +utils:basicTypes:uniType:abstractSyn:prelude:envs:rename:typecheck:deSugar:coreSyn:specialise:simplCore:stranal:stgSyn:simplStg:codeGen:nativeGen:absCSyn:main:reader:profiling:deforest:podizeCore:yaccParser:nhcParser:interpreter + +DASH_I_SUBDIR_LIST = \ /* same thing, in -I format */ +-Iutils -IbasicTypes -IuniType -IabstractSyn -Iprelude -Ienvs -Irename -Itypecheck -IdeSugar -IcoreSyn -Ispecialise -IsimplCore -Istranal -IstgSyn -IsimplStg -IcodeGen -InativeGen -IabsCSyn -Imain -Ireader -Iprofiling -Ideforest -IpodizeCore -IyaccParser -InhcParser -Iinterpreter + +#ifdef MainIncludeDir +MAIN_INCLUDE_DIR=MainIncludeDir +#else +MAIN_INCLUDE_DIR=$(TOP_PWD)/$(CURRENT_DIR)/$(GHC_INCLUDES) +#endif + +/* helps to find GhcConstants.h in codeGen/CgCompInfo.lhs */ +#ifdef CompInfoDir +COMPINFO_DIR=CompInfoDir +#else +COMPINFO_DIR=$(TOP_PWD)/$(CURRENT_DIR)/codeGen +#endif +/* nativeGen, elsewhere */ +#ifdef NativeGenDir +NATIVEGEN_DIR=NativeGenDir +#else +NATIVEGEN_DIR=$(TOP_PWD)/$(CURRENT_DIR)/nativeGen +#endif + +/* in order-of-passes order, utility modules at the end */ + +#if GhcBuilderVersion >= 23 && GhcBuildeeVersion >= 23 +# define USE_NEW_READER YES +# define __new_reader_flag -DUSE_NEW_READER=1 +#else +# define __new_reader_flag /*none*/ +#endif +#if USE_NEW_READER == YES +# define READERSRCS_HS \ +yaccParser/U_atype.hs \ +yaccParser/U_binding.hs \ +yaccParser/U_coresyn.hs \ +yaccParser/U_entidt.hs \ +yaccParser/U_finfot.hs \ +yaccParser/U_hpragma.hs \ +yaccParser/U_list.hs \ +yaccParser/U_literal.hs \ +yaccParser/U_pbinding.hs \ +yaccParser/U_treeHACK.hs \ +yaccParser/U_ttype.hs +#define READERSRCS_LHS \ +yaccParser/UgenUtil.lhs \ +yaccParser/UgenAll.lhs \ +reader/ReadPrefix2.lhs \ +reader/ReadPragmas2.lhs +#define hsp_library libhsp.a +#else +#define READERSRCS_HS /* none */ +#define READERSRCS_LHS \ +reader/ReadPrefix.lhs \ +reader/ReadPragmas.lhs +#define hsp_library /*none*/ +#endif + +#define FRONTSRCS_LHS \ +reader/PrefixSyn.lhs \ +reader/PrefixToHs.lhs \ +\ +basicTypes/Unique.lhs \ +basicTypes/SplitUniq.lhs \ +basicTypes/ProtoName.lhs \ +basicTypes/NameTypes.lhs \ +basicTypes/SrcLoc.lhs \ +basicTypes/Id.lhs \ +basicTypes/IdInfo.lhs \ +basicTypes/Inst.lhs \ +basicTypes/BasicLit.lhs \ +basicTypes/CLabelInfo.lhs \ +basicTypes/OrdList.lhs \ +\ +uniType/TyVar.lhs \ +uniType/TyCon.lhs \ +uniType/Class.lhs \ +uniType/UniType.lhs \ +uniType/UniTyFuns.lhs \ +uniType/AbsUniType.lhs \ +\ +abstractSyn/Name.lhs /* abstract Haskell syntax */ \ +abstractSyn/HsCore.lhs \ +abstractSyn/HsPragmas.lhs \ +abstractSyn/HsImpExp.lhs \ +abstractSyn/HsDecls.lhs \ +abstractSyn/HsBinds.lhs \ +abstractSyn/HsMatches.lhs \ +abstractSyn/HsLit.lhs \ +abstractSyn/HsExpr.lhs \ +abstractSyn/HsPat.lhs \ +abstractSyn/HsTypes.lhs \ +abstractSyn/AbsSyn.lhs \ +abstractSyn/AbsSynFuns.lhs \ +\ +rename/Rename.lhs \ +rename/Rename1.lhs \ +rename/Rename2.lhs \ +rename/Rename3.lhs \ +rename/Rename4.lhs \ +rename/RenameAuxFuns.lhs \ +rename/RenameMonad12.lhs \ +rename/RenameMonad3.lhs \ +rename/RenameMonad4.lhs \ +rename/RenameBinds4.lhs \ +rename/RenameExpr4.lhs + +#define TCSRCS_LHS \ +prelude/PrelFuns.lhs \ +prelude/PrimKind.lhs \ +prelude/PrimOps.lhs \ +prelude/TysPrim.lhs \ +prelude/TysWiredIn.lhs \ +prelude/PrelVals.lhs \ +prelude/AbsPrel.lhs \ +\ +envs/IdEnv.lhs \ +envs/TyVarEnv.lhs \ +envs/LIE.lhs \ +envs/CE.lhs \ +envs/E.lhs \ +envs/InstEnv.lhs \ +envs/TCE.lhs \ +envs/TVE.lhs \ +\ +typecheck/BackSubst.lhs \ +typecheck/Disambig.lhs \ +typecheck/GenSpecEtc.lhs \ +typecheck/Spec.lhs \ +typecheck/Subst.lhs \ +typecheck/TcBinds.lhs \ +typecheck/TcClassDcl.lhs \ +typecheck/TcClassSig.lhs \ +typecheck/TcConDecls.lhs \ +typecheck/TcContext.lhs \ +typecheck/TcDefaults.lhs \ +typecheck/TcDeriv.lhs \ +typecheck/TcExpr.lhs \ +typecheck/TcGRHSs.lhs \ +typecheck/TcGenDeriv.lhs \ +typecheck/TcIfaceSig.lhs \ +typecheck/TcInstDcls.lhs \ +typecheck/TcMatches.lhs \ +typecheck/TcModule.lhs \ +typecheck/TcMonad.lhs \ +typecheck/TcMonadFns.lhs \ +typecheck/TcMonoBnds.lhs \ +typecheck/TcMonoType.lhs \ +typecheck/TcPat.lhs \ +typecheck/TcPolyType.lhs \ +typecheck/TcPragmas.lhs \ +typecheck/TcQuals.lhs \ +typecheck/TcSimplify.lhs \ +typecheck/TcTyDecls.lhs \ +typecheck/Typecheck.lhs \ +typecheck/Unify.lhs + +#define DSSRCS_LHS \ +coreSyn/AnnCoreSyn.lhs \ +coreSyn/CoreSyn.lhs \ +coreSyn/PlainCore.lhs \ +coreSyn/TaggedCore.lhs \ +coreSyn/CoreFuns.lhs \ +coreSyn/CoreUnfold.lhs \ +coreSyn/FreeVars.lhs \ +coreSyn/CoreLift.lhs \ +coreSyn/CoreLint.lhs \ +\ +deSugar/Desugar.lhs \ +deSugar/Match.lhs \ +deSugar/MatchCon.lhs \ +deSugar/MatchLit.lhs \ +deSugar/DsBinds.lhs \ +deSugar/DsCCall.lhs \ +deSugar/DsExpr.lhs \ +deSugar/DsGRHSs.lhs \ +deSugar/DsListComp.lhs \ +deSugar/DsMonad.lhs \ +deSugar/DsUtils.lhs \ +\ +specialise/Specialise.lhs \ +specialise/SpecTyFuns.lhs \ +\ +simplCore/SimplCase.lhs \ +simplCore/SimplEnv.lhs \ +simplCore/SimplMonad.lhs \ +simplCore/SimplPgm.lhs \ +simplCore/SimplUtils.lhs \ +simplCore/SimplVar.lhs \ +simplCore/Simplify.lhs \ +\ +simplCore/LiberateCase.lhs \ +\ +simplCore/BinderInfo.lhs \ +simplCore/ConFold.lhs \ +simplCore/FloatIn.lhs \ +simplCore/FloatOut.lhs \ +simplCore/MagicUFs.lhs \ +simplCore/SAT.lhs \ +simplCore/SATMonad.lhs \ +simplCore/SetLevels.lhs \ +simplCore/SimplCore.lhs \ +simplCore/OccurAnal.lhs \ +simplCore/NewOccurAnal.lhs \ +simplCore/FoldrBuildWW.lhs \ +simplCore/AnalFBWW.lhs \ +\ +stranal/StrictAnal.lhs \ +stranal/SaLib.lhs \ +stranal/SaAbsInt.lhs \ +stranal/WwLib.lhs \ +stranal/WorkWrap.lhs \ +\ +profiling/SCCauto.lhs \ +profiling/SCCfinal.lhs \ +profiling/CostCentre.lhs + +#if UseSemantiqueStrictnessAnalyser != YES +#define SEM_STRANAL_SRCS_LHS /* omit */ +#else +#define SEM_STRANAL_SRCS_LHS \ +stranal-sem/AFE.lhs \ +stranal-sem/AbsVal.lhs \ +stranal-sem/AssocPair.lhs \ +stranal-sem/BuildAFE.lhs \ +stranal-sem/ConstrEnv.lhs \ +stranal-sem/Cycles.lhs \ +stranal-sem/FG.lhs \ +stranal-sem/FourProj.lhs \ +stranal-sem/OAL.lhs \ +stranal-sem/OAT.lhs \ +stranal-sem/OL.lhs \ +stranal-sem/ProgEnv.lhs \ +stranal-sem/ProjBasic.lhs \ +stranal-sem/ProjFactor.lhs \ +stranal-sem/ProjFolds.lhs \ +stranal-sem/ProjGets.lhs \ +stranal-sem/ProjLubAnd.lhs \ +stranal-sem/REL.lhs \ +stranal-sem/StrAnal.lhs \ +stranal-sem/StrAnn.lhs \ +stranal-sem/StrAnnCore.lhs \ +stranal-sem/StrAnnUtil.lhs \ +stranal-sem/StrTypeEnv.lhs \ +stranal-sem/Transformer.lhs \ +stranal-sem/Tree.lhs +#endif /* UseSemantiqueStrictnessAnalyser */ + +#if GhcWithDeforester != YES +#define __omit_deforester_flag -DOMIT_DEFORESTER=1 +#define DEFORESTER_SRCS_LHS /*none*/ +#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 */ + +#if BuildGHCI != YES +#define __build_ghci_flag /*nope*/ +#define NHCSRCS_LHS /* omit */ +#define GHCISRCS_LHS /* omit */ +#else +#define __build_ghci_flag -DBUILD_GHCI=1 +#define NHCSRCS_LHS \ +nhcParser/Parse.lhs \ +nhcParser/ParseCore.lhs \ +nhcParser/ParseLib.lhs \ +nhcParser/ParseLex.lhs \ +nhcParser/PPSyntax.lhs \ +nhcParser/PPLib.lhs \ +nhcParser/Lexical.lhs \ +nhcParser/Lex.lhs \ +nhcParser/LexPre.lhs \ +nhcParser/LexStr.lhs \ +nhcParser/HS.lhs \ +nhcParser/MkSyntax.lhs \ +nhcParser/SyntaxPos.lhs \ +nhcParser/Syntax.lhs \ +nhcParser/Extra.lhs \ +nhcParser/ScopeLib.lhs \ +nhcParser/Import.lhs \ +nhcParser/AttrLib.lhs \ +nhcParser/Attr.lhs \ +nhcParser/NHCName.lhs \ +nhcParser/NameLow.lhs \ +nhcParser/ParseI.lhs \ +nhcParser/Tree234.lhs \ +nhcParser/MergeSort.lhs \ +nhcParser/StrName.lhs \ +nhcParser/NameLib.lhs \ +nhcParser/OsOnly.lhs \ +nhcParser/Flags.lhs \ +nhcParser/Fixity.lhs \ +nhcParser/StrSyntax.lhs \ +nhcParser/Either.lhs \ +nhcParser/ListUtil.lhs \ +nhcParser/NHCPackedString.lhs \ +nhcParser/HbcOnly.lhs \ +nhcParser/LexLow.lhs + +/* Bits we don't need after all. ToDo: delete their source... +nhcParser/IName.lhs \ +nhcParser/IExtract.lhs \ +nhcParser/Error.lhs \ +nhcParser/BindLib.lhs \ +nhcParser/BindI.lhs +*/ + +#define GHCISRCS_LHS \ +interpreter/ToPrefix.lhs \ +interpreter/UnsafeCoerce.lhs \ +interpreter/Dynamic.lhs \ +interpreter/Interpreter.lhs \ +interpreter/MkInterface.lhs \ +interpreter/GHCIMonad.lhs \ +interpreter/FullEnv.lhs \ +interpreter/Command.lhs \ +interpreter/GHCIFlags.lhs \ +interpreter/GHCInterface.lhs \ +interpreter/GHCI.lhs \ +interpreter/GHCICore.lhs \ +interpreter/Dld.lhs + +/* ToDo: mkworld-ify */ +DLD_DIR = ./dld +DLD_LIB = $(DLD_DIR)/libdld.a +DLD_INCLUDE = $(DLD_DIR)/dld.h + +DLD_OBJS_O = \ + dld/dld.o \ + dld/find_exec.o \ + dld/define.o \ + dld/get_func.o \ + dld/get_symbol.o \ + dld/list_undef.o \ + dld/mk_dummy.o \ + dld/ref.o \ + dld/ul_file.o \ + dld/ul_symbol.o \ + dld/remove.o \ + dld/error.o + +#endif /* BuildGHCI */ + +#define BACKSRCS_LHS \ +stgSyn/CoreToStg.lhs \ +stgSyn/StgSyn.lhs \ +stgSyn/StgFuns.lhs \ +stgSyn/StgLint.lhs \ +\ +simplStg/SatStgRhs.lhs \ +simplStg/LambdaLift.lhs \ +simplStg/StgVarInfo.lhs \ +simplStg/UpdAnal.lhs \ +simplStg/StgStats.lhs \ +simplStg/StgSATMonad.lhs \ +simplStg/StgSAT.lhs \ +simplStg/SimplStg.lhs \ +\ +absCSyn/AbsCSyn.lhs \ +absCSyn/Costs.lhs \ +absCSyn/HeapOffs.lhs \ +absCSyn/AbsCFuns.lhs \ +absCSyn/PprAbsC.lhs \ +\ +codeGen/CodeGen.lhs \ +codeGen/ClosureInfo.lhs \ +codeGen/SMRep.lhs \ +codeGen/CgConTbls.lhs \ +codeGen/CgCompInfo.lhs \ +codeGen/CgMonad.lhs \ +codeGen/CgUsages.lhs \ +codeGen/CgHeapery.lhs \ +codeGen/CgStackery.lhs \ +codeGen/CgExpr.lhs \ +codeGen/CgCase.lhs \ +codeGen/CgLetNoEscape.lhs \ +codeGen/CgTailCall.lhs \ +codeGen/CgClosure.lhs \ +codeGen/CgCon.lhs \ +codeGen/CgRetConv.lhs \ +codeGen/CgBindery.lhs \ +codeGen/CgUpdate.lhs + +#if GhcWithNativeCodeGen == NO || GhcWithHscBuiltViaC == YES + /* if building via C, we *assume* that it is the + distributed C files, which do not have a native-code + generator in them + */ +#define __omit_ncg_maybe -DOMIT_NATIVE_CODEGEN=1 +#define NATIVEGEN_SRCS_LHS /*none*/ +#else +#define __omit_ncg_maybe /*none*/ +#if sparc_TARGET_ARCH +#define __machdep_nativegen_lhs \ +nativeGen/SparcDesc.lhs \ +nativeGen/SparcCode.lhs \ +nativeGen/SparcGen.lhs +#define __ghci_machdep_nativegen_lhs \ +nativeGen/SparcCode.lhs +#else +#define __machdep_nativegen_lhs \ +nativeGen/AlphaDesc.lhs \ +nativeGen/AlphaCode.lhs \ +nativeGen/AlphaGen.lhs +#define __ghci_machdep_nativegen_lhs \ +nativeGen/AlphaCode.lhs +#endif + +#define NATIVEGEN_SRCS_LHS \ +nativeGen/AbsCStixGen.lhs \ +nativeGen/AsmCodeGen.lhs \ +nativeGen/AsmRegAlloc.lhs \ +nativeGen/MachDesc.lhs \ +nativeGen/Stix.lhs \ +nativeGen/StixInfo.lhs \ +nativeGen/StixInteger.lhs \ +nativeGen/StixPrim.lhs \ +nativeGen/StixMacro.lhs \ +__machdep_nativegen_lhs /*arch-specific ones */ +#endif + +#define UTILSRCS_LHS \ +utils/CharSeq.lhs \ +utils/Bag.lhs \ +utils/Pretty.lhs \ +utils/Unpretty.lhs \ +utils/Maybes.lhs \ +utils/Digraph.lhs \ +utils/BitSet.lhs \ +utils/LiftMonad.lhs \ +utils/ListSetOps.lhs \ +utils/Outputable.lhs \ +utils/FiniteMap.lhs \ +utils/UniqFM.lhs \ +utils/UniqSet.lhs \ +utils/Util.lhs + +#if BuildDataParallelHaskell != YES +#define DPH_SRCS_LHS /*none*/ +#else +#define DPH_SRCS_LHS \ +\ +typecheck/TcParQuals.lhs \ +deSugar/DsParZF.lhs \ +deSugar/MatchProc.lhs \ +prelude/ClsPid.lhs \ +prelude/ClsProc.lhs \ +prelude/TyPod.lhs \ +prelude/TyProcs.lhs \ +\ +podizeCore/PodInfoTree.lhs \ +podizeCore/PodInfoMonad.lhs \ +podizeCore/PodInfo1.lhs \ +podizeCore/PodInfo2.lhs \ +podizeCore/PodizeMonad.lhs \ +podizeCore/PodizePass0.lhs \ +podizeCore/PodizePass1.lhs \ +podizeCore/PodizePass2.lhs \ +podizeCore/PodizeCore.lhs +#endif /* DPH */ + +#define MAIN_SRCS_LHS \ +main/MkIface.lhs \ +main/ErrUtils.lhs \ +main/ErrsRn.lhs \ +main/ErrsTc.lhs \ +main/Errors.lhs \ +main/MainMonad.lhs \ +main/CmdLineOpts.lhs \ +main/Main.lhs + +ALLSRCS_HS = READERSRCS_HS +ALLSRCS_LHS = /* all pieces of the compiler */ \ +READERSRCS_LHS \ +FRONTSRCS_LHS \ +TCSRCS_LHS \ +DSSRCS_LHS \ +BACKSRCS_LHS \ +MAIN_SRCS_LHS \ +UTILSRCS_LHS NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS SEM_STRANAL_SRCS_LHS DPH_SRCS_LHS NHCSRCS_LHS GHCISRCS_LHS +/* NB: all the ones that may be empty (e.g., DPH_SRCS_LHS) + need to be on the last line. +*/ + +HSCSRCS_HS = READERSRCS_HS +HSCSRCS_LHS = /* all pieces of the compiler */ \ +READERSRCS_LHS \ +FRONTSRCS_LHS \ +TCSRCS_LHS \ +DSSRCS_LHS \ +BACKSRCS_LHS \ +MAIN_SRCS_LHS \ +UTILSRCS_LHS NATIVEGEN_SRCS_LHS DEFORESTER_SRCS_LHS SEM_STRANAL_SRCS_LHS DPH_SRCS_LHS + +/* +As well as the obvious inclusions, there are a few non-obvious ones +obtained from the transitive closure: + +* main/Errors.lhs andmain/CmdLineOpts.lhs are actually used. + +* most of the rest trickles in through the prelude. + +ToDo: hack around in the prelude to avoid all this... + +*/ + +GHCISRCS = /* all pieces of the interpreter */ \ +FRONTSRCS_LHS \ +TCSRCS_LHS \ +DSSRCS_LHS \ +main/Errors.lhs \ +main/ErrUtils.lhs \ +main/ErrsRn.lhs \ +main/ErrsTc.lhs \ +main/CmdLineOpts.lhs \ +main/MainMonad.lhs \ +absCSyn/HeapOffs.lhs \ +codeGen/SMRep.lhs \ +codeGen/CgCompInfo.lhs \ +codeGen/ClosureInfo.lhs \ +codeGen/CgRetConv.lhs \ +absCSyn/AbsCSyn.lhs \ +codeGen/CgMonad.lhs \ +absCSyn/AbsCFuns.lhs \ +codeGen/CgBindery.lhs \ +codeGen/CgUsages.lhs \ +absCSyn/Costs.lhs \ +absCSyn/PprAbsC.lhs \ +stgSyn/StgSyn.lhs \ +nativeGen/AsmRegAlloc.lhs __ghci_machdep_nativegen_lhs \ +UTILSRCS_LHS SEM_STRANAL_SRCS_LHS DEFORESTER_SRCS_LHS NHCSRCS_LHS GHCISRCS_LHS + + +/* should't use these fancy `make' things, really */ +ALLOBJS=$(ALLSRCS_LHS:.lhs=.o) $(ALLSRCS_HS:.hs=.o) +ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi) + +HSCOBJS=$(HSCSRCS_LHS:.lhs=.o) $(HSCSRCS_HS:.hs=.o) +HSCINTS=$(HSCSRCS_LHS:.lhs=.hi) $(HSCSRCS_HS:.hs=.hi) + +GHCIOBJS=$(GHCISRCS:.lhs=.o) interpreter/DldHacks.o interpreter/DldC.o interpreter/prelude.o interpreter/runtime.o +GHCIINTS=$(GHCISRCS:.lhs=.hi) interpreter/Dldhacks.hi + +.PRECIOUS: $(ALLINTS) + +#if GhcWithHscDebug == YES +# define use_DDEBUG -DDEBUG +#else +# define use_DDEBUG /*nothing*/ +#endif + +#if HaskellCompilerType == HC_CHALMERS_HBC + +HC_OPTS = -D__HASKELL1__=2 -M -H12m -DCOMPILING_GHC use_DDEBUG -I. -i$(SUBDIR_LIST) + +/* ToDo: else something for Niklas Rojemo's NHC (not yet) */ + +#else /* assume we either have GlasgowHaskell or are booting from .hc C files */ + +#if GhcWithHscOptimised == YES +#define __version_sensitive_flags -DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs -fomit-reexported-instances -fshow-import-specs +#else +#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 /**/ + +HC_OPTS = -cpp -H12m HcMaxHeapFlag -fglasgow-exts -DCOMPILING_GHC \ + -fomit-derived-read \ + -I. -i$(SUBDIR_LIST) \ + use_DDEBUG __version_sensitive_flags __unreg_opts_maybe __omit_ncg_maybe __new_reader_flag __build_ghci_flag __omit_deforester_flag + +#undef __version_sensitive_flags +#undef __unreg_opts_maybe +#undef __omit_ncg_maybe +#undef __new_reader_flag +#undef __build_ghci_flag +#undef __omit_deforester_flag + +#if GhcWithHscBuiltViaC == YES /* not using a Haskell compiler */ + +HSCHCS=$(HSCSRCS_LHS:.lhs=.hc) $(HSCSRCS_HS:.hs=.hc) +hcs:: $(HSCHCS) + +#if HaskellCompilerType == HC_USE_HC_FILES +HC = $(GHC) /* uses the driver herein */ +#endif + +#endif /* using .hc files */ +#endif /* not using HBC */ + +/* + -DCOMPILING_GHC + we're compiling the compiler with itself; clear enough? + Only used at present to ask for SPECIALIZEd functions + in modules that are allegedly "generic" (e.g., FiniteMap). + + -DUSE_SEMANTIQUE_STRANAL + to include the Semantique strictness analyser into the compiler + [probably quite moth-eaten by now 94/05 (WDP)] + + -DDPH compiling Jon Hill's "data parallel Haskell" + + (there are more, as yet unlisted WDP 94/12) +*/ +#if UseSemantiqueStrictnessAnalyser == YES +STRANAL_SEM_P = -DUSE_SEMANTIQUE_STRANAL +#endif + +#if BuildDataParallelHaskell == YES +DPH_P = -DDPH +#endif + +#if GhcUseSplittableUniqueSupply == YES +/* ToDo: delete? */ +SPLIT_P = -DUSE_SPLITTABLE_UNIQUESUPPLY +#endif + +GHC_EXTRA_DEFINES = $(STRANAL_SEM_P) $(DPH_P) $(SPLIT_P) + +#if USE_NEW_READER == YES +BuildPgmFromHaskellModules(hsc,$(HSCOBJS) yaccParser/hsclink.o yaccParser/hschooks.o,,libhsp.a) +#else +BuildPgmFromHaskellModules(hsc,$(HSCOBJS),,) +#endif + +/* ghci:: hsc */ +/* Hack to let me bootstrap (needed for error handlers) */ +/* Comment out if building boot copy of hsc */ +/*HC = ../driver/ghc*/ +#if BuildGHCI == YES +BuildPgmFromHaskellModules(ghci,$(GHCIOBJS),,$(DLD_LIB)) +#endif + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC)) +InstallBinaryTarget(hsc,$(INSTLIBDIR_GHC)) +#endif + +/* set up for going either to .hc or to .o files */ +#if GhcWithHscBuiltViaC == YES + +/*OLD:SuffixRule_hc_o() */ + +# if HaskellCompilerType == HC_USE_HC_FILES + /* if we do not, we never try to compile .lhs files; + we *blast* the macro we would normally use (HACK) (WDP 94/12) + */ + +# undef HaskellCompileWithSpecifiedFlags +# define HaskellCompileWithSpecifiedFlags(module,isuf,osuf,flags) @@\ +module.osuf : module.isuf \ +_body_HaskellCompileWithSpecifiedFlags(module.isuf,module.osuf,module,isuf,flags) + +# define compile(module,isuf,extra_flags) \ +HaskellCompileWithExtraFlags(module,hc,o,-c,extra_flags) + +# define compile_rec(module,isuf,extra_flags) \ +HaskellCompileWithExtraFlags_Recursive(module,hc,o,-c,extra_flags) + +# else /* we do! */ + +# define compile(module,isuf,extra_flags) \ +HaskellCompileWithExtraFlags(module,isuf,hc,-C,extra_flags) + +# define compile_rec(module,isuf,extra_flags) \ +HaskellCompileWithExtraFlags_Recursive(module,isuf,hc,-C,extra_flags) + +# endif /* ... == HC_USE_HC_FILES */ + +#else /* ! booting from C */ + +# define compile(module,isuf,extra_flags) \ +HaskellCompileWithExtraFlags(module,isuf,o,-c,extra_flags) + +# define compile_rec(module,isuf,extra_flags) \ +HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags) + +#endif /* ! booting from C */ + +#if HaskellCompilerType == HC_CHALMERS_HBC +# define if_ghc(x) /*nothing*/ +# define if_ghc26(x) /*nothing*/ +#else /* hope for GHC-ish */ +# define if_ghc(x) x +# if GhcBuilderVersion >= 26 +# define if_ghc26(x) x +# else +# define if_ghc26(x) /*nothing*/ +# endif +#endif + +/* OK, here we go: */ + +compile(absCSyn/AbsCFuns,lhs,) +compile_rec(absCSyn/AbsCSyn,lhs,if_ghc(-fno-omit-reexported-instances)) +compile(absCSyn/Costs,lhs,) /* HWL */ +compile_rec(absCSyn/HeapOffs,lhs,) +compile(absCSyn/PprAbsC,lhs,-H20m) + +compile_rec(abstractSyn/AbsSyn,lhs,if_ghc(-fno-omit-reexported-instances)) +compile_rec(abstractSyn/AbsSynFuns,lhs,) +compile_rec(abstractSyn/HsBinds,lhs,) +compile_rec(abstractSyn/HsCore,lhs,) +compile(abstractSyn/HsDecls,lhs,) +compile_rec(abstractSyn/HsExpr,lhs,-H14m) +compile(abstractSyn/HsImpExp,lhs,) +compile(abstractSyn/HsLit,lhs,) +compile(abstractSyn/HsMatches,lhs,) +compile(abstractSyn/HsPat,lhs,) +compile_rec(abstractSyn/HsPragmas,lhs,) +compile(abstractSyn/HsTypes,lhs,) +compile_rec(abstractSyn/Name,lhs,) + +compile(basicTypes/BasicLit,lhs,) +compile(basicTypes/OrdList,lhs,) +compile_rec(basicTypes/CLabelInfo,lhs,) +compile_rec(basicTypes/Id,lhs,-H20m) +compile_rec(basicTypes/IdInfo,lhs,-H20m -K2m) +compile(basicTypes/Inst,lhs,) +compile(basicTypes/NameTypes,lhs,) +compile(basicTypes/ProtoName,lhs,) +compile(basicTypes/SrcLoc,lhs,) +compile(basicTypes/Unique,lhs,) +compile_rec(basicTypes/SplitUniq,lhs,) + +compile(codeGen/CgBindery,lhs,) +compile(codeGen/CgCase,lhs,-H16m) +compile(codeGen/CgClosure,lhs,-H16m) +compile_rec(codeGen/CgCompInfo,lhs,-I$(COMPINFO_DIR)) +compile(codeGen/CgCon,lhs,) +compile(codeGen/CgConTbls,lhs,) +compile_rec(codeGen/CgExpr,lhs,) +compile(codeGen/CgHeapery,lhs,) +compile(codeGen/CgLetNoEscape,lhs,) +compile_rec(codeGen/CgMonad,lhs,if_ghc(-fno-omit-reexported-instances)) +compile_rec(codeGen/CgRetConv,lhs,) +compile(codeGen/CgStackery,lhs,) +compile(codeGen/CgTailCall,lhs,) +compile(codeGen/CgUpdate,lhs,) +compile(codeGen/CgUsages,lhs,) +compile_rec(codeGen/ClosureInfo,lhs,) +compile(codeGen/CodeGen,lhs,) +compile(codeGen/SMRep,lhs,) + +compile(coreSyn/AnnCoreSyn,lhs,if_ghc(-fno-omit-reexported-instances)) +compile(coreSyn/CoreFuns,lhs,-H16m) +compile(coreSyn/CoreLift,lhs,) +compile(coreSyn/CoreLint,lhs,) +compile(coreSyn/CoreSyn,lhs,) +compile(coreSyn/CoreUnfold,lhs,) +compile(coreSyn/FreeVars,lhs,) +compile_rec(coreSyn/PlainCore,lhs,if_ghc(-fno-omit-reexported-instances)) +compile(coreSyn/TaggedCore,lhs,if_ghc(-fno-omit-reexported-instances)) + +compile(deSugar/Desugar,lhs,) +compile_rec(deSugar/DsBinds,lhs,-H16m) +compile(deSugar/DsCCall,lhs,) +compile_rec(deSugar/DsExpr,lhs,-H16m) +compile(deSugar/DsGRHSs,lhs,) +compile(deSugar/DsListComp,lhs,) +compile(deSugar/DsMonad,lhs,) +compile_rec(deSugar/DsUtils,lhs,) +compile_rec(deSugar/Match,lhs,) +compile(deSugar/MatchCon,lhs,) +compile(deSugar/MatchLit,lhs,) + +compile(envs/CE,lhs,) +compile(envs/E,lhs,) +compile(envs/IdEnv,lhs,) +compile_rec(envs/InstEnv,lhs,) +compile(envs/LIE,lhs,) +compile(envs/TCE,lhs,) +compile(envs/TVE,lhs,) +compile_rec(envs/TyVarEnv,lhs,) + +compile(main/CmdLineOpts,lhs,-K2m) +compile_rec(main/Errors,lhs,) +compile_rec(main/ErrsTc,lhs,-H20m) +compile_rec(main/ErrsRn,lhs,) +compile_rec(main/ErrUtils,lhs,) +compile(main/Main,lhs,-H16m if_ghc(-fvia-C -fno-update-analysis)) /* ToDo: update */ +compile(main/MainMonad,lhs,if_ghc(-fno-omit-reexported-instances)) +compile(main/MkIface,lhs,) + +#if GhcWithNativeCodeGen == YES +compile(nativeGen/AbsCStixGen,lhs,) +compile(nativeGen/AsmCodeGen,lhs,-I$(COMPINFO_DIR)) +compile_rec(nativeGen/AsmRegAlloc,lhs,-I$(COMPINFO_DIR) -H20m) +compile(nativeGen/MachDesc,lhs,) +compile(nativeGen/Stix,lhs,) +compile(nativeGen/StixInfo,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/StixInteger,lhs,-H20m) +compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR)) +compile(nativeGen/StixPrim,lhs,-H16m) +#if sparc_TARGET_ARCH +compile_rec(nativeGen/SparcDesc,lhs,) +compile(nativeGen/SparcCode,lhs,-H20m -I$(NATIVEGEN_DIR)) +compile(nativeGen/SparcGen,lhs,-H20m) +#else +compile_rec(nativeGen/AlphaDesc,lhs,) +compile(nativeGen/AlphaCode,lhs,-H24m -K2m -I$(NATIVEGEN_DIR)) +compile(nativeGen/AlphaGen,lhs,-H24m) +#endif +#endif + +compile_rec(prelude/AbsPrel,lhs,-H16m -K2m if_ghc(-fno-omit-reexported-instances -fno-update-analysis)) +compile_rec(prelude/PrelFuns,lhs,) +compile(prelude/PrelVals,lhs,) +compile_rec(prelude/PrimKind,lhs,-I$(COMPINFO_DIR)) +compile_rec(prelude/PrimOps,lhs,-H16m -K2m) +compile(prelude/TysPrim,lhs,) +compile(prelude/TysWiredIn,lhs,) + +compile(profiling/SCCauto,lhs,) +compile(profiling/SCCfinal,lhs,) +compile(profiling/CostCentre,lhs,) + +compile(reader/PrefixSyn,lhs,) +compile(reader/PrefixToHs,lhs,-H16m) +compile(reader/ReadPragmas,lhs,) +compile_rec(reader/ReadPrefix,lhs,) +compile_rec(reader/ReadPrefix2,lhs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(reader/ReadPragmas2,lhs,-H20m) + +compile(rename/Rename,lhs,) +compile(rename/Rename1,lhs,) +compile(rename/Rename2,lhs,) +compile(rename/Rename3,lhs,) +compile(rename/Rename4,lhs,-H20m) +compile(rename/RenameAuxFuns,lhs,) +compile_rec(rename/RenameBinds4,lhs,) +compile_rec(rename/RenameExpr4,lhs,) +compile(rename/RenameMonad12,lhs,) +compile(rename/RenameMonad3,lhs,) +compile(rename/RenameMonad4,lhs,) + +compile(simplCore/BinderInfo,lhs,) +compile(simplCore/ConFold,lhs,) +compile(simplCore/FloatIn,lhs,) +compile(simplCore/FloatOut,lhs,) +compile(simplCore/LiberateCase,lhs,) +compile(simplCore/MagicUFs,lhs,) +compile(simplCore/OccurAnal,lhs,) + +compile(simplCore/NewOccurAnal,lhs,) +compile(simplCore/AnalFBWW,lhs,) +compile(simplCore/FoldrBuildWW,lhs,) +/* ANDY: compile(simplCore/SimplHaskell,lhs,) */ + +compile(simplCore/SAT,lhs,) +compile(simplCore/SATMonad,lhs,) +compile(simplCore/SetLevels,lhs,) +compile_rec(simplCore/SimplCase,lhs,-H20m) +compile(simplCore/SimplCore,lhs,) +compile_rec(simplCore/SimplEnv,lhs,) +compile(simplCore/SimplMonad,lhs,) +compile(simplCore/SimplPgm,lhs,) +compile(simplCore/SimplUtils,lhs,) +compile_rec(simplCore/SimplVar,lhs,) +compile(simplCore/Simplify,lhs,) + +compile(simplStg/SatStgRhs,lhs,) +compile(simplStg/LambdaLift,lhs,) +compile(simplStg/StgVarInfo,lhs,) +compile(simplStg/UpdAnal,lhs,) +compile(simplStg/StgStats,lhs,) +compile(simplStg/StgSATMonad,lhs,) +compile(simplStg/StgSAT,lhs,) +compile(simplStg/SimplStg,lhs,) + +#if GhcWithDeforester == YES +compile(deforest/Core2Def,lhs,) +compile(deforest/Cyclic,lhs,) +compile_rec(deforest/Def2Core,lhs,) +compile(deforest/DefExpr,lhs,-H20m) +compile(deforest/DefSyn,lhs,) +compile(deforest/DefUtils,lhs,-H16m) +compile(deforest/Deforest,lhs,) +compile(deforest/TreelessForm,lhs,) +#endif + +compile(specialise/Specialise,lhs,-H32m) /* sigh */ +compile(specialise/SpecTyFuns,lhs,) + +compile(stgSyn/CoreToStg,lhs,) +compile(stgSyn/StgFuns,lhs,) +compile(stgSyn/StgLint,lhs,) +compile(stgSyn/StgSyn,lhs,if_ghc(-fno-omit-reexported-instances) -H16m) + +compile(stranal/SaAbsInt,lhs,) +compile(stranal/SaLib,lhs,) +compile(stranal/StrictAnal,lhs,) +compile(stranal/WorkWrap,lhs,) +compile(stranal/WwLib,lhs,) + +compile(typecheck/BackSubst,lhs,) +compile_rec(typecheck/Disambig,lhs,) +compile(typecheck/GenSpecEtc,lhs,) +compile(typecheck/Spec,lhs,) +compile(typecheck/Subst,lhs,if_ghc(-fvia-C) if_ghc26(-monly-4-regs)) +compile(typecheck/TcBinds,lhs,) +compile(typecheck/TcClassDcl,lhs,-H14m) +compile(typecheck/TcClassSig,lhs,) +compile(typecheck/TcConDecls,lhs,) +compile(typecheck/TcContext,lhs,) +compile(typecheck/TcDefaults,lhs,) +compile_rec(typecheck/TcDeriv,lhs,-H20m) +compile_rec(typecheck/TcExpr,lhs,-H20m) +compile_rec(typecheck/TcGRHSs,lhs,) +compile(typecheck/TcGenDeriv,lhs,-H20m) +compile(typecheck/TcIfaceSig,lhs,) +compile(typecheck/TcInstDcls,lhs,-H20m) +compile(typecheck/TcMatches,lhs,) +compile(typecheck/TcModule,lhs,) +compile_rec(typecheck/TcMonad,lhs,) +compile(typecheck/TcMonadFns,lhs,) +compile(typecheck/TcMonoBnds,lhs,) +compile(typecheck/TcMonoType,lhs,) +compile(typecheck/TcPat,lhs,-H14m) +compile_rec(typecheck/TcPolyType,lhs,) +compile(typecheck/TcPragmas,lhs,-H20m) +compile(typecheck/TcQuals,lhs,) +compile(typecheck/TcSimplify,lhs,) +compile(typecheck/TcTyDecls,lhs,) +compile(typecheck/Typecheck,lhs,) +compile(typecheck/Unify,lhs,) + +compile_rec(uniType/AbsUniType,lhs,if_ghc(-fno-omit-reexported-instances)) +compile_rec(uniType/Class,lhs,) +compile_rec(uniType/TyCon,lhs,) +compile_rec(uniType/TyVar,lhs,) +compile(uniType/UniTyFuns,lhs,-H20m) +compile_rec(uniType/UniType,lhs,) + +compile(utils/Bag,lhs,) +compile(utils/CharSeq,lhs,if_ghc(-fvia-C)) /* uses stg_putc */ +compile(utils/Digraph,lhs,) +compile(utils/FiniteMap,lhs,-H20m) +compile(utils/LiftMonad,lhs,) +compile(utils/ListSetOps,lhs,) +compile(utils/Maybes,lhs,) +compile_rec(utils/Outputable,lhs,) +compile_rec(utils/Pretty,lhs,) +compile(utils/BitSet,lhs,if_ghc26(-monly-4-regs)) +compile_rec(utils/UniqFM,lhs,) +compile(utils/UniqSet,lhs,) +compile(utils/Unpretty,lhs,) +compile_rec(utils/Util,lhs,) + +/* Some of these sizes have been boosted a little to fit the alpha */ +#if BuildGHCI == YES +compile(nhcParser/Attr,lhs,) +compile(nhcParser/AttrLib,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/Either,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/Extra,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/Fixity,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/Flags,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/HS,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/HbcOnly,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/Import,lhs,) +compile(nhcParser/Lex,lhs,) +compile(nhcParser/LexLow,lhs,) +compile(nhcParser/LexPre,lhs,) +compile(nhcParser/LexStr,lhs,) +compile(nhcParser/Lexical,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/ListUtil,lhs,) +compile(nhcParser/MergeSort,lhs,) +compile(nhcParser/MkSyntax,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/NHCName,lhs,) +compile(nhcParser/NHCPackedString,lhs,) +compile(nhcParser/NameLib,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/NameLow,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/OsOnly,lhs,) +compile(nhcParser/PPLib,lhs,) +compile(nhcParser/PPSyntax,lhs,) +compile(nhcParser/Parse,lhs,-H30m if_ghc(-fhaskell-1.3)) +compile(nhcParser/ParseCore,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/ParseI,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/ParseLex,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/ParseLib,lhs,if_ghc(-fhaskell-1.3)) +compile(nhcParser/ScopeLib,lhs,) +compile(nhcParser/StrName,lhs,) +compile(nhcParser/StrSyntax,lhs,) +compile(nhcParser/Syntax,lhs,) +compile(nhcParser/SyntaxPos,lhs,) +compile(nhcParser/Tree234,lhs,) + +compile(interpreter/ToPrefix,lhs,if_ghc(-fhaskell-1.3)) +compile(interpreter/UnsafeCoerce,lhs,if_ghc(-nohi)) /* NB: no interface file, please! */ +compile(interpreter/Dynamic,lhs,) +compile(interpreter/Interpreter,lhs,if_ghc(-fvia-C -fhaskell-1.3)) +compile(interpreter/MkInterface,lhs,) +compile(interpreter/GHCIMonad,lhs,if_ghc(-fvia-C -fhaskell-1.3)) +compile(interpreter/FullEnv,lhs,if_ghc(-fhaskell-1.3)) +compile(interpreter/Command,lhs,) +compile(interpreter/GHCIFlags,lhs,) +compile(interpreter/GHCInterface,lhs,-H40m if_ghc(-fhaskell-1.3)) +compile(interpreter/GHCI,lhs,if_ghc(-fhaskell-1.3)) +compile(interpreter/GHCICore,lhs,if_ghc(-fhaskell-1.3)) + +# Just using standard macro doesn't use the #include then compiling the +# .hc file. + +HaskellCompileWithExtraFlags(interpreter/Dld,lhs,hc,-fvia-C -C -fhaskell-1.3,) +HaskellCompileWithExtraFlags_Recursive(interpreter/Dld,hc,o,-c,'-#include"$(DLD_INCLUDE)"') + +# (There's gotta be a cleaner way of doing this but only one person in +# the entire world understands Jmakefiles well enough to use them +# effectively.) + +# some c-as-asm level hacks +# also needs a hand-hacked interface file +interpreter/DldHacks.o: interpreter/DldHacks.lhc + $(RM) interpreter/DldHacks.hc interpreter/DldHacks.o + lit2pgm interpreter/DldHacks.lhc + $(GHC) -c $(GHC_FLAGS) interpreter/DldHacks.hc + +interpreter/DldC.o: interpreter/DldC.lc + $(RM) interpreter/DldC.c interpreter/DldC.o + lit2pgm interpreter/DldC.lc + $(GHC) -c $(GHC_FLAGS) interpreter/DldC.c -I$(DLD_DIR) -optcO-DNON_POSIX_SOURCE + +/* Does not work for a subdir ... (Sigh) +NormalLibraryTarget($(DLD_DIR)/libdld,$(DLD_OBJS_O)) +*/ +all :: dld/libdld.a +clean :: + $(RM) dld/libdld.a +dld/libdld.a :: $(DLD_OBJS_O) + $(RM) $@ + $(AR) $@ $(DLD_OBJS_O) + $(RANLIB) $@ + +# To improve loading speed, we generate some C programs which contain +# references to all symbols in the libraries we link with. + +# ToDo: remove the appel dependency. + +MY_TOP = .. +MY_LIB = $(MY_TOP)/lib +MY_RTS = $(MY_TOP)/runtime + +interpreter/prelude.o: $(MY_LIB)/libHS.a makeSymbolList.prl + $(RM) interpreter/prelude.c interpreter/prelude.o + nm -p $(MY_LIB)/libHS.a | perl makeSymbolList.prl > interpreter/prelude.c + $(GHC) -c $(GHC_FLAGS) interpreter/prelude.c + +interpreter/runtime.o: $(MY_RTS)/libHSrts.a $(MY_RTS)/libHSclib.a makeSymbolList.prl + $(RM) interpreter/runtime.c interpreter/runtime.o + nm -p $(MY_RTS)/libHSrts.a $(MY_RTS)/libHSclib.a | perl makeSymbolList.prl > interpreter/runtime.c + $(GHC) -c $(GHC_FLAGS) interpreter/runtime.c + +#endif /* GHCI */ + +/* for convenience in cross-compiling */ +objs:: $(ALLOBJS) + +/* *** parser ************************************************* */ + +YACC_OPTS = -d +CC_OPTS = -IyaccParser -I. -I$(COMPINFO_DIR) + +/* add to these on the command line with, e.g., EXTRA_YACC_OPTS=-v */ + +#if BuildDataParallelHaskell == YES +D_DPH = -DDPH +#endif + +XCOMM D_DEBUG = -DDEBUG + +CPP_DEFINES = $(D_DEBUG) $(D_DPH) + +HSP_SRCS_C = /* yaccParser/main.c */ \ + yaccParser/atype.c \ + yaccParser/binding.c \ + yaccParser/coresyn.c \ + yaccParser/entidt.c \ + yaccParser/finfot.c \ + yaccParser/hpragma.c \ + yaccParser/hslexer.c \ + yaccParser/hsparser.tab.c \ + yaccParser/id.c \ + yaccParser/import_dirlist.c \ + yaccParser/infix.c \ + yaccParser/list.c \ + yaccParser/literal.c \ + yaccParser/pbinding.c \ + /* yaccParser/printtree.c */ \ + yaccParser/syntax.c \ + yaccParser/tree.c \ + yaccParser/ttype.c \ + yaccParser/type2context.c \ + yaccParser/util.c + +HSP_OBJS_O = /* yaccParser/main.o */ \ + yaccParser/atype.o \ + yaccParser/binding.o \ + yaccParser/coresyn.o \ + yaccParser/entidt.o \ + yaccParser/finfot.o \ + yaccParser/hpragma.o \ + yaccParser/hslexer.o \ + yaccParser/hsparser.tab.o \ + yaccParser/id.o \ + yaccParser/import_dirlist.o \ + yaccParser/infix.o \ + yaccParser/list.o \ + yaccParser/literal.o \ + yaccParser/pbinding.o \ + /* yaccParser/printtree.o */ \ + yaccParser/syntax.o \ + yaccParser/tree.o \ + yaccParser/ttype.o \ + yaccParser/type2context.o \ + yaccParser/util.o + +/* DPH uses some tweaked files; here are the lists again... */ + +#if BuildDataParallelHaskell == YES +DPH_HSP_SRCS_C = yaccParser/atype.c \ + yaccParser/binding.c \ + yaccParser/coresyn.c \ + yaccParser/entidt.c \ + yaccParser/finfot.c \ + yaccParser/hpragma.c \ + yaccParser/hslexer-DPH.c \ + yaccParser/hsparser-DPH.tab.c \ + yaccParser/id.c \ + yaccParser/import_dirlist.c \ + yaccParser/infix.c \ + yaccParser/list.c \ + yaccParser/literal.c \ + yaccParser/main.c \ + yaccParser/pbinding.c \ + yaccParser/printtree.c \ + yaccParser/syntax.c \ + yaccParser/tree-DPH.c \ + yaccParser/ttype-DPH.c \ + yaccParser/type2context.c \ + yaccParser/util.c + +DPH_HSP_OBJS_O = yaccParser/atype.o \ + yaccParser/binding.o \ + yaccParser/coresyn.o \ + yaccParser/entidt.o \ + yaccParser/finfot.o \ + yaccParser/hpragma.o \ + yaccParser/hslexer-DPH.o \ + yaccParser/hsparser-DPH.tab.o \ + yaccParser/id.o \ + yaccParser/import_dirlist.o \ + yaccParser/infix.o \ + yaccParser/list.o \ + yaccParser/literal.o \ + yaccParser/main.o \ + yaccParser/pbinding.o \ + yaccParser/printtree.o \ + yaccParser/syntax.o \ + yaccParser/tree-DPH.o \ + yaccParser/ttype-DPH.o \ + yaccParser/type2context.o \ + yaccParser/util.o +#endif + +/* this is for etags */ +REAL_HSP_SRCS_C = yaccParser/main.c \ + yaccParser/hschooks.c \ + yaccParser/hsclink.c \ + yaccParser/id.c \ + yaccParser/util.c \ + yaccParser/syntax.c \ + yaccParser/type2context.c \ + yaccParser/import_dirlist.c \ + yaccParser/infix.c \ + yaccParser/printtree.c + +UgenNeededHere(all depend) + +/* Most hsp files are in libhsp.a, so we can either make + a standalone parser, or incorporate the files into + the hsc compiler directly (WDP 94/10) +*/ +NormalLibraryTarget(hsp,$(HSP_OBJS_O)) + +/* We need the hsp program for hstags to work! */ +BuildPgmFromCFiles(hsp,yaccParser/printtree.o yaccParser/main.o,,libhsp.a) +#if BuildDataParallelHaskell == YES +BuildPgmFromCFiles(dphsp,$(DPH_HSP_OBJS_O),,) +#endif + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC)) +InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC)) +# if BuildDataParallelHaskell == YES +InstallBinaryTarget(dphsp,$(INSTLIBDIR_GHC)) +# endif +#endif /* DoInstall... */ + +YaccRunWithExpectMsg(yaccParser/hsparser,12,2) + +UgenTarget(yaccParser/atype) +UgenTarget(yaccParser/binding) +UgenTarget(yaccParser/coresyn) +UgenTarget(yaccParser/entidt) +UgenTarget(yaccParser/finfot) +UgenTarget(yaccParser/literal) +UgenTarget(yaccParser/list) +UgenTarget(yaccParser/pbinding) +UgenTarget(yaccParser/hpragma) +UgenTarget(yaccParser/tree) +UgenTarget(yaccParser/ttype) + +#if BuildDataParallelHaskell == YES +YaccRunWithExpectMsg(yaccParser/hsparser-DPH,12,4) +UgenTarget(yaccParser/tree-DPH) +UgenTarget(yaccParser/ttype-DPH) +#endif + +UGENS_C = yaccParser/atype.c \ + yaccParser/binding.c \ + yaccParser/coresyn.c \ + yaccParser/entidt.c \ + yaccParser/finfot.c \ + yaccParser/literal.c \ + yaccParser/list.c \ + yaccParser/pbinding.c \ + yaccParser/hpragma.c \ + yaccParser/tree.c \ + yaccParser/ttype.c + +compile(yaccParser/UgenAll,lhs,if_ghc(-fvia-C)) +compile(yaccParser/UgenUtil,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_atype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_binding,hs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_coresyn,hs,-H20m if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_entidt,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_finfot,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_hpragma,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_list,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_literal,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_pbinding,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_tree,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_treeHACK,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) +compile(yaccParser/U_ttype,hs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -IyaccParser '-#include"hspincl.h"')) + +/* finished with local macros */ +#undef compile +#undef compile_rec +#undef if_ghc + +/* *** misc *************************************************** */ + +/* ?????????? ToDo: need parser depend/clean/etc in here ????? */ + +/* omit for now: +LitDocRootTargetWithNamedOutput(root,lit,root-standalone) +*/ +/* LitDependTarget(root,lit): built-in to the above */ + +/* mkdependHS has to have the -i.../-I... subdirectory lists even if "ghc" does not +*/ +#if GhcWithHscBuiltViaC == NO +DEPSRCS = $(ALLSRCS_LHS) $(ALLSRCS_HS) +MKDEPENDHS_OPTS= $(DASH_I_SUBDIR_LIST) -i$(SUBDIR_LIST) -I$(MAIN_INCLUDE_DIR) + +#else /* booting from .hc (no ghci) */ +DEPSRCS = $(HSCSRCS_LHS) $(HSCSRCS_HS) +MKDEPENDHS_OPTS= -o .hc $(DASH_I_SUBDIR_LIST) -i$(SUBDIR_LIST) -I$(MAIN_INCLUDE_DIR) +#endif /* booting from .hc files */ + +#if HaskellCompilerType != HC_USE_HC_FILES + /* otherwise, the dependencies jeopardize our .hc files -- + which are all we have! */ +HaskellDependTarget( $(DEPSRCS) ) +#endif + +ExtraStuffToClean( $(ALLOBJS) $(HSP_OBJS_O) ) +#if GhcWithHscBuiltViaC == YES +ExtraStuffToClean( $(ALLHCS) ) +#endif +ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) ) + +ClearTagsFile() +HsTagsTarget( $(ALLSRCS_LHS) ) +HSTAGS_OPTS = $(HC_OPTS) -I$(MAIN_INCLUDE_DIR) + +/* count the number of lines in the source files */ +count_lines :: + ./count_lines $(ALLSRCS_LHS) $(ALLSRCS_HS) + +/* accumulate similar info about the sizes of object files */ +count_bytes :: + ./count_bytes $(ALLSRCS_LHS) $(ALLSRCS_HS) + +/* run the "resolve_ifaces" script (assuming you know what you are doing) */ +resolve_ifaces :: + ./resolve_ifaces $(ALLINTS) diff --git a/ghc/compiler/README b/ghc/compiler/README new file mode 100644 index 0000000..0830fb3 --- /dev/null +++ b/ghc/compiler/README @@ -0,0 +1,45 @@ +This directory contains the source for Glorious Glasgow Haskell +compiler proper, normally a binary called "hsc". The source is +organized into _one_ level of directories, and the literate Haskell +source files sit in those directories (i.e., */*.lhs). + +The only "real" subdirectory is the tests/ directory [NB: not +distributed normally, but available to gluttons for punishment], which +includes some tests that we use to make sure we're not going +backwards. The subdirs of the test directory "match" the subdirs of +the main source directory; e.g., the desugarer is in subdir deSugar/, +and the tests for the desugarer are in tests/deSugar/. + +The main information about how the compiler goes together is in +./Jmakefile. The list of modules under "FRONTSRCS_LHS =", +"TCSRCS_LHS =", etc., should show the basic organization of the (many) +modules. + +TO ADD A MODULE TO THE COMPILER: + +0. Be familiar with "How to add an optimisation pass..." (in + ghc/docs/add_to_compiler). + +1. Create an appropriately-named module in an appropriate subdirectory. + +2. Edit the Jmakefile: + + * If you created a new subdirectory for the module, add that + directory to the SUBDIR_LIST and DASH_I_SUBDIR_LIST lists. + + * Add your module to one of the lists of modules in the compiler; + e.g., TCSRCS_LHS. + +3. Re-make the Makefile: "make Makefile" + +4. Re-make the automatically-generated dependencies: "make depend". + +Your new module is now "wired in" and you may proceed normally... + + % make + +(see also: day-to-day make-worlding section of developer's guide, near +the end) + +5. If you want to set up automagically (re-)runnable tests, follow + the suggests in the file tests/README. diff --git a/ghc/compiler/absCSyn/AbsCFuns.hi b/ghc/compiler/absCSyn/AbsCFuns.hi new file mode 100644 index 0000000..26456a5 --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCFuns.hi @@ -0,0 +1,41 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsCFuns where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import ClosureInfo(ClosureInfo) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +amodeCanSurviveGC :: CAddrMode -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +getAmodeKind :: CAddrMode -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +kindFromMagicId :: MagicId -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mixedPtrLocn :: CAddrMode -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mixedTypeLocn :: CAddrMode -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkAbsCStmtList :: AbstractC -> [AbstractC] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: AbstractC) (u1 :: AbstractC) -> _!_ _ORIG_ AbsCSyn AbsCStmts [] [u0, u1] _N_ #-} +mkAbstractCs :: [AbstractC] -> AbstractC + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [AbstractC]) -> case u0 of { _ALG_ (:) (u1 :: AbstractC) (u2 :: [AbstractC]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { AbstractC } [ _ORIG_ AbsCFuns mkAbsCStmts, u0 ]; _NIL_ -> _!_ _ORIG_ AbsCSyn AbsCNop [] []; _NO_DEFLT_ } _N_ #-} +mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _N_ _N_ _N_ #-} +nonemptyAbsC :: AbstractC -> Labda AbstractC + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/absCSyn/AbsCFuns.lhs b/ghc/compiler/absCSyn/AbsCFuns.lhs new file mode 100644 index 0000000..448ac5b --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCFuns.lhs @@ -0,0 +1,864 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[AbsCFuns]{Help functions for Abstract~C datatype} + +\begin{code} +#include "HsVersions.h" + +module AbsCFuns ( + nonemptyAbsC, + mkAbstractCs, mkAbsCStmts, + mkAlgAltsCSwitch, + kindFromMagicId, + getAmodeKind, amodeCanSurviveGC, + mixedTypeLocn, mixedPtrLocn, + flattenAbsC, +--UNUSED: getDestinationRegs, + mkAbsCStmtList, + + -- printing/forcing stuff comes from PprAbsC + + -- and for interface self-sufficiency... + AbstractC, CAddrMode, PrimKind, SplitUniqSupply + ) where + +import AbsCSyn + +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( kindFromType, splitTyArgs, TauType(..), + TyVar, TyCon, Arity(..), Class, UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) + +#ifndef DPH +import CLabelInfo ( CLabel, mkReturnPtLabel, mkVecTblLabel ) +#else +import CLabelInfo ( CLabel, mkReturnPtLabel, + isNestableBlockLabel, isSlowFastLabelPair ) +#endif {- Data Parallel Haskell -} + +import BasicLit ( kindOfBasicLit ) +import Digraph ( stronglyConnComp ) +import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id ) +import Maybes ( Maybe(..) ) +import PrimKind ( getKindSize, retKindSize, PrimKind(..) ) +import SplitUniq +import StgSyn ( StgAtom ) +import Unique -- UniqueSupply primitives used in flattening monad +import Util + +infixr 9 `thenFlt` +\end{code} + +Check if there is any real code in some Abstract~C. If so, return it +(@Just ...@); otherwise, return @Nothing@. Don't be too strict! + +It returns the "reduced" code in the Just part so that the work of +discarding AbsCNops isn't lost, and so that if the caller uses +the reduced version there's less danger of a big tree of AbsCNops getting +materialised and causing a space leak. + +\begin{code} +nonemptyAbsC :: AbstractC -> Maybe AbstractC +nonemptyAbsC AbsCNop = Nothing +--UNUSED:nonemptyAbsC (CComment _) = Nothing +nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of + Nothing -> nonemptyAbsC s2 + Just x -> Just (AbsCStmts x s2) +nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of + Nothing -> Nothing + Just x -> Just s +nonemptyAbsC other = Just other +\end{code} + +\begin{code} +mkAbstractCs :: [AbstractC] -> AbstractC +mkAbstractCs [] = AbsCNop +mkAbstractCs cs = foldr1 mkAbsCStmts cs + +-- for fiddling around w/ killing off AbsCNops ... (ToDo) +mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC +mkAbsCStmts = AbsCStmts + +{- Discarded SLPJ June 95; it calls nonemptyAbsC too much! + = BIND (case (nonemptyAbsC abc2) of + Nothing -> AbsCNop + Just d2 -> d2) _TO_ abc2b -> + + case (nonemptyAbsC abc1) of { + Nothing -> abc2b; + Just d1 -> AbsCStmts d1 abc2b + } BEND +-} +{- + = case (nonemptyAbsC abc1) of + Nothing -> abc2 + Just d1 -> AbsCStmts d1 abc2 +-} +{- old2: + = case (nonemptyAbsC abc1) of + Nothing -> case (nonemptyAbsC abc2) of + Nothing -> AbsCNop + Just d2 -> d2 + Just d1 -> AbsCStmts d1 abc2 +-} +{- old: + if abc1_empty then + if abc2_empty + then AbsCNop + else abc2 + else if {- abc1 not empty but -} abc2_empty then + abc1 + else {- neither empty -} + AbsCStmts abc1 abc2 + where + abc1_empty = noAbsCcode abc1 + abc2_empty = noAbsCcode abc2 +-} +\end{code} + +Get the sho' 'nuff statements out of an @AbstractC@. +\begin{code} +{- +mkAbsCStmtList :: AbstractC -> [AbstractC] + +mkAbsCStmtList AbsCNop = [] +--UNUSED:mkAbsCStmtList (CComment _) = [] +mkAbsCStmtList (AbsCStmts s1 s2) = mkAbsCStmtList s1 ++ mkAbsCStmtList s2 +mkAbsCStmtList s@(CSimultaneous c) = if null (mkAbsCStmtList c) + then [] + else [s] +mkAbsCStmtList other = [other] +-} + +mkAbsCStmtList :: AbstractC -> [AbstractC] +mkAbsCStmtList absC = mkAbsCStmtList' absC [] + +-- Optimised a la foldr/build! + +mkAbsCStmtList' AbsCNop r = r +--UNUSED:mkAbsCStmtList' (CComment _) r = r +mkAbsCStmtList' (AbsCStmts s1 s2) r = + mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r) +mkAbsCStmtList' s@(CSimultaneous c) r = + if null (mkAbsCStmtList c) then r else s : r +mkAbsCStmtList' other r = other : r + +\end{code} + +\begin{code} +mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC + +mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc + = CSwitch scrutinee (adjust tagged_alts) deflt_absc + where + -- Adjust the tags in the switch to start at zero. + -- This is the convention used by primitive ops which return algebraic + -- data types. Why? Because for two-constructor types, zero is faster + -- to create and distinguish from 1 than are 1 and 2. + + -- We also need to convert to BasicLits to keep the CSwitch happy + adjust tagged_alts + = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c) + | (tag, abs_c) <- tagged_alts ] +\end{code} + +%************************************************************************ +%* * +\subsubsection[AbsCFuns-kinds-from-MagicIds]{Kinds from MagicIds} +%* * +%************************************************************************ + +\begin{code} +kindFromMagicId BaseReg = PtrKind +kindFromMagicId StkOReg = PtrKind +kindFromMagicId (VanillaReg kind _) = kind +kindFromMagicId (FloatReg _) = FloatKind +kindFromMagicId (DoubleReg _) = DoubleKind +kindFromMagicId TagReg = IntKind +kindFromMagicId RetReg = RetKind +kindFromMagicId SpA = PtrKind +kindFromMagicId SuA = PtrKind +kindFromMagicId SpB = PtrKind +kindFromMagicId SuB = PtrKind +kindFromMagicId Hp = PtrKind +kindFromMagicId HpLim = PtrKind +kindFromMagicId LivenessReg = IntKind +kindFromMagicId ActivityReg = IntKind +kindFromMagicId StdUpdRetVecReg = PtrKind +kindFromMagicId StkStubReg = PtrKind +kindFromMagicId CurCostCentre = CostCentreKind +kindFromMagicId VoidReg = VoidKind +#ifdef DPH +kindFromMagicId (DataReg _ n) = kind +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[AbsCFuns-amode-kinds]{Finding @PrimitiveKinds@ of amodes} +%* * +%************************************************************************ + +See also the return conventions for unboxed things; currently living +in @CgCon@ (next to the constructor return conventions). + +ToDo: tiny tweaking may be in order +\begin{code} +getAmodeKind :: CAddrMode -> PrimKind + +getAmodeKind (CVal _ kind) = kind +getAmodeKind (CAddr _) = PtrKind +getAmodeKind (CReg magic_id) = kindFromMagicId magic_id +getAmodeKind (CTemp uniq kind) = kind +getAmodeKind (CLbl label kind) = kind +getAmodeKind (CUnVecLbl _ _) = PtrKind +getAmodeKind (CCharLike _) = PtrKind +getAmodeKind (CIntLike _) = PtrKind +getAmodeKind (CString _) = PtrKind +getAmodeKind (CLit lit) = kindOfBasicLit lit +getAmodeKind (CLitLit _ kind) = kind +getAmodeKind (COffset _) = IntKind +getAmodeKind (CCode abs_C) = CodePtrKind +getAmodeKind (CLabelledCode label abs_C) = CodePtrKind +getAmodeKind (CJoinPoint _ _) = panic "getAmodeKind:CJoinPoint" +getAmodeKind (CTableEntry _ _ kind) = kind +getAmodeKind (CMacroExpr kind _ _) = kind +getAmodeKind (CCostCentre _ _) = panic "getAmodeKind:CCostCentre" +\end{code} + +@amodeCanSurviveGC@ tells, well, whether or not the amode is invariant +across a garbage collection. Used only for PrimOp arguments (not that +it matters). + +\begin{code} +amodeCanSurviveGC :: CAddrMode -> Bool + +amodeCanSurviveGC (CTableEntry base offset _) + = amodeCanSurviveGC base && amodeCanSurviveGC offset + -- "Fixed table, so it's OK" (JSM); code is slightly paranoid + +amodeCanSurviveGC (CLbl _ _) = True +amodeCanSurviveGC (CUnVecLbl _ _) = True +amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg +amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg +amodeCanSurviveGC (CString _) = True +amodeCanSurviveGC (CLit _) = True +amodeCanSurviveGC (CLitLit _ _) = True +amodeCanSurviveGC (COffset _) = True +amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args + +amodeCanSurviveGC _ = False + -- there are some amodes that "cannot occur" as args + -- to a PrimOp, but it is safe to return False (rather than panic) +\end{code} + +@mixedTypeLocn@ tells whether an amode identifies an ``StgWord'' +location; that is, one which can contain values of various types. + +\begin{code} +mixedTypeLocn :: CAddrMode -> Bool + +mixedTypeLocn (CVal (NodeRel _) _) = True +mixedTypeLocn (CVal (SpBRel _ _) _) = True +mixedTypeLocn (CVal (HpRel _ _) _) = True +mixedTypeLocn other = False -- All the rest +\end{code} + +@mixedPtrLocn@ tells whether an amode identifies a +location which can contain values of various pointer types. + +\begin{code} +mixedPtrLocn :: CAddrMode -> Bool + +mixedPtrLocn (CVal (SpARel _ _) _) = True +mixedPtrLocn other = False -- All the rest +\end{code} + +%************************************************************************ +%* * +\subsection[AbsCFuns-flattening]{Flatten Abstract~C} +%* * +%************************************************************************ + +The following bits take ``raw'' Abstract~C, which may have all sorts of +nesting, and flattens it into one long @AbsCStmtList@. Mainly, +@CClosureInfos@ and code for switches are pulled out to the top level. + +The various functions herein tend to produce +\begin{enumerate} +\item +A {\em flattened} \tr{} of interest for ``here'', and +\item +Some {\em unflattened} Abstract~C statements to be carried up to the +top-level. The only real reason (now) that it is unflattened is +because it means the recursive flattening can be done in just one +place rather than having to remember lots of places. +\end{enumerate} + +Care is taken to reduce the occurrence of forward references, while still +keeping laziness a much as possible. Essentially, this means that: +\begin{itemize} +\item +{\em All} the top-level C statements resulting from flattening a +particular AbsC statement (whether the latter is nested or not) appear +before {\em any} of the code for a subsequent AbsC statement; +\item +but stuff nested within any AbsC statement comes +out before the code for the statement itself. +\end{itemize} + +The ``stuff to be carried up'' always includes a label: a +@CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or +@CCodeBlock@. The latter turns into a C function, and is never +actually produced by the code generator. Rather it always starts life +as a @CLabelledCode@ addressing mode; when such an addr mode is +flattened, the ``tops'' stuff is a @CCodeBlock@. + +\begin{code} +flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC + +flattenAbsC us abs_C + = case (initFlt us (flatAbsC abs_C)) of { (here, tops) -> + here `mkAbsCStmts` tops } +\end{code} + +%************************************************************************ +%* * +\subsubsection{Flattening monadery} +%* * +%************************************************************************ + +The flattener is monadised. It's just a @UniqueSupply@, along with a +``come-back-to-here'' label to pin on heap and stack checks. + +\begin{code} +type FlatM result + = CLabel + -> SplitUniqSupply + -> result + +initFlt :: SplitUniqSupply -> FlatM a -> a + +initFlt init_us m = m (panic "initFlt:CLabel") init_us + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenFlt #-} +{-# INLINE returnFlt #-} +#endif + +thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b + +thenFlt expr cont label us + = case (splitUniqSupply us) of { (s1, s2) -> + case (expr label s1) of { result -> + cont result label s2 }} + +returnFlt :: a -> FlatM a +returnFlt result label us = result + +mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b] + +mapFlt f [] = returnFlt [] +mapFlt f (x:xs) + = f x `thenFlt` \ r -> + mapFlt f xs `thenFlt` \ rs -> + returnFlt (r:rs) + +mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c]) + +mapAndUnzipFlt f [] = returnFlt ([],[]) +mapAndUnzipFlt f (x:xs) + = f x `thenFlt` \ (r1, r2) -> + mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) -> + returnFlt (r1:rs1, r2:rs2) + +getUniqFlt :: FlatM Unique +getUniqFlt label us = getSUnique us + +getUniqsFlt :: Int -> FlatM [Unique] +getUniqsFlt i label us = getSUniques i us + +setLabelFlt :: CLabel -> FlatM a -> FlatM a +setLabelFlt new_label cont label us = cont new_label us + +getLabelFlt :: FlatM CLabel +getLabelFlt label us = label +\end{code} + +%************************************************************************ +%* * +\subsubsection{Flattening the top level} +%* * +%************************************************************************ + +\begin{code} +flatAbsC :: AbstractC + -> FlatM (AbstractC, -- Stuff to put inline [Both are fully + AbstractC) -- Stuff to put at top level flattened] + +flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop) + +flatAbsC (AbsCStmts s1 s2) + = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) -> + flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) -> + returnFlt (mkAbsCStmts inline_s1 inline_s2, + mkAbsCStmts top_s1 top_s2) + +flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr) + = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) -> + flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) -> + flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) -> + returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops, + CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr] + ) + where + flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC) + flat_maybe Nothing = returnFlt (Nothing, AbsCNop) + flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) -> + returnFlt (Just heres, tops) + +flatAbsC (CCodeBlock label abs_C) + = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) -> + returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres) + +flatAbsC (CClosureUpdInfo info) = flatAbsC info + +flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes) + = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) -> + returnFlt (AbsCNop, tops `mkAbsCStmts` + CStaticClosure closure_lbl closure_info new_cc new_amodes) + +flatAbsC (CRetVector tbl_label stuff deflt) + = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) -> + mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) -> + returnFlt (AbsCNop, mkAbstractCs [deflt_tops, + mkAbstractCs alt_tops, + CFlatRetVector tbl_label alt_amodes]) + + where + do_deflt deflt = case nonemptyAbsC deflt of + Nothing -> returnFlt (bogus_default_label, AbsCNop) + Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the + -- CJump (CLabelledCode ...) case + + do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop) + do_alt deflt_amode (Just alt) = flatAmode alt + + bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available" + + +flatAbsC (CRetUnVector label amode) + = flatAmode amode `thenFlt` \ (new_amode, tops) -> + returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode) + +flatAbsC (CFlatRetVector label amodes) + = flatAmodes amodes `thenFlt` \ (new_amodes, tops) -> + returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes) + +flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat + = returnFlt (AbsCNop, cc) + +-- now the real stmts: + +flatAbsC (CAssign dest source) + = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) -> + flatAmode source `thenFlt` \ (src_amode, src_tops) -> + returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops ) + +-- special case: jump to some anonymous code +flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C + +flatAbsC (CJump target) + = flatAmode target `thenFlt` \ (targ_amode, targ_tops) -> + returnFlt ( CJump targ_amode, targ_tops ) + +flatAbsC (CFallThrough target) + = flatAmode target `thenFlt` \ (targ_amode, targ_tops) -> + returnFlt ( CFallThrough targ_amode, targ_tops ) + +flatAbsC (CReturn target return_info) + = flatAmode target `thenFlt` \ (targ_amode, targ_tops) -> + returnFlt ( CReturn targ_amode return_info, targ_tops ) + +flatAbsC (CSwitch discrim alts deflt) + = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) -> + mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) -> + flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) -> + returnFlt ( + CSwitch discrim_amode flat_alts flat_def_alt, + mkAbstractCs (discrim_tops : def_tops : flat_alts_tops) + ) + where + flat_alt (tag, absC) + = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) -> + returnFlt ( (tag, alt_heres), alt_tops ) + +flatAbsC stmt@(CInitHdr a b cc u) + = flatAmode cc `thenFlt` \ (new_cc, tops) -> + returnFlt (CInitHdr a b new_cc u, tops) + +flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs) + = flatAmodes results `thenFlt` \ (results_here, tops1) -> + flatAmodes args `thenFlt` \ (args_here, tops2) -> + returnFlt (COpStmt results_here op args_here liveness_mask vol_regs, + mkAbsCStmts tops1 tops2) + +flatAbsC stmt@(CSimultaneous abs_c) + = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) -> + doSimultaneously stmts_here `thenFlt` \ new_stmts_here -> + returnFlt (new_stmts_here, tops) + +flatAbsC stmt@(CMacroStmt macro amodes) + = flatAmodes amodes `thenFlt` \ (amodes_here, tops) -> + returnFlt (CMacroStmt macro amodes_here, tops) + +flatAbsC stmt@(CCallProfCtrMacro str amodes) + = flatAmodes amodes `thenFlt` \ (amodes_here, tops) -> + returnFlt (CCallProfCtrMacro str amodes_here, tops) + +flatAbsC stmt@(CCallProfCCMacro str amodes) + = flatAmodes amodes `thenFlt` \ (amodes_here, tops) -> + returnFlt (CCallProfCCMacro str amodes_here, tops) + +--UNUSED:flatAbsC comment_stmt@(CComment comment) = returnFlt (AbsCNop, AbsCNop) + +flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt) + +#ifdef DPH + -- Hack since 0.16 because Direct entry code blocks can be nested + -- within other Direct entry blocks... + flatAbsC (CNativeInfoTableAndCode cinfo descr + (CCodeBlock slow_label + (AbsCStmts slow_abs_c + (CCodeBlock fast_label fast_abs_c)))) + | isSlowFastLabelPair slow_label fast_label + = flatAbsC slow_abs_c `thenFlt` \ (slow_here, slow_top) -> + flatAbsC fast_abs_c `thenFlt` \ (fast_here, fast_top) -> + returnFlt (CNativeInfoTableAndCode cinfo descr + (CCodeBlock slow_label + (AbsCStmts slow_here + (CCodeBlock fast_label fast_here))), + mkAbsCStmts slow_top fast_top) + + flatAbsC (CNativeInfoTableAndCode cinfo descr abs_C) + = flatAbsC abs_C `thenFlt` \ (heres, tops) -> + returnFlt (CNativeInfoTableAndCode cinfo descr heres, tops) +#endif {- Data Parallel Haskell -} + +--flatAbsC stmt = panic ("flatAbsC: funny statement " ++ printRealC (\x->False) stmt) +\end{code} + +%************************************************************************ +%* * +\subsection[flat-amodes]{Flattening addressing modes} +%* * +%************************************************************************ + +\begin{code} +flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC) + +-- easy ones first +flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop) + +flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CString _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop) +flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop) +flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop) + +-- CIntLike must be a literal -- no flattening +flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop) + +-- CCharLike may be arbitrary value -- have to flatten +flatAmode amode@(CCharLike char) + = flatAmode char `thenFlt` \ (flat_char, tops) -> + returnFlt(CCharLike flat_char, tops) + +flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint" + +flatAmode (CLabelledCode label abs_C) + -- Push the code (with this label) to the top level + = flatAbsC abs_C `thenFlt` \ (body_code, tops) -> + returnFlt (CLbl label CodePtrKind, + tops `mkAbsCStmts` CCodeBlock label body_code) + +flatAmode (CCode abs_C) + = case mkAbsCStmtList abs_C of + [CJump amode] -> flatAmode amode -- Elide redundant labels + _ -> + -- de-anonymous-ise the code and push it (labelled) to the top level + getUniqFlt `thenFlt` \ new_uniq -> + BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label -> + flatAbsC abs_C `thenFlt` \ (body_code, tops) -> + returnFlt ( + CLbl return_pt_label CodePtrKind, + tops `mkAbsCStmts` CCodeBlock return_pt_label body_code + -- DO NOT TOUCH the stuff sent to the top... + ) + BEND + +flatAmode (CTableEntry base index kind) + = flatAmode base `thenFlt` \ (base_amode, base_tops) -> + flatAmode index `thenFlt` \ (ix_amode, ix_tops) -> + returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops ) + +flatAmode (CMacroExpr pk macro amodes) + = flatAmodes amodes `thenFlt` \ (amodes_here, tops) -> + returnFlt ( CMacroExpr pk macro amodes_here, tops ) + +flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop) +\end{code} + +And a convenient way to do a whole bunch of 'em. +\begin{code} +flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC) + +flatAmodes [] = returnFlt ([], AbsCNop) + +flatAmodes amodes + = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) -> + returnFlt (amodes_here, mkAbstractCs tops) +\end{code} + +%************************************************************************ +%* * +\subsection[flat-simultaneous]{Doing things simultaneously} +%* * +%************************************************************************ + +\begin{code} +doSimultaneously :: AbstractC -> FlatM AbstractC +\end{code} + +Generate code to perform the @CAssign@s and @COpStmt@s in the +input simultaneously, using temporary variables when necessary. + +We use the strongly-connected component algorithm, in which + * the vertices are the statements + * an edge goes from s1 to s2 iff + s1 assigns to something s2 uses + that is, if s1 should *follow* s2 in the final order + +ADR Comment + +Wow - fancy stuff. But are we ever going to do anything other than +assignments in parallel? If not, wouldn't it be simpler to generate +the following: + + x1, x2, x3 = e1, e2, e3 + + | + | + V + { int t1 = e1; + int t2 = e2; + int t3 = e3; + x1 = t1; + x2 = t2; + x3 = t3; + } + +and leave it to the C compiler to figure out whether it needs al +those variables. + +(Likewise, why not let the C compiler delete silly code like + + x = x + +for us?) + +tnemmoC RDA + +\begin{code} +type CVertex = (Int, AbstractC) -- Give each vertex a unique number, + -- for fast comparison + +type CEdge = (CVertex, CVertex) + +doSimultaneously abs_c + = let + enlisted = en_list abs_c + in + case enlisted of -- it's often just one stmt + [] -> returnFlt AbsCNop + [x] -> returnFlt x + _ -> doSimultaneously1 (zip [(1::Int)..] enlisted) + +-- en_list puts all the assignments in a list, filtering out Nops and +-- assignments which do nothing +en_list AbsCNop = [] +en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2 +en_list (CAssign am1 am2) | sameAmode am1 am2 = [] +en_list other = [other] + +sameAmode :: CAddrMode -> CAddrMode -> Bool +-- ToDo: Move this function, or make CAddrMode an instance of Eq +-- At the moment we put in just enough to catch the cases we want: +-- the second (destination) argument is always a CVal. +sameAmode (CReg r1) (CReg r2) = r1 == r2 +sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2 +sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2 +sameAmode other1 other2 = False + +doSimultaneously1 :: [CVertex] -> FlatM AbstractC +doSimultaneously1 vertices + = let + edges :: [CEdge] + edges = concat (map edges_from vertices) + + edges_from :: CVertex -> [CEdge] + edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2] + + should_follow :: CVertex -> CVertex -> Bool + (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2) + = dest1 `conflictsWith` src2 + (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2) + = or [dest1 `conflictsWith` src2 | dest1 <- dests1] + (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _) + = or [dest1 `conflictsWith` src2 | src2 <- srcs2] + (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _) + = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2] + +-- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False +-- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False + + eq_vertex :: CVertex -> CVertex -> Bool + (n1, _) `eq_vertex` (n2, _) = n1 == n2 + + components = stronglyConnComp eq_vertex edges vertices + + -- do_components deal with one strongly-connected component + do_component :: [CVertex] -> FlatM AbstractC + + -- A singleton? Then just do it. + do_component [(n,abs_c)] = returnFlt abs_c + + -- Two or more? Then go via temporaries. + do_component ((n,first_stmt):rest) + = doSimultaneously1 rest `thenFlt` \ abs_cs -> + go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) -> + returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps]) + + go_via_temps (CAssign dest src) + = getUniqFlt `thenFlt` \ uniq -> + let the_temp = CTemp uniq (getAmodeKind dest) in + returnFlt (CAssign the_temp src, CAssign dest the_temp) + + go_via_temps (COpStmt dests op srcs liveness_mask vol_regs) + = getUniqsFlt (length dests) `thenFlt` \ uniqs -> + let the_temps = zipWith (\ u d -> CTemp u (getAmodeKind d)) uniqs dests + in + returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs, + mkAbstractCs (zipWith CAssign dests the_temps)) + in + mapFlt do_component components `thenFlt` \ abs_cs -> + returnFlt (mkAbstractCs abs_cs) +\end{code} + + +@conflictsWith@ tells whether an assignment to its first argument will +screw up an access to its second. + +\begin{code} +conflictsWith :: CAddrMode -> CAddrMode -> Bool +(CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2 +(CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel +(CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel +(CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2 +(CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2) + = rrConflictsWithRR (getKindSize k1) (getKindSize k2) reg_rel1 reg_rel2 + +other1 `conflictsWith` other2 = False +-- CAddr and literals are impossible on the LHS of an assignment + +regConflictsWithRR :: MagicId -> RegRelative -> Bool + +regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True + +regConflictsWithRR SpA (SpARel _ _) = True +regConflictsWithRR SpB (SpBRel _ _) = True +regConflictsWithRR Hp (HpRel _ _) = True +regConflictsWithRR _ _ = False + +rrConflictsWithRR :: Int -> Int -- Sizes of two things + -> RegRelative -> RegRelative -- The two amodes + -> Bool + +rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2 + where + rr (SpARel p1 o1) (SpARel p2 o2) + | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero + | s1 == 1 && s2 == 1 = b1 == b2 + | otherwise = (b1+s1) >= b2 && + (b2+s2) >= b1 + where + b1 = p1-o1 + b2 = p2-o2 + + rr (SpBRel p1 o1) (SpBRel p2 o2) + | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero + | s1 == 1 && s2 == 1 = b1 == b2 + | otherwise = (b1+s1) >= b2 && + (b2+s2) >= b1 + where + b1 = p1-o1 + b2 = p2-o2 + + rr (NodeRel o1) (NodeRel o2) + | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero + | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2 + | otherwise = True -- Give up + + rr (HpRel _ _) (HpRel _ _) = True -- Give up + + rr other1 other2 = False +\end{code} + +%************************************************************************ +%* * +\subsection[gaze-into-simultaneous]{Registers live in a @CSimultaneous@?} +%* * +%************************************************************************ + +Hidden in a blob of ``simultaneous assignments'' is the info of how +many pointer (``followable'') registers are live (i.e., assigned +into). What we do here is merely fish out the destination registers. + +\begin{code} +{- UNUSED: +getDestinationRegs :: AbstractC -> [MagicId] + +getDestinationRegs abs_c + = foldr gather [{-acc-}] (en_list abs_c) + where + gather :: AbstractC -> [MagicId] -> [MagicId] + + -- only CAssigns and COpStmts now possible... + + gather (CAssign (CReg magic_id) _) acc | magic_id `not_elem` acc + = magic_id : acc + where + not_elem = isn'tIn "getDestinationRegs" + + gather (COpStmt dests _ _ _ _) acc + = foldr gather2 acc dests + where + gather2 (CReg magic_id) acc | magic_id `not_elem` acc = magic_id : acc + gather2 _ acc = acc + + not_elem = isn'tIn "getDestinationRegs2" + + gather _ acc = acc +-} +\end{code} diff --git a/ghc/compiler/absCSyn/AbsCSyn.hi b/ghc/compiler/absCSyn/AbsCSyn.hi new file mode 100644 index 0000000..3ba2bf9 --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCSyn.hi @@ -0,0 +1,333 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsCSyn where +import AbsCFuns(amodeCanSurviveGC, flattenAbsC, getAmodeKind, kindFromMagicId, mixedPtrLocn, mixedTypeLocn, mkAbsCStmtList, mkAbsCStmts, mkAbstractCs, mkAlgAltsCSwitch, nonemptyAbsC) +import BasicLit(BasicLit(..), mkMachInt, mkMachWord) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import Class(Class) +import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo) +import CmdLineOpts(GlobalSwitch, SimplifierSwitch) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import HeapOffs(HeapOffset, HpRelOffset(..), SpARelOffset(..), SpBRelOffset(..), VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..), addOff, fixedHdrSize, intOff, intOffsetIntoGoods, isZeroOff, maxOff, possiblyEqualHeapOffset, pprHeapOffset, subOff, totHdrSize, varHdrSize, zeroOff) +import Id(ConTag(..), Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PprAbsC(dumpRealC, writeRealC) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind(..)) +import PrimOps(PrimOp) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Stdio(_FILE) +import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +import Unpretty(Unpretty(..)) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data AbstractC = AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker +data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) +data CAddrMode = CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool +data CExprMacro = INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG +data CLabel +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data CStmtMacro = ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG +data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-} +data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data HeapOffset +type HpRelOffset = HeapOffset +data MagicId = BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg +data RegRelative = HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset +data ReturnInfo = DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode +type SpARelOffset = Int +type SpBRelOffset = Int +type VirtualHeapOffset = HeapOffset +type VirtualSpAOffset = Int +type VirtualSpBOffset = Int +type ConTag = Int +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +type Unpretty = CSeq +amodeCanSurviveGC :: CAddrMode -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +getAmodeKind :: CAddrMode -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +kindFromMagicId :: MagicId -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mixedPtrLocn :: CAddrMode -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mixedTypeLocn :: CAddrMode -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkAbsCStmtList :: AbstractC -> [AbstractC] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: AbstractC) (u1 :: AbstractC) -> _!_ _ORIG_ AbsCSyn AbsCStmts [] [u0, u1] _N_ #-} +mkAbstractCs :: [AbstractC] -> AbstractC + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [AbstractC]) -> case u0 of { _ALG_ (:) (u1 :: AbstractC) (u2 :: [AbstractC]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { AbstractC } [ _ORIG_ AbsCFuns mkAbsCStmts, u0 ]; _NIL_ -> _!_ _ORIG_ AbsCSyn AbsCNop [] []; _NO_DEFLT_ } _N_ #-} +mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _N_ _N_ _N_ #-} +nonemptyAbsC :: AbstractC -> Labda AbstractC + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkMachInt :: Integer -> BasicLit + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkMachWord :: Integer -> BasicLit + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +addOff :: HeapOffset -> HeapOffset -> HeapOffset + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +fixedHdrSize :: HeapOffset + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +infoptr :: MagicId + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intOff :: Int -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +intOffsetIntoGoods :: HeapOffset -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isVolatileReg :: MagicId -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: MagicId) -> _!_ True [] [] _N_ #-} +isZeroOff :: HeapOffset -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maxOff :: HeapOffset -> HeapOffset -> HeapOffset + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +mkCCostCentre :: CostCentre -> CAddrMode + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkIntCLit :: Int -> CAddrMode + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +node :: MagicId + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +pprHeapOffset :: PprStyle -> HeapOffset -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +subOff :: HeapOffset -> HeapOffset -> HeapOffset + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +totHdrSize :: SMRep -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +varHdrSize :: SMRep -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +zeroOff :: HeapOffset + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LU(P)LL" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Eq MagicId + {-# GHC_PRAGMA _M_ AbsCSyn {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(MagicId -> MagicId -> Bool), (MagicId -> MagicId -> Bool)] [_CONSTM_ Eq (==) (MagicId), _CONSTM_ Eq (/=) (MagicId)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq CLabel + {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool)] [_CONSTM_ Eq (==) (CLabel), _CONSTM_ Eq (/=) (CLabel)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq SimplifierSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool)] [_CONSTM_ Eq (==) (SimplifierSwitch), _CONSTM_ Eq (/=) (SimplifierSwitch)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord CLabel + {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq CLabel}}, (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> _CMP_TAG)] [_DFUN_ Eq (CLabel), _CONSTM_ Ord (<) (CLabel), _CONSTM_ Ord (<=) (CLabel), _CONSTM_ Ord (>=) (CLabel), _CONSTM_ Ord (>) (CLabel), _CONSTM_ Ord max (CLabel), _CONSTM_ Ord min (CLabel), _CONSTM_ Ord _tagCmp (CLabel)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord SimplifierSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq SimplifierSwitch}}, (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> _CMP_TAG)] [_DFUN_ Eq (SimplifierSwitch), _CONSTM_ Ord (<) (SimplifierSwitch), _CONSTM_ Ord (<=) (SimplifierSwitch), _CONSTM_ Ord (>=) (SimplifierSwitch), _CONSTM_ Ord (>) (SimplifierSwitch), _CONSTM_ Ord max (SimplifierSwitch), _CONSTM_ Ord min (SimplifierSwitch), _CONSTM_ Ord _tagCmp (SimplifierSwitch)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_ + ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_ + ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} +instance Outputable a => Outputable (StgAtom a) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _F_ _IF_ARGS_ 1 3 XXC 8 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: StgAtom u0) -> case u3 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u4 :: u0) -> _APP_ u1 [ u2, u4 ]; _ORIG_ StgSyn StgLitAtom (u5 :: BasicLit) -> _APP_ _CONSTM_ Outputable ppr (BasicLit) [ u2, u5 ]; _NO_DEFLT_ } _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Text CExprMacro + {-# GHC_PRAGMA _M_ AbsCSyn {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CExprMacro, [Char])]), (Int -> CExprMacro -> [Char] -> [Char]), ([Char] -> [([CExprMacro], [Char])]), ([CExprMacro] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CExprMacro), _CONSTM_ Text showsPrec (CExprMacro), _CONSTM_ Text readList (CExprMacro), _CONSTM_ Text showList (CExprMacro)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CExprMacro, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} +instance Text CStmtMacro + {-# GHC_PRAGMA _M_ AbsCSyn {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CStmtMacro, [Char])]), (Int -> CStmtMacro -> [Char] -> [Char]), ([Char] -> [([CStmtMacro], [Char])]), ([CStmtMacro] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CStmtMacro), _CONSTM_ Text showsPrec (CStmtMacro), _CONSTM_ Text readList (CStmtMacro), _CONSTM_ Text showList (CStmtMacro)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CStmtMacro, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs new file mode 100644 index 0000000..e66f7a7 --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -0,0 +1,689 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[AbstractC]{Abstract C: the last stop before machine code} + +This ``Abstract C'' data type describes the raw Spineless Tagless +machine model at a C-ish level; it is ``abstract'' in that it only +includes C-like structures that we happen to need. The conversion of +programs from @StgSyntax@ (basically a functional language) to +@AbstractC@ (basically imperative C) is the heart of code generation. +From @AbstractC@, one may convert to real C (for portability) or to +raw assembler/machine code. + +\begin{code} +#include "HsVersions.h" + +module AbsCSyn ( + -- export everything + AbstractC(..), + CStmtMacro(..), + CExprMacro(..), + CAddrMode(..), + ReturnInfo(..), + mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, + mkIntCLit, + 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 AbsCFuns and PprAbsC... + nonemptyAbsC, flattenAbsC, getAmodeKind, + mixedTypeLocn, mixedPtrLocn, +#ifdef __GLASGOW_HASKELL__ + writeRealC, +#endif + dumpRealC, + kindFromMagicId, -- UNUSED: getDestinationRegs, + amodeCanSurviveGC, + +#ifdef GRAN + CostRes(Cost), +#endif + + -- and stuff to make the interface self-sufficient + Outputable(..), NamedThing(..), + PrettyRep, ExportFlag, SrcLoc, Unique, + CSeq, PprStyle, Pretty(..), Unpretty(..), + -- blargh... + UniType, + + PrimKind(..), -- re-exported NON-ABSTRACTLY + BasicLit(..), mkMachInt, mkMachWord, -- re-exported NON-ABSTRACTLY + Id, ConTag(..), Maybe, PrimOp, SplitUniqSupply, TyCon, + CLabel, GlobalSwitch, CostCentre, + SimplifierSwitch, UniqSet(..), UniqFM, StgExpr, StgAtom + ) where + +import AbsCFuns -- used, and re-exported +import ClosureInfo -- ditto +import Costs +import PprAbsC -- ditto +import HeapOffs hiding ( hpRelToInt ) + +import AbsPrel ( PrimOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import CLabelInfo +import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch ) +import BasicLit ( mkMachInt, mkMachWord, BasicLit(..) ) +import Id ( Id, ConTag(..), DataCon(..) ) +import Maybes ( Maybe ) +import Outputable +import Unpretty -- ********** NOTE ********** +import PrimKind ( PrimKind(..) ) +import CostCentre -- for CostCentre type +import StgSyn ( StgExpr, StgAtom, StgBinderInfo ) +import UniqSet ( UniqSet(..), UniqFM ) +import Unique ( Unique ) +import Util + +#ifndef DPH +import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG ) +#else +import CgCompInfo ( spARelToInt, spBRelToInt ) +import DapInfo ( virtualHeapOffsetToInt ) +#endif {- Data Parallel Haskell -} +\end{code} + +@AbstractC@ is a list of Abstract~C statements, but the data structure +is tree-ish, for easier and more efficient putting-together. +\begin{code} +data AbstractC + = AbsCNop + | AbsCStmts AbstractC AbstractC + + -- and the individual stmts... +\end{code} + +A note on @CAssign@: In general, the type associated with an assignment +is the type of the lhs. However, when the lhs is a pointer to mixed +types (e.g. SpB relative), the type of the assignment is the type of +the rhs for float types, or the generic StgWord for all other types. +(In particular, a CharKind on the rhs is promoted to IntKind when +stored in a mixed type location.) + +\begin{code} + | CAssign + CAddrMode -- target + CAddrMode -- source + + | CJump + CAddrMode -- Put this in the program counter + -- eg `CJump (CReg (VanillaReg PtrKind 1))' puts Ret1 in PC + -- Enter can be done by: + -- CJump (CVal NodeRel zeroOff) + + | CFallThrough + CAddrMode -- Fall through into this routine + -- (for the benefit of the native code generators) + -- Equivalent to CJump in C land + + | CReturn -- This used to be RetVecRegRel + CAddrMode -- Any base address mode + ReturnInfo -- How to get the return address from the base address + + | CSwitch CAddrMode + [(BasicLit, AbstractC)] -- alternatives + AbstractC -- default; if there is no real Abstract C in here + -- (e.g., all comments; see function "nonemptyAbsC"), + -- then that means the default _cannot_ occur. + -- If there is only one alternative & no default code, + -- then there is no need to check the tag. + -- Therefore, e.g.: + -- CSwitch m [(tag,code)] AbsCNop == code + + | CCodeBlock CLabel AbstractC + -- [amode analog: CLabelledCode] + -- A labelled block of code; this "statement" is not + -- executed; rather, the labelled code will be hoisted + -- out to the top level (out of line) & it can be + -- jumped to. + + | CInitHdr -- to initialise the header of a closure (both fixed/var parts) + ClosureInfo + RegRelative -- address of the info ptr + CAddrMode -- cost centre to place in closure + -- CReg CurCostCentre or CC_HDR(R1.p{-Node-}) + Bool -- inplace update or allocate + + | COpStmt + [CAddrMode] -- Results + PrimOp + [CAddrMode] -- Arguments + Int -- Live registers (may be obtainable from volatility? ADR) + [MagicId] -- Potentially volatile/live registers + -- (to save/restore around the call/op) + + -- INVARIANT: When a PrimOp which can cause GC is used, the + -- only live data is tidily on the STG stacks or in the STG + -- registers (the code generator ensures this). + -- + -- Why this? Because if the arguments were arbitrary + -- addressing modes, they might be things like (Hp+6) which + -- will get utterly spongled by GC. + + | CSimultaneous -- Perform simultaneously all the statements + AbstractC -- in the nested AbstractC. They are only + -- allowed to be CAssigns, COpStmts and AbsCNops, so the + -- "simultaneous" part just concerns making + -- sure that permutations work. + -- For example { a := b, b := a } + -- needs to go via (at least one) temporary + + -- see the notes about these next few; they follow below... + | CMacroStmt CStmtMacro [CAddrMode] + | CCallProfCtrMacro FAST_STRING [CAddrMode] + | CCallProfCCMacro FAST_STRING [CAddrMode] + + -- *** the next three [or so...] are DATA (those above are CODE) *** + + | CStaticClosure + CLabel -- The (full, not base) label to use for labelling the closure. + ClosureInfo + CAddrMode -- cost centre identifier to place in closure + [CAddrMode] -- free vars; ptrs, then non-ptrs + + + | CClosureInfoAndCode + ClosureInfo -- Explains placement and layout of closure + AbstractC -- Slow entry point code + (Maybe AbstractC) + -- Fast entry point code, if any + CAddrMode -- Address of update code; Nothing => should never be used + -- (which is the case for all except constructors) + String -- Closure description; NB we can't get this from + -- ClosureInfo, because the latter refers to the *right* hand + -- side of a defn, whereas the "description" refers to *left* + -- hand side + + | CRetVector -- Return vector with "holes" + -- (Nothings) for the default + CLabel -- vector-table label + [Maybe CAddrMode] + AbstractC -- (and what to put in a "hole" [when Nothing]) + + | CRetUnVector -- Direct return + CLabel -- unvector-table label + CAddrMode -- return code + + | CFlatRetVector -- A labelled block of static data + CLabel -- This is the flattened version of CRetVector + [CAddrMode] + + | CCostCentreDecl -- A cost centre *declaration* + Bool -- True <=> local => full declaration + -- False <=> extern; just say so + CostCentre + +{-UNUSED: + | CComment -- to insert a comment into the output + FAST_STRING +-} + + | CClosureUpdInfo + AbstractC -- InRegs Info Table (CClosureInfoTable) + -- ^^^^^^^^^^^^^^^^^ + -- out of date -- HWL + + | CSplitMarker -- Split into separate object modules here + +#ifdef DPH + | CNativeInfoTableAndCode + ClosureInfo -- Explains placement and layout of closure + String -- closure description + AbstractC -- We want to apply the trick outlined in the STG + -- paper of putting the info table before the normal + -- entry point to a function (well a very similar + -- trick, see nativeDap/NOTES.static). By putting the + -- abstractC here we stop the info table + -- wandering off :-) (No post mangler hacking going + -- on here Will :-) +#endif {- Data Parallel Haskell -} +\end{code} + +About @CMacroStmt@, etc.: notionally, they all just call some +arbitrary C~macro or routine, passing the @CAddrModes@ as arguments. +However, we distinguish between various flavours of these things, +mostly just to keep things somewhat less wild and wooly. + +\begin{description} +\item[@CMacroStmt@:] +Some {\em essential} bits of the STG execution model are done with C +macros. An example is @STK_CHK@, which checks for stack-space +overflow. This enumeration type lists all such macros: +\begin{code} +data CStmtMacro + = ARGS_CHK_A_LOAD_NODE + | ARGS_CHK_A + | ARGS_CHK_B_LOAD_NODE + | ARGS_CHK_B + | HEAP_CHK + | STK_CHK + | UPD_CAF + | UPD_IND + | UPD_INPLACE_NOPTRS + | UPD_INPLACE_PTRS + | UPD_BH_UPDATABLE + | UPD_BH_SINGLE_ENTRY + | PUSH_STD_UPD_FRAME + | POP_STD_UPD_FRAME +--UNUSED: | PUSH_CON_UPD_FRAME + | SET_ARITY + | CHK_ARITY + | SET_TAG +#ifdef GRAN + | GRAN_FETCH -- for GrAnSim only -- HWL + | GRAN_RESCHEDULE -- for GrAnSim only -- HWL + | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL + | THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL +#endif + deriving Text + +\end{code} + +\item[@CCallProfCtrMacro@:] +The @String@ names a macro that, if \tr{#define}d, will bump one/some +of the STG-event profiling counters. + +\item[@CCallProfCCMacro@:] +The @String@ names a macro that, if \tr{#define}d, will perform some +cost-centre-profiling-related action. +\end{description} + +HERE ARE SOME OLD NOTES ABOUT HEAP-CHK ENTRY POINTS: + +\item[@CCallStgC@:] +Some parts of the system, {\em notably the storage manager}, are +implemented by C~routines that must know something about the internals +of the STG world, e.g., where the heap-pointer is. (The +``C-as-assembler'' documents describes this stuff in detail.) + +This is quite a tricky business, especially with ``optimised~C,'' so +we keep close tabs on these fellows. This enumeration type lists all +such ``STG~C'' routines: + +HERE ARE SOME *OLD* NOTES ABOUT HEAP-CHK ENTRY POINTS: + +Heap overflow invokes the garbage collector (of your choice :-), and +we have different entry points, to tell the GC the exact configuration +before it. +\begin{description} +\item[Branch of a boxed case:] +The @Node@ register points off to somewhere legitimate, the @TagReg@ +holds the tag, and the @RetReg@ points to the code for the +alterative which should be resumed. (ToDo: update) + +\item[Branch of an unboxed case:] +The @Node@ register points nowhere of any particular interest, a +kind-specific register (@IntReg@, @FloatReg@, etc.) holds the unboxed +value, and the @RetReg@ points to the code for the alternative +which should be resumed. (ToDo: update) + +\item[Closure entry:] +The @Node@ register points to the closure, and the @RetReg@ points +to the code to be resumed. (ToDo: update) +\end{description} + +%************************************************************************ +%* * +\subsection[CAddrMode]{C addressing modes} +%* * +%************************************************************************ + +Addressing modes: these have @PrimitiveKinds@ pinned on them. +\begin{code} +data CAddrMode + = CVal RegRelative PrimKind + -- On RHS of assign: Contents of Magic[n] + -- On LHS of assign: location Magic[n] + -- (ie at addr Magic+n) + + | CAddr RegRelative + -- On RHS of assign: Address of Magic[n]; ie Magic+n + -- n=0 gets the Magic location itself + -- (NB: n=0 case superceded by CReg) + -- On LHS of assign: only sensible if n=0, + -- which gives the magic location itself + -- (NB: superceded by CReg) + + | CReg MagicId -- To replace (CAddr MagicId 0) + + | CTableEntry -- CVal should be generalized to allow this + CAddrMode -- Base + CAddrMode -- Offset + PrimKind -- For casting + + | CTemp Unique PrimKind -- Temporary locations + -- ``Temporaries'' correspond to local variables in C, and registers in + -- native code. + -- OLD: The kind (that used to be there) is redundant, but it's REALLY helpful for + -- generating C declarations + + | CLbl CLabel -- Labels in the runtime system, etc. + -- See comment under CLabelledData about (String,Name) + PrimKind -- the kind is so we can generate accurate C decls + + | CUnVecLbl -- A choice of labels left up to the back end + CLabel -- direct + CLabel -- vectored + + | CCharLike CAddrMode -- The address of a static char-like closure for + -- the specified character. It is guaranteed to be in + -- the range 0..255. + + | CIntLike CAddrMode -- The address of a static int-like closure for the + -- specified small integer. It is guaranteed to be in the + -- range mIN_INTLIKE..mAX_INTLIKE + + | CString FAST_STRING -- The address of the null-terminated string + | CLit BasicLit + | CLitLit FAST_STRING -- completely literal literal: just spit this String + -- into the C output + PrimKind + + | COffset HeapOffset -- A literal constant, not an offset *from* anything! + -- ToDo: this should really be CLitOffset + + | CCode AbstractC -- Some code. Used mainly for return addresses. + + | CLabelledCode CLabel AbstractC -- Almost defunct? (ToDo?) --JSM + -- Some code that must have a particular label + -- (which is jumpable to) + + | CJoinPoint -- This is used as the amode of a let-no-escape-bound variable + VirtualSpAOffset -- SpA and SpB values after any volatile free vars + VirtualSpBOffset -- of the rhs have been saved on stack. + -- Just before the code for the thing is jumped to, + -- SpA/B will be set to these values, + -- and then any stack-passed args pushed, + -- then the code for this thing will be entered + + | CMacroExpr + PrimKind -- the kind of the result + CExprMacro -- the macro to generate a value + [CAddrMode] -- and its arguments + + | CCostCentre -- If Bool is True ==> it to be printed as a String, + CostCentre -- (*not* as a C identifier or some such). + Bool -- (It's not just the double-quotes on either side; + -- spaces and other funny characters will have been + -- fiddled in the non-String variant.) + +mkCCostCentre cc + = --ASSERT(not (currentOrSubsumedCosts cc)) + --FALSE: We do put subsumedCC in static closures + CCostCentre cc False +\end{code} + +Various C macros for values which are dependent on the back-end layout. + +\begin{code} + +data CExprMacro + = INFO_PTR + | ENTRY_CODE + | INFO_TAG + | EVAL_TAG + deriving(Text) + +\end{code} + +A tiny convenience: +\begin{code} +mkIntCLit :: Int -> CAddrMode +mkIntCLit i = CLit (mkMachInt (toInteger i)) +\end{code} + +%************************************************************************ +%* * +\subsection[RegRelative]{@RegRelatives@: ???} +%* * +%************************************************************************ + +\begin{code} +data RegRelative + = HpRel VirtualHeapOffset -- virtual offset of Hp + VirtualHeapOffset -- virtual offset of The Thing + | SpARel VirtualSpAOffset -- virtual offset of SpA + VirtualSpAOffset -- virtual offset of The Thing + | SpBRel VirtualSpBOffset -- virtual offset of SpB + VirtualSpBOffset -- virtual offset of The Thing + | NodeRel VirtualHeapOffset + +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} + +%************************************************************************ +%* * +\subsection[MagicId]{@MagicIds@: registers and such} +%* * +%************************************************************************ + +Much of what happens in Abstract-C is in terms of ``magic'' locations, +such as the stack pointer, heap pointer, etc. If possible, these will +be held in registers. + +Here are some notes about what's active when: +\begin{description} +\item[Always active:] + Hp, HpLim, SpA, SpB, SuA, SuB + +\item[Entry set:] + ArgPtr1 (= Node)... + +\item[Return set:] +Ptr regs: RetPtr1 (= Node), RetPtr2... +Int/char regs: RetData1 (= TagReg = IntReg), RetData2... +Float regs: RetFloat1, ... +Double regs: RetDouble1, ... +\end{description} + +\begin{code} +data MagicId + = BaseReg -- mentioned only in nativeGen + + | StkOReg -- mentioned only in nativeGen + + -- Argument and return registers + | VanillaReg -- pointers, unboxed ints and chars + PrimKind -- PtrKind, IntKind, CharKind, StablePtrKind or MallocPtrKind + -- (in case we need to distinguish) + FAST_INT -- its number (1 .. mAX_Vanilla_REG) + + | FloatReg -- single-precision floating-point registers + FAST_INT -- its number (1 .. mAX_Float_REG) + + | DoubleReg -- double-precision floating-point registers + FAST_INT -- its number (1 .. mAX_Double_REG) + + | TagReg -- to return constructor tags; as almost all returns are vectored, + -- this is rarely used. + + | RetReg -- topmost return address from the B stack + + | SpA -- Stack ptr; points to last occupied stack location. + -- Stack grows downward. + | SuA -- mentioned only in nativeGen + + | SpB -- Basic values, return addresses and update frames. + -- Grows upward. + | SuB -- mentioned only in nativeGen + + | Hp -- Heap ptr; points to last occupied heap location. + -- Free space at lower addresses. + + | HpLim -- Heap limit register: mentioned only in nativeGen + + | LivenessReg -- (parallel only) used when we need to record explicitly + -- what registers are live + + | ActivityReg -- mentioned only in nativeGen + | StdUpdRetVecReg -- mentioned only in nativeGen + | StkStubReg -- register holding STK_STUB_closure (for stubbing dead stack slots) + + | CurCostCentre -- current cost centre register. + + | VoidReg -- see "VoidPrim" type; just a placeholder; no actual register + +#ifdef DPH +-- In DPH we use: +-- (VanillaReg X) for pointers, ints, chars floats +-- (DataReg X) for ints chars or floats +-- (DoubleReg X) first 32 bits of double in register X, second 32 in +-- register X+1; DoubleReg is a synonymn for +-- DataReg X; DataReg X+1 + + | DataReg + PrimKind + Int +#endif {- Data Parallel Haskell -} + +node = VanillaReg PtrKind ILIT(1) -- A convenient alias for Node +infoptr = VanillaReg DataPtrKind ILIT(2) -- An alias for InfoPtr +\end{code} + +We need magical @Eq@ because @VanillaReg@s come in multiple flavors. + +\begin{code} +instance Eq MagicId where +#ifdef DPH + (FloatReg f1) == (FloatReg f2) = f1 == f2 + (DoubleReg d1) == (DoubleReg d2) = d1 == d2 + (DataReg _ d1) == (DataReg _ d2) = d1 == d2 +#endif {- Data Parallel Haskell -} + reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2 + +tagOf_MagicId BaseReg = (ILIT(0) :: FAST_INT) +tagOf_MagicId StkOReg = ILIT(1) +tagOf_MagicId TagReg = ILIT(2) +tagOf_MagicId RetReg = ILIT(3) +tagOf_MagicId SpA = ILIT(4) +tagOf_MagicId SuA = ILIT(5) +tagOf_MagicId SpB = ILIT(6) +tagOf_MagicId SuB = ILIT(7) +tagOf_MagicId Hp = ILIT(8) +tagOf_MagicId HpLim = ILIT(9) +tagOf_MagicId LivenessReg = ILIT(10) +tagOf_MagicId ActivityReg = ILIT(11) +tagOf_MagicId StdUpdRetVecReg = ILIT(12) +tagOf_MagicId StkStubReg = ILIT(13) +tagOf_MagicId CurCostCentre = ILIT(14) +tagOf_MagicId VoidReg = ILIT(15) + +tagOf_MagicId (VanillaReg _ i) = ILIT(15) _ADD_ i + +#ifndef DPH +tagOf_MagicId (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i + where + maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } + +tagOf_MagicId (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i + where + maxv = case mAX_Vanilla_REG of { IBOX(x) -> x } + maxf = case mAX_Float_REG of { IBOX(x) -> x } + +#else +tagOf_MagicId (DoubleReg i) = ILIT(1066) _ADD_ i -- Hacky, but we want disjoint +tagOf_MagicId (DataReg _ IBOX(i)) = ILIT(1066) _ADD_ i -- range with Vanillas +#endif {- Data Parallel Haskell -} +\end{code} + +Returns True for any register that {\em potentially} dies across +C calls (or anything near equivalent). We just say @True@ and +let the (machine-specific) registering macros sort things out... +\begin{code} +isVolatileReg :: MagicId -> Bool + +isVolatileReg any = True +--isVolatileReg (FloatReg _) = True +--isVolatileReg (DoubleReg _) = True +\end{code} + +%************************************************************************ +%* * +\subsection[AbsCSyn-printing]{Pretty-printing Abstract~C} +%* * +%************************************************************************ + +It's in \tr{PprAbsC.lhs}. + +%************************************************************************ +%* * +\subsection[EqInstances]{Eq instance for RegRelative & CAddrMode} +%* * +%************************************************************************ + +DPH requires CAddrMode to be in class Eq for its register allocation +algorithm. The code for equality is rather conservative --- it doesnt +matter if two things are determined to be not equal (even if they really are, +i.e with CVal's), we just generate less efficient code. + +NOTE(07/04/93) It does matter, its doing really bad with the reg relative + stuff. + +\begin{code} +#ifdef DPH +instance Eq CAddrMode where + (CVal r _) == (CVal r' _) = r `eqRRel` r' + (CAddr r) == (CAddr r') = r `eqRRel` r' + (CReg reg) == (CReg reg') = reg == reg' + (CTemp u _) == (CTemp u' _) = u == u' + (CLbl l _) == (CLbl l' _) = l == l' + (CUnVecLbl d v) == (CUnVecLbl d' v') = d == d' && v == v' + (CCharLike c) == (CCharLike c') = c == c' + (CIntLike c) == (CIntLike c') = c == c' + (CString str) == (CString str') = str == str' + (CLit lit) == (CLit lit') = lit == lit' + (COffset off) == (COffset off') = possiblyEqualHeapOffset off off' + (CCode _) == (CCode _) = panic "(==) Code in CAddrMode" + (CLabelledCode _ _) == (CLabelledCode _ _)= panic "(==) LabCode in CAddrMode" + _ == _ = False + + +eqRRel :: RegRelative -> RegRelative -> Bool +eqRRel (NodeRel x) (NodeRel y) + = virtualHeapOffsetToInt x == virtualHeapOffsetToInt y + +eqRRel l@(SpARel _ _) r@(SpARel _ _) + = spARelToInt l == spARelToInt r + +eqRRel l@(SpBRel _ _) r@(SpBRel _ _) + = spBRelToInt l == spBRelToInt r + +eqRRel (HpRel hp off) (HpRel hp' off') + = (virtualHeapOffsetToInt (hp `subOff` off)) == + (virtualHeapOffsetToInt (hp' `subOff` off')) + +eqRRel _ _ = False + +eqRetInfo:: ReturnInfo -> ReturnInfo -> Bool +eqRetInfo DirectReturn DirectReturn = True +eqRetInfo (StaticVectoredReturn x) (StaticVectoredReturn x') = x == x' +eqRetInfo _ _ = False +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/absCSyn/Costs.hi b/ghc/compiler/absCSyn/Costs.hi new file mode 100644 index 0000000..0142894 --- /dev/null +++ b/ghc/compiler/absCSyn/Costs.hi @@ -0,0 +1,32 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Costs where +import AbsCSyn(AbstractC, CAddrMode) +data CostRes = Cost (Int, Int, Int, Int, Int) +data Side = Lhs | Rhs +addrModeCosts :: CAddrMode -> Side -> CostRes + {-# GHC_PRAGMA _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CAddrMode) (u1 :: Side) -> _ORIG_ Costs nullCosts _N_ #-} +costs :: AbstractC -> CostRes + {-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: AbstractC) -> _ORIG_ Costs nullCosts _N_ #-} +nullCosts :: CostRes + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq CostRes + {-# GHC_PRAGMA _M_ Costs {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CostRes -> CostRes -> Bool), (CostRes -> CostRes -> Bool)] [_CONSTM_ Eq (==) (CostRes), _CONSTM_ Eq (/=) (CostRes)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: CostRes) (u1 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes -> Bool) } [ _NOREP_S_ "%DPreludeCore.Eq.(==)\"", u0, u1 ] _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Num CostRes + {-# GHC_PRAGMA _M_ Costs {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [{{Eq CostRes}}, {{Text CostRes}}, (CostRes -> CostRes -> CostRes), (CostRes -> CostRes -> CostRes), (CostRes -> CostRes -> CostRes), (CostRes -> CostRes), (CostRes -> CostRes), (CostRes -> CostRes), (Integer -> CostRes), (Int -> CostRes)] [_DFUN_ Eq (CostRes), _DFUN_ Text (CostRes), _CONSTM_ Num (+) (CostRes), _CONSTM_ Num (-) (CostRes), _CONSTM_ Num (*) (CostRes), _CONSTM_ Num negate (CostRes), _CONSTM_ Num abs (CostRes), _CONSTM_ Num signum (CostRes), _CONSTM_ Num fromInteger (CostRes), _CONSTM_ Num fromInt (CostRes)] _N_ + (+) = _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CostRes) (u1 :: CostRes) -> _ORIG_ Costs nullCosts _N_, + (-) = _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CostRes) (u1 :: CostRes) -> _ORIG_ Costs nullCosts _N_, + (*) = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: CostRes) (u1 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.(*)\"", u0, u1 ] _N_, + negate = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.negate\"", u0 ] _N_, + abs = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.abs\"", u0 ] _N_, + signum = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.signum\"", u0 ] _N_, + fromInteger = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Integer) -> _APP_ _TYAPP_ patError# { (Integer -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.fromInteger\"", u0 ] _N_, + fromInt = _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-} +instance Text CostRes + {-# GHC_PRAGMA _M_ Costs {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CostRes, [Char])]), (Int -> CostRes -> [Char] -> [Char]), ([Char] -> [([CostRes], [Char])]), ([CostRes] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CostRes), _CONSTM_ Text showsPrec (CostRes), _CONSTM_ Text readList (CostRes), _CONSTM_ Text showList (CostRes)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CostRes, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: CostRes) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> CostRes -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs new file mode 100644 index 0000000..1b16d6d --- /dev/null +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -0,0 +1,628 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994-1995 +% Hans Wolfgang Loidl +% +% --------------------------------------------------------------------------- + +\section[Costs]{Evaluating the costs of computing some abstract C code} + +This module provides all necessary functions for computing for a given +abstract~C Program the costs of executing that program. This is done by the +exported function: + +\begin{quote} + {\verb type CostRes = (Int, Int, Int, Int, Int)} + {\verb costs :: AbstractC -> CostRes } +\end{quote} + +The meaning of the result tuple is: +\begin{itemize} + \item The first component ({\tt i}) counts the number of integer, + arithmetic and bit-manipulating instructions. + \item The second component ({\tt b}) counts the number of branches (direct + branches as well as indirect ones). + \item The third component ({\tt l}) counts the number of load instructions. + \item The fourth component ({\tt s}) counts the number of store + instructions. + \item The fifth component ({\tt f}) counts the number of floating point + instructions. +\end{itemize} + +This function is needed in GrAnSim for parallelism. + +These are first suggestions for scaling the costs. But, this scaling should be done in the RTS rather than the compiler (this really should be tunable!): + +\begin{pseudocode} + +#define LOAD_COSTS 2 +#define STORE_COSTS 2 +#define INT_ARITHM_COSTS 1 +#define GMP_ARITHM_COSTS 3 {- any clue for GMP costs ? -} +#define FLOAT_ARITHM_COSTS 3 {- any clue for float costs ? -} +#define BRANCH_COSTS 2 + +\end{pseudocode} + +\begin{code} +#include "HsVersions.h" + +#define ACCUM_COSTS(i,b,l,s,f) (i+b+l+s+f) + +#define NUM_REGS 10 {- PprAbsCSyn.lhs -} {- runtime/c-as-asm/CallWrap_C.lc -} +#define RESTORE_COSTS (Cost (0, 0, NUM_REGS, 0, 0) :: CostRes) +#define SAVE_COSTS (Cost (0, 0, 0, NUM_REGS, 0) :: CostRes) +#define CCALL_COSTS_GUESS (Cost (50, 0, 0, 0, 0) :: CostRes) + +module Costs( costs, + addrModeCosts, CostRes(Cost), nullCosts, Side(..) + ) where + +import AbsCFuns +import AbsCSyn +import AbsPrel +import PrimOps +import TyCon +import Util + +-- -------------------------------------------------------------------------- +#ifndef GRAN +-- a module of "stubs" that don't do anything +data CostRes = Cost (Int, Int, Int, Int, Int) +data Side = Lhs | Rhs + +nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes + +costs :: AbstractC -> CostRes +addrModeCosts :: CAddrMode -> Side -> CostRes +costs _ = nullCosts +addrModeCosts _ _ = nullCosts + +instance Eq CostRes; instance Text CostRes + +instance Num CostRes where + x + y = nullCosts + +#else {-GRAN-} +-- the real thing + +data CostRes = Cost (Int, Int, Int, Int, Int) + deriving (Text) + +nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes +initHdrCosts = Cost (2, 0, 0, 1, 0) :: CostRes +errorCosts = Cost (-1, -1, -1, -1, -1) -- just for debugging + +oneArithm = Cost (1, 0, 0, 0, 0) :: CostRes + +instance Eq CostRes where + (==) t1 t2 = i && b && l && s && f + where (i,b,l,s,f) = binOp' (==) t1 t2 + +instance Num CostRes where + (+) = binOp (+) + (-) = binOp (-) + (*) = binOp (*) + negate = mapOp negate + abs = mapOp abs + signum = mapOp signum + +mapOp :: (Int -> Int) -> CostRes -> CostRes +mapOp g ( Cost (i, b, l, s, f) ) = Cost (g i, g b, g l, g s, g f) + +foldrOp :: (Int -> a -> a) -> a -> CostRes -> a +foldrOp o x ( Cost (i1, b1, l1, s1, f1) ) = + i1 `o` ( b1 `o` ( l1 `o` ( s1 `o` ( f1 `o` x)))) + +binOp :: (Int -> Int -> Int) -> CostRes -> CostRes -> CostRes +binOp o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) = + ( Cost (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) ) + +binOp' :: (Int -> Int -> a) -> CostRes -> CostRes -> (a,a,a,a,a) +binOp' o ( Cost (i1, b1, l1, s1, f1) ) ( Cost (i2, b2, l2, s2, f2) ) = + (i1 `o` i2, b1 `o` b2, l1 `o` l2, s1 `o` s2, f1 `o` f2) + +-- -------------------------------------------------------------------------- + +data Side = Lhs | Rhs + deriving (Eq) + +-- -------------------------------------------------------------------------- + +costs :: AbstractC -> CostRes + +costs absC = + case absC of + AbsCNop -> nullCosts + + AbsCStmts absC1 absC2 -> costs absC1 + costs absC2 + + CAssign (CReg _) (CReg _) -> Cost (1,0,0,0,0) -- typ.: mov %reg1,%reg2 + + CAssign (CReg _) (CTemp _ _) -> Cost (1,0,0,0,0) + + CAssign (CReg _) (CAddr _) -> Cost (1,0,0,0,0) -- typ.: add %reg1,,%reg2 + + CAssign target_m source_m -> addrModeCosts target_m Lhs + + addrModeCosts source_m Rhs + + CJump (CLbl _ _) -> Cost (0,1,0,0,0) -- no ld for call necessary + + CJump mode -> addrModeCosts mode Rhs + + Cost (0,1,0,0,0) + + CFallThrough mode -> addrModeCosts mode Rhs + -- chu' 0.24 + Cost (0,1,0,0,0) + + CReturn mode info -> case info of + DirectReturn -> addrModeCosts mode Rhs + + Cost (0,1,0,0,0) + + -- i.e. ld address to reg and call reg + + DynamicVectoredReturn mode' -> + addrModeCosts mode Rhs + + addrModeCosts mode' Rhs + + Cost (0,1,1,0,0) + + {- generates code like this: + JMP_()[RVREL()]; + i.e. 1 possb ld for mode' + 1 ld for RVREL + 1 possb ld for mode + 1 call -} + + StaticVectoredReturn _ -> addrModeCosts mode Rhs + + Cost (0,1,1,0,0) + + -- as above with mode' fixed to CLit + -- typically 2 ld + 1 call; 1st ld due + -- to CVal as mode + + CSwitch mode alts absC -> nullCosts + {- for handling costs of all branches of + a CSwitch see PprAbsC. + Basically: + Costs for branch = + Costs before CSwitch + + addrModeCosts of head + + Costs for 1 cond branch + + Costs for body of branch + -} + + CCodeBlock _ absC -> costs absC + + CInitHdr cl_info reg_rel cost_centre inplace_upd -> initHdrCosts + + {- This is more fancy but superflous: The addr modes + are fixed and so the costs are const! + + argCosts + initHdrCosts + where argCosts = addrModeCosts (CAddr reg_rel) Rhs + + addrModeCosts base_lbl + -- CLbl! + 3*addrModeCosts (mkIntCLit 1{- any val -}) + -} + {- this extends to something like + SET_SPEC_HDR(...) + For costing the args of this macro + see PprAbsC.lhs where args are inserted -} + + COpStmt modes_res primOp modes_args _ _ -> + {- + let + n = length modes_res + in + (0, 0, n, n, 0) + + primOpCosts primOp + + if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS + else nullCosts + -- ^^HWL + -} + foldl (+) nullCosts [addrModeCosts mode Lhs | mode <- modes_res] + + foldl (+) nullCosts [addrModeCosts mode Rhs | mode <- modes_args] + + primOpCosts primOp + + if primOpNeedsWrapper primOp then SAVE_COSTS + RESTORE_COSTS + else nullCosts + + CSimultaneous absC -> costs absC + + CMacroStmt macro modes -> stmtMacroCosts macro modes + + CCallProfCtrMacro _ _ -> nullCosts + {- we don't count profiling in GrAnSim -} + + CCallProfCCMacro _ _ -> nullCosts + {- we don't count profiling in GrAnSim -} + + -- *** the next three [or so...] are DATA (those above are CODE) *** + -- as they are data rather than code they all have nullCosts -- HWL + + CStaticClosure _ _ _ _ -> nullCosts + + CClosureInfoAndCode _ _ _ _ _ -> nullCosts + + CRetVector _ _ _ -> nullCosts + + CRetUnVector _ _ -> nullCosts + + CFlatRetVector _ _ -> nullCosts + + CCostCentreDecl _ _ -> nullCosts + + CClosureUpdInfo _ -> nullCosts + + CSplitMarker -> nullCosts + +-- --------------------------------------------------------------------------- + +addrModeCosts :: CAddrMode -> Side -> CostRes + +-- addrModeCosts _ _ = nullCosts + +addrModeCosts addr_mode side = + let + lhs = side == Lhs + in + case addr_mode of + CVal _ _ -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + + CAddr _ -> if lhs then Cost (0, 0, 0, 1, 0) -- ??unchecked + else Cost (0, 0, 1, 0, 0) + + CReg _ -> nullCosts {- loading from, storing to reg is free ! -} + {- for costing CReg->Creg ops see special -} + {- case in costs fct -} + CTableEntry base_mode offset_mode kind -> + addrModeCosts base_mode side + + addrModeCosts offset_mode side + + Cost (1,0,1,0,0) + + CTemp _ _ -> nullCosts {- if lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) -} + -- ``Temporaries'' correspond to local variables in C, and registers in + -- native code. + -- I assume they can be somewhat optimized by gcc -- HWL + + CLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (2, 0, 0, 0, 0) + -- Rhs: typically: sethi %hi(lbl),%tmp_reg + -- or %tmp_reg,%lo(lbl),%target_reg + + CUnVecLbl _ _ -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (2, 0, 0, 0, 0) + -- same as CLbl + + -- Check the following 3 (checked form CLit on) + + CCharLike mode -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + + CIntLike mode -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + + CString _ -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + + CLit _ -> if lhs then nullCosts -- should never occur + else Cost (1, 0, 0, 0, 0) -- typ.: mov lit,%reg + + CLitLit _ _ -> if lhs then nullCosts + else Cost (1, 0, 0, 0, 0) + -- same es CLit + + COffset _ -> if lhs then nullCosts + else Cost (1, 0, 0, 0, 0) + -- same es CLit + + CCode absC -> costs absC + + CLabelledCode _ absC -> costs absC + + CJoinPoint _ _ -> if lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + + CMacroExpr _ macro mode_list -> exprMacroCosts side macro mode_list + + CCostCentre _ _ -> nullCosts + +-- --------------------------------------------------------------------------- + +exprMacroCosts :: Side -> CExprMacro -> [CAddrMode] -> CostRes + +exprMacroCosts side macro mode_list = + let + arg_costs = foldl (+) nullCosts + (map (\ x -> addrModeCosts x Rhs) mode_list) + in + arg_costs + + case macro of + INFO_PTR -> if side == Lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + ENTRY_CODE -> nullCosts + INFO_TAG -> if side == Lhs then Cost (0, 0, 0, 1, 0) + else Cost (0, 0, 1, 0, 0) + EVAL_TAG -> if side == Lhs then Cost (1, 0, 0, 1, 0) + else Cost (1, 0, 1, 0, 0) + -- costs of INFO_TAG + (1,0,0,0,0) + +-- --------------------------------------------------------------------------- + +stmtMacroCosts :: CStmtMacro -> [CAddrMode] -> CostRes + +stmtMacroCosts macro modes = + let + arg_costs = foldl (+) nullCosts + [addrModeCosts mode Rhs | mode <- modes] + in + case macro of + ARGS_CHK_A_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -} + -- p=probability of PAP (instead of AP): + p*(3,1,0,0,0) + ARGS_CHK_A -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -} + -- p=probability of PAP (instead of AP): + p*(0,1,0,0,0) + ARGS_CHK_B_LOAD_NODE -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -} + ARGS_CHK_B -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -} + HEAP_CHK -> Cost (2, 1, 0, 0, 0) {- StgMacros.lh -} + -- STK_CHK -> (2, 1, 0, 0, 0) {- StgMacros.lh -} + STK_CHK -> Cost (0, 0, 0, 0, 0) {- StgMacros.lh -} + UPD_CAF -> Cost (7, 0, 1, 3, 0) {- SMupdate.lh -} + UPD_IND -> Cost (8, 2, 2, 0, 0) {- SMupdate.lh + updatee in old-gen: Cost (4, 1, 1, 0, 0) + updatee in new-gen: Cost (4, 1, 1, 0, 0) + NB: we include costs fo checking if there is + a BQ, but we omit costs for awakening BQ + (these probably differ between old-gen and + new gen) -} + UPD_INPLACE_NOPTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh + common for both: Cost (4, 1, 1, 0, 0) + updatee in old-gen: Cost (14, 3, 2, 4, 0) + updatee in new-gen: Cost (4, 1, 1, 0, 0) -} + UPD_INPLACE_PTRS -> Cost (13, 3, 3, 2, 0) {- SMupdate.lh + common for both: Cost (4, 1, 1, 0, 0) + updatee in old-gen: Cost (14, 3, 2, 4, 0) + updatee in new-gen: Cost (4, 1, 1, 0, 0) -} + + UPD_BH_UPDATABLE -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -} + UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -} + PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -} + POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -} + SET_ARITY -> nullCosts {- StgMacros.lh -} + CHK_ARITY -> nullCosts {- StgMacros.lh -} + SET_TAG -> nullCosts {- COptRegs.lh -} + GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -} + GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} + GRAN_FETCH_AND_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -} + THREAD_CONTEXT_SWITCH -> nullCosts {- GrAnSim bookkeeping -} + +-- --------------------------------------------------------------------------- + +floatOps :: [PrimOp] +floatOps = + [ FloatGtOp , FloatGeOp , FloatEqOp , FloatNeOp , FloatLtOp , FloatLeOp + , DoubleGtOp , DoubleGeOp , DoubleEqOp , DoubleNeOp , DoubleLtOp , DoubleLeOp + , FloatAddOp , FloatSubOp , FloatMulOp , FloatDivOp , FloatNegOp + , Float2IntOp , Int2FloatOp + , FloatExpOp , FloatLogOp , FloatSqrtOp + , FloatSinOp , FloatCosOp , FloatTanOp + , FloatAsinOp , FloatAcosOp , FloatAtanOp + , FloatSinhOp , FloatCoshOp , FloatTanhOp + , FloatPowerOp + , DoubleAddOp , DoubleSubOp , DoubleMulOp , DoubleDivOp , DoubleNegOp + , Double2IntOp , Int2DoubleOp + , Double2FloatOp , Float2DoubleOp + , DoubleExpOp , DoubleLogOp , DoubleSqrtOp + , DoubleSinOp , DoubleCosOp , DoubleTanOp + , DoubleAsinOp , DoubleAcosOp , DoubleAtanOp + , DoubleSinhOp , DoubleCoshOp , DoubleTanhOp + , DoublePowerOp + , FloatEncodeOp , FloatDecodeOp + , DoubleEncodeOp , DoubleDecodeOp + ] + +gmpOps :: [PrimOp] +gmpOps = + [ IntegerAddOp , IntegerSubOp , IntegerMulOp + , IntegerQuotRemOp , IntegerDivModOp , IntegerNegOp + , IntegerCmpOp + , Integer2IntOp , Int2IntegerOp + , Addr2IntegerOp + ] + + +-- Haven't found the .umul .div .rem macros yet +-- If they are not Haskell cde, they are not costed, yet + +abs_costs = nullCosts -- NB: This is normal STG code with costs already + -- included; no need to add costs again. + +umul_costs = Cost (21,4,0,0,0) -- due to spy counts +rem_costs = Cost (30,15,0,0,0) -- due to spy counts +div_costs = Cost (30,15,0,0,0) -- due to spy counts + +primOpCosts :: PrimOp -> CostRes + +-- Special cases + +primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS + + RESTORE_COSTS -- GUESS; check it + +-- Usually 3 mov instructions are needed to get args and res in right place. + +primOpCosts IntMulOp = Cost (3, 1, 0, 0, 0) + umul_costs +primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0) + div_costs +primOpCosts IntDivOp = Cost (3, 1, 0, 0, 0) -- div dclosure already costed +primOpCosts IntRemOp = Cost (3, 1, 0, 0, 0) + rem_costs +primOpCosts IntNegOp = Cost (1, 1, 0, 0, 0) -- translates into 1 sub +primOpCosts IntAbsOp = Cost (0, 1, 0, 0, 0) -- abs closure already costed + +primOpCosts FloatGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts FloatGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts FloatEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp +primOpCosts FloatNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp +primOpCosts FloatLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts FloatLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts DoubleGtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts DoubleGeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts DoubleEqOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp +primOpCosts DoubleNeOp = Cost (0, 0, 0, 0, 2) -- cheap f-comp +primOpCosts DoubleLtOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp +primOpCosts DoubleLeOp = Cost (2, 0, 0, 0, 2) -- expensive f-comp + +primOpCosts FloatExpOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatLogOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatSqrtOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatSinOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatCosOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatTanOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatAsinOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatAcosOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatAtanOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatSinhOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatCoshOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatTanhOp = Cost (2, 1, 4, 4, 3) +--primOpCosts FloatAsinhOp = Cost (2, 1, 4, 4, 3) +--primOpCosts FloatAcoshOp = Cost (2, 1, 4, 4, 3) +--primOpCosts FloatAtanhOp = Cost (2, 1, 4, 4, 3) +primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3) + +{- There should be special handling of the Array PrimOps in here HWL -} + +primOpCosts primOp + | primOp `elem` floatOps = Cost (0, 0, 0, 0, 1) :: CostRes + | primOp `elem` gmpOps = Cost (50, 5, 10, 10, 0) :: CostRes -- GUESS; check it + | otherwise = Cost (1, 0, 0, 0, 0) + +-- --------------------------------------------------------------------------- +{- HWL: currently unused + +costsByKind :: PrimKind -> Side -> CostRes + +-- The following PrimKinds say that the data is already in a reg + +costsByKind CharKind _ = nullCosts +costsByKind IntKind _ = nullCosts +costsByKind WordKind _ = nullCosts +costsByKind AddrKind _ = nullCosts +costsByKind FloatKind _ = nullCosts +costsByKind DoubleKind _ = nullCosts +-} +-- --------------------------------------------------------------------------- + +#endif {-GRAN-} +\end{code} + +This is the data structure of {\tt PrimOp} copied from prelude/PrimOps.lhs. +I include here some comments about the estimated costs for these @PrimOps@. +Compare with the @primOpCosts@ fct above. -- HWL + +\begin{pseudocode} +data PrimOp + -- I assume all these basic comparisons take just one ALU instruction + -- Checked that for Char, Int; Word, Addr should be the same as Int. + + = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp + | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp + | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp + | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp + + -- Analogously, these take one FP unit instruction + -- Haven't checked that, yet. + + | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp + | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp + + -- 1 ALU op; unchecked + | OrdOp | ChrOp + + -- these just take 1 ALU op; checked + | IntAddOp | IntSubOp + + -- but these take more than that; see special cases in primOpCosts + -- I counted the generated ass. instructions for these -> checked + | IntMulOp | IntQuotOp + | IntDivOp | IntRemOp | IntNegOp | IntAbsOp + + -- Rest is unchecked so far -- HWL + + -- Word#-related ops: + | AndOp | OrOp | NotOp | ShiftLOp | ShiftROp + | Int2WordOp | Word2IntOp -- casts + + -- Addr#-related ops: + | Int2AddrOp | Addr2IntOp -- casts + + -- Float#-related ops: + | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp + | Float2IntOp | Int2FloatOp + + | FloatExpOp | FloatLogOp | FloatSqrtOp + | FloatSinOp | FloatCosOp | FloatTanOp + | FloatAsinOp | FloatAcosOp | FloatAtanOp + | FloatSinhOp | FloatCoshOp | FloatTanhOp + -- not all machines have these available conveniently: + -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp + | FloatPowerOp -- ** op + + -- Double#-related ops: + | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp + | Double2IntOp | Int2DoubleOp + | Double2FloatOp | Float2DoubleOp + + | DoubleExpOp | DoubleLogOp | DoubleSqrtOp + | DoubleSinOp | DoubleCosOp | DoubleTanOp + | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp + | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp + -- not all machines have these available conveniently: + -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp + | DoublePowerOp -- ** op + + -- Integer (and related...) ops: + -- slightly weird -- to match GMP package. + | IntegerAddOp | IntegerSubOp | IntegerMulOp + | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp + + | IntegerCmpOp + + | Integer2IntOp | Int2IntegerOp + | Addr2IntegerOp -- "Addr" is *always* a literal string + -- ?? gcd, etc? + + | FloatEncodeOp | FloatDecodeOp + | DoubleEncodeOp | DoubleDecodeOp + + -- primitive ops for primitive arrays + + | NewArrayOp + | NewByteArrayOp PrimKind + + | SameMutableArrayOp + | SameMutableByteArrayOp + + | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs + + | ReadByteArrayOp PrimKind + | WriteByteArrayOp PrimKind + | IndexByteArrayOp PrimKind + | IndexOffAddrOp PrimKind + -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind. + -- This is just a cheesy encoding of a bunch of ops. + -- Note that MallocPtrKind is not included -- the only way of + -- creating a MallocPtr is with a ccall or casm. + + | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp + + | MakeStablePtrOp | DeRefStablePtrOp +\end{pseudocode} + +A special ``trap-door'' to use in making calls direct to C functions: +Note: From GrAn point of view, CCall is probably very expensive -- HWL + +\begin{pseudocode} + | CCallOp String -- An "unboxed" ccall# to this named function + Bool -- True <=> really a "casm" + Bool -- True <=> might invoke Haskell GC + [UniType] -- Unboxed argument; the state-token + -- argument will have been put *first* + UniType -- Return type; one of the "StateAnd#" types + + -- (... to be continued ... ) +\end{pseudocode} diff --git a/ghc/compiler/absCSyn/HeapOffs.hi b/ghc/compiler/absCSyn/HeapOffs.hi new file mode 100644 index 0000000..5e06692 --- /dev/null +++ b/ghc/compiler/absCSyn/HeapOffs.hi @@ -0,0 +1,38 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HeapOffs where +import CharSeq(CSeq) +import Maybes(Labda) +import Pretty(PprStyle) +import SMRep(SMRep) +data HeapOffset +type HpRelOffset = HeapOffset +type SpARelOffset = Int +type SpBRelOffset = Int +type VirtualHeapOffset = HeapOffset +type VirtualSpAOffset = Int +type VirtualSpBOffset = Int +addOff :: HeapOffset -> HeapOffset -> HeapOffset + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +fixedHdrSize :: HeapOffset + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intOff :: Int -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +intOffsetIntoGoods :: HeapOffset -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isZeroOff :: HeapOffset -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maxOff :: HeapOffset -> HeapOffset -> HeapOffset + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +pprHeapOffset :: PprStyle -> HeapOffset -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +subOff :: HeapOffset -> HeapOffset -> HeapOffset + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +totHdrSize :: SMRep -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +varHdrSize :: SMRep -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +zeroOff :: HeapOffset + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs new file mode 100644 index 0000000..79000d9 --- /dev/null +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -0,0 +1,402 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[HeapOffs]{Abstract C: heap offsets} + +Part of ``Abstract C.'' Heap offsets---main point: they are {\em +symbolic}---are sufficiently turgid that they get their own module. + +INTERNAL MODULE: should be accessed via @AbsCSyn.hi@. + +\begin{code} +#include "HsVersions.h" + +module HeapOffs ( +#ifndef DPH + HeapOffset, +#else + HeapOffset(..), -- DPH needs to do a little peaking inside this thing. +#endif {- Data Parallel Haskell -} + + zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize, + maxOff, addOff, subOff, + isZeroOff, possiblyEqualHeapOffset, + + pprHeapOffset, + + intOffsetIntoGoods, + +#if ! OMIT_NATIVE_CODEGEN + hpRelToInt, +#endif + + VirtualHeapOffset(..), HpRelOffset(..), + VirtualSpAOffset(..), VirtualSpBOffset(..), + SpARelOffset(..), SpBRelOffset(..) + ) where + +import ClosureInfo -- esp. about SMReps +import SMRep +#if ! OMIT_NATIVE_CODEGEN +import MachDesc +#endif +import Maybes ( catMaybes, Maybe(..) ) +import Outputable +import Unpretty -- ********** NOTE ********** +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Offsets-Heap-and-others]{Offsets, Heap and otherwise} +%* * +%************************************************************************ + +\begin{code} +{- + < fixed-hdr-size> < var-hdr-size > + --------------------------------------------------------------------- + |info| | | | | | | | ptrs... | nonptrs ... | slop.... | + --------------------------------------------------------------------- + <------------- header ------------> + + * Node, the ptr to the closure, pts at its info-ptr field +-} +data HeapOffset + = MkHeapOffset + + FAST_INT -- this many words... + + FAST_INT -- PLUS: this many FixedHdrSizes + + [SMRep__Int] -- PLUS: for each elem in this list: + -- "Int" VarHdrSizes for rep "SMRep" + -- *sorted* by SMRep + -- We never have any SpecReps in here, because their + -- VarHdrSize is zero + + [SMRep__Int] -- PLUS: for each elem in this list: + -- "Int" TotHdrSizes for rep "SMRep" + -- *sorted* by SMRep + -- We never have any SpecReps in here, because + -- their TotHdrSize is just FixedHdrSize + + | MaxHeapOffset HeapOffset HeapOffset + | SubHeapOffset HeapOffset HeapOffset + | AddHeapOffset HeapOffset HeapOffset + | ZeroHeapOffset + + deriving () -- but: see `eqOff` below + +#if defined(__GLASGOW_HASKELL__) +data SMRep__Int = SMRI_ SMRep Int# +#define SMRI(a,b) (SMRI_ a b) +#else +type SMRep__Int = (SMRep, Int) +#define SMRI(a,b) (a, b) +#endif + +type VirtualHeapOffset = HeapOffset +type VirtualSpAOffset = Int +type VirtualSpBOffset = Int + +type HpRelOffset = HeapOffset +type SpARelOffset = Int +type SpBRelOffset = Int +\end{code} + +Interface fns for HeapOffsets: +\begin{code} +zeroOff = ZeroHeapOffset + +intOff IBOX(n) = MkHeapOffset n ILIT(0) [] [] + +fixedHdrSize = MkHeapOffset ILIT(0) ILIT(1) [] [] + +totHdrSize sm_rep + = if isSpecRep sm_rep -- Tot hdr size for a spec rep is just FixedHdrSize + then MkHeapOffset ILIT(0) ILIT(1) [] [] + else MkHeapOffset ILIT(0) ILIT(0) [] [SMRI(sm_rep, ILIT(1))] + +varHdrSize sm_rep + = if isSpecRep sm_rep + then zeroOff + else MkHeapOffset ILIT(0) ILIT(0) [SMRI(sm_rep, ILIT(1))] [] +\end{code} + +%************************************************************************ +%* * +\subsubsection[Heap-offset-arithmetic]{Heap offset arithmetic} +%* * +%************************************************************************ + +\begin{code} +-- For maxOff we do our best when we have something simple to deal with +maxOff ZeroHeapOffset off2 = off2 +maxOff off1 ZeroHeapOffset = off1 +maxOff off1@(MkHeapOffset int_offs1 fixhdr_offs1 varhdr_offs1 tothdr_offs1) + off2@(MkHeapOffset int_offs2 fixhdr_offs2 varhdr_offs2 tothdr_offs2) + = if (int_offs1 _LE_ int_offs2) && + (real_fixed1 _LE_ real_fixed2) && + (all negative_or_zero difference_of_real_varhdrs) + then + off2 + else + if (int_offs2 _LE_ int_offs1) && + (real_fixed2 _LE_ real_fixed1) && + (all positive_or_zero difference_of_real_varhdrs) + then + off1 + else + MaxHeapOffset off1 off2 + where + -- Normalise, by realising that each tot-hdr is really a + -- var-hdr plus a fixed-hdr + n_tothdr1 = total_of tothdr_offs1 + real_fixed1 = fixhdr_offs1 _ADD_ n_tothdr1 + real_varhdr1 = add_HdrSizes varhdr_offs1 tothdr_offs1 + + n_tothdr2 = total_of tothdr_offs2 + real_fixed2 = fixhdr_offs2 _ADD_ n_tothdr2 + real_varhdr2 = add_HdrSizes varhdr_offs2 tothdr_offs2 + + -- Take the difference of the normalised var-hdrs + difference_of_real_varhdrs + = add_HdrSizes real_varhdr1 (map negate_HdrSize real_varhdr2) + where + negate_HdrSize :: SMRep__Int -> SMRep__Int + negate_HdrSize SMRI(rep,n) = SMRI(rep, (_NEG_ n)) + + positive_or_zero SMRI(rep,n) = n _GE_ ILIT(0) + negative_or_zero SMRI(rep,n) = n _LE_ ILIT(0) + + total_of [] = ILIT(0) + total_of (SMRI(rep,n):offs) = n _ADD_ total_of offs + +maxOff other_off1 other_off2 = MaxHeapOffset other_off1 other_off2 + +------------------------------------------------------------------ + +subOff off1 ZeroHeapOffset = off1 +subOff off1 + (MkHeapOffset int_offs2 fxdhdr_offs2 varhdr_offs2 tothdr_offs2) + = addOff off1 + (MkHeapOffset (_NEG_ int_offs2) + (_NEG_ fxdhdr_offs2) + (map negate_HdrSize varhdr_offs2) + (map negate_HdrSize tothdr_offs2)) + where + negate_HdrSize :: SMRep__Int -> SMRep__Int + negate_HdrSize SMRI(rep,n) = SMRI(rep,(_NEG_ n)) + +subOff other_off1 other_off2 = SubHeapOffset other_off1 other_off2 + +------------------------------------------------------------------ + +addOff ZeroHeapOffset off2 = off2 +addOff off1 ZeroHeapOffset = off1 +addOff (MkHeapOffset int_offs1 fxdhdr_offs1 varhdr_offs1 tothdr_offs1) + (MkHeapOffset int_offs2 fxdhdr_offs2 varhdr_offs2 tothdr_offs2) + = MkHeapOffset + (int_offs1 _ADD_ int_offs2) + (fxdhdr_offs1 _ADD_ fxdhdr_offs2) + (add_HdrSizes varhdr_offs1 varhdr_offs2) + (add_HdrSizes tothdr_offs1 tothdr_offs2) + +addOff other_off1 other_off2 = AddHeapOffset other_off1 other_off2 + +------------------------------------------------------------------ +-- not exported: +-- +add_HdrSizes :: [SMRep__Int] -> [SMRep__Int] -> [SMRep__Int] + +add_HdrSizes [] offs2 = offs2 +add_HdrSizes offs1 [] = offs1 +add_HdrSizes as@(off1@(SMRI(rep1,n1)) : offs1) bs@(off2@(SMRI(rep2,n2)) : offs2) + = if rep1 `ltSMRepHdr` rep2 then + off1 : (add_HdrSizes offs1 bs) + else + if rep2 `ltSMRepHdr` rep1 then + off2 : (add_HdrSizes as offs2) + else + let + n1_plus_n2 = n1 _ADD_ n2 + in + -- So they are the same rep + if n1_plus_n2 _EQ_ ILIT(0) then + add_HdrSizes offs1 offs2 + else + (SMRI(rep1, n1_plus_n2)) : (add_HdrSizes offs1 offs2) +\end{code} + +\begin{code} +isZeroOff :: HeapOffset -> Bool +isZeroOff ZeroHeapOffset = True +isZeroOff (MaxHeapOffset off1 off2) = isZeroOff off1 && isZeroOff off2 + +isZeroOff (AddHeapOffset off1 off2) = isZeroOff off1 && isZeroOff off2 + -- This assumes that AddHeapOffset only has positive arguments + +isZeroOff (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs) + = int_offs _EQ_ ILIT(0) && fxdhdr_offs _EQ_ ILIT(0) && + null varhdr_offs && null tothdr_offs + +isZeroOff (SubHeapOffset off1 off2) = panic "Can't say if a SubHeapOffset is zero" +\end{code} + +@possiblyEqualHeapOffset@ tells if two heap offsets might be equal. +It has to be conservative, but the situation in which it is used +(@doSimultaneously@) makes it likely to give a good answer. + +\begin{code} +possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool +possiblyEqualHeapOffset o1 o2 + = case (o1 `subOff` o2) of + + SubHeapOffset _ _ -> True -- Very conservative + + diff -> not (isZeroOff diff) -- Won't be any SubHeapOffsets in diff + -- NB: this claim depends on the use of + -- heap offsets, so this defn might need + -- to be elaborated. + +\end{code} + +%************************************************************************ +%* * +\subsection[HeapOffs-printing]{Printing heap offsets} +%* * +%************************************************************************ + +IMPORTANT: @pprHeapOffset@ and @pprHeapOffsetPieces@ guarantee to +print either a single value, or a parenthesised value. No need for +the caller to parenthesise. + +\begin{code} +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] +pprHeapOffset sty (AddHeapOffset off1 off2) + = uppBesides [uppLparen, pprHeapOffset sty off1, uppChar '+', + pprHeapOffset sty off2, uppRparen] +pprHeapOffset sty (SubHeapOffset off1 off2) + = uppBesides [uppLparen, pprHeapOffset sty off1, uppChar '-', + pprHeapOffset sty off2, uppRparen] + +pprHeapOffset sty (MkHeapOffset int_offs fxdhdr_offs varhdr_offs tothdr_offs) + = pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs +\end{code} + +\begin{code} +pprHeapOffsetPieces :: PprStyle + -> FAST_INT -- Words + -> FAST_INT -- Fixed hdrs + -> [SMRep__Int] -- Var hdrs + -> [SMRep__Int] -- Tot hdrs + -> Unpretty + +pprHeapOffsetPieces sty n ILIT(0) [] [] = uppInt IBOX(n) -- Deals with zero case too + +pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs + = let pp_int_offs = + if int_offs _EQ_ ILIT(0) + then Nothing + else Just (uppInt IBOX(int_offs)) + + pp_fxdhdr_offs = + if fxdhdr_offs _EQ_ ILIT(0) then + Nothing + else if fxdhdr_offs _EQ_ ILIT(1) then + Just (uppPStr SLIT("_FHS")) + else + Just (uppBesides [uppStr "(_FHS*", uppInt IBOX(fxdhdr_offs), uppChar ')']) + + pp_varhdr_offs = pp_hdrs (uppPStr SLIT("_VHS")) varhdr_offs + + pp_tothdr_offs = pp_hdrs (uppPStr SLIT("_HS")) tothdr_offs + in + 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 ] + 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_hdr :: Unpretty -> SMRep__Int -> Unpretty + pp_hdr pp_str (SMRI(rep, n)) + = if n _EQ_ ILIT(1) then + uppBeside (uppStr (show rep)) pp_str + else + uppBesides [uppInt IBOX(n), uppChar '*', uppStr (show rep), pp_str] +\end{code} + +%************************************************************************ +%* * +\subsection[HeapOffs-conversion]{Converting heap offsets to words} +%* * +%************************************************************************ + +@intOffsetIntoGoods@ and @hpRelToInt@ convert HeapOffsets into Ints. + +@intOffsetIntoGoods@ {\em tries} to convert a HeapOffset in a SPEC +closure into an Int, returning the (0-origin) index from the beginning +of the ``goods'' in the closure. [SPECs don't have VHSs, by +definition, so the index is merely ignoring the FHS]. + +@hpRelToInt@ is for the native code-generator(s); it is courtesy of +Jon Hill and the DAP code generator. We've just abstracted away some +of the implementation-dependent bits. + +\begin{code} +intOffsetIntoGoods :: HeapOffset -> Maybe Int + +intOffsetIntoGoods (MkHeapOffset n ILIT(1){-FHS-} [{-no VHSs-}] [{-no totHSs-}]) + = Just IBOX(n) +intOffsetIntoGoods anything_else = Nothing +\end{code} + +\begin{code} +#if ! OMIT_NATIVE_CODEGEN + +hpRelToInt :: Target -> HeapOffset -> Int + +hpRelToInt target (MaxHeapOffset left right) + = (hpRelToInt target left) `max` (hpRelToInt target right) + +hpRelToInt target (SubHeapOffset left right) + = (hpRelToInt target left) - (hpRelToInt target right) + +hpRelToInt target (AddHeapOffset left right) + = (hpRelToInt target left) + (hpRelToInt target right) + +hpRelToInt target ZeroHeapOffset = 0 + +hpRelToInt target (MkHeapOffset base fhs vhs ths) + = let + vhs_pieces, ths_pieces :: [Int] + fhs_off, vhs_off, ths_off :: Int + + vhs_pieces = map (\ (SMRI(r, n)) -> vhs_size r * IBOX(n)) vhs + ths_pieces = map (\ (SMRI(r, n)) -> (fhs_size + vhs_size r) * IBOX(n)) ths + + fhs_off = fhs_size * IBOX(fhs) + vhs_off = sum vhs_pieces + ths_off = sum ths_pieces + in + IBOX(base) + fhs_off + vhs_off + ths_off + where + fhs_size = (fixedHeaderSize target) :: Int + vhs_size r = (varHeaderSize target r) :: Int + +#endif +\end{code} diff --git a/ghc/compiler/absCSyn/PprAbsC.hi b/ghc/compiler/absCSyn/PprAbsC.hi new file mode 100644 index 0000000..c5f6fe4 --- /dev/null +++ b/ghc/compiler/absCSyn/PprAbsC.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PprAbsC where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import ClosureInfo(ClosureInfo) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Maybes(Labda) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import Stdio(_FILE) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LU(P)LL" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs new file mode 100644 index 0000000..0d4f390 --- /dev/null +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -0,0 +1,1447 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[PprAbsC]{Pretty-printing Abstract~C} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module PprAbsC ( +#ifdef __GLASGOW_HASKELL__ + writeRealC, +#endif + dumpRealC, +#if defined(DEBUG) || defined(DPH) + pprAmode, -- otherwise, not exported +#endif +#ifdef DPH + pprAbsC, + pprMagicId, +#endif + + -- and for interface self-sufficiency... + AbstractC, CAddrMode, MagicId, + PprStyle, CSeq + ) where + +IMPORT_Trace -- ToDo: rm (debugging only) + +import AbsCSyn + +import AbsPrel ( pprPrimOp, primOpNeedsWrapper, PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + ) +import BasicLit ( kindOfBasicLit, showBasicLit ) +import CLabelInfo -- lots of things +import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE ) +import CgRetConv ( noLiveRegsMask ) +import ClosureInfo -- quite a few things +import CmdLineOpts ( GlobalSwitch(..) ) +import Costs -- for GrAnSim; cost counting function -- HWL +import CostCentre +import FiniteMap +import Maybes ( catMaybes, maybeToBool, Maybe(..) ) +import Outputable +import Pretty ( codeStyle, prettyToUn ) +import PrimKind ( showPrimKind, isFloatingKind, PrimKind(..) ) +import SplitUniq +import StgSyn +import UniqFM +import Unique -- UniqueSupply monadery used in flattening +import Unpretty -- ********** NOTE ********** +import Util + +infixr 9 `thenTE` +\end{code} + +For spitting out the costs of an abstract~C expression, @writeRealC@ +now not only prints the C~code of the @absC@ arg but also adds a macro +call to a cost evaluation function @GRAN_EXEC@. For that, +@pprAbsC@ has a new ``costs'' argument. %% HWL + +\begin{code} +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ < 23 +# define _FILE _Addr +# endif +writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> PrimIO () + +writeRealC sw_chker file absC + = uppAppendFile file 80 ( + uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n') + ) +#endif + +dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> String + +dumpRealC sw_chker absC + = uppShow 80 ( + uppAbove (pprAbsC (PprForC sw_chker) absC (costs absC)) (uppChar '\n') + ) +\end{code} + +This emits the macro, which is used in GrAnSim to compute the total costs +from a cost 5 tuple. %% HWL + +\begin{code} +emitMacro :: CostRes -> Unpretty + +#ifndef GRAN +emitMacro _ = uppNil +#else +emitMacro (Cost (i,b,l,s,f)) + = uppBesides [ uppStr "GRAN_EXEC(", + uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, + uppInt s, uppComma, uppInt f, pp_paren_semi ] +#endif {-GRAN-} +\end{code} + +\begin{code} +pp_paren_semi = uppStr ");" + +-- --------------------------------------------------------------------------- +-- New type: Now pprAbsC also takes the costs for evaluating the Abstract C +-- code as an argument (that's needed when spitting out the GRAN_EXEC macro +-- which must be done before the return i.e. inside absC code) HWL +-- --------------------------------------------------------------------------- + +pprAbsC :: PprStyle -> AbstractC -> CostRes -> Unpretty + +pprAbsC sty AbsCNop _ = uppNil +pprAbsC sty (AbsCStmts s1 s2) c = uppAbove (pprAbsC sty s1 c) (pprAbsC sty s2 c) + +pprAbsC sty (CClosureUpdInfo info) c + = pprAbsC sty info c + +pprAbsC sty (CAssign dest src) _ = pprAssign sty (getAmodeKind dest) dest src + +pprAbsC sty (CJump target) c + = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CJump */"-} ]) + (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) + +pprAbsC sty (CFallThrough target) c + = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <--++ CFallThrough */"-} ]) + (uppBesides [ uppStr "JMP_(", pprAmode sty target, pp_paren_semi ]) + +-- -------------------------------------------------------------------------- +-- Spit out GRAN_EXEC macro immediately before the return HWL + +pprAbsC sty (CReturn am return_info) c + = uppAbove (uppBesides [emitMacro c {-WDP:, uppStr "/* <---- CReturn */"-} ]) + (uppBesides [uppStr "JMP_(", target, pp_paren_semi ]) + where + target = case return_info of + DirectReturn -> uppBesides [uppStr "DIRECT(", pprAmode sty am, uppRparen] + DynamicVectoredReturn am' -> mk_vector (pprAmode sty am') + StaticVectoredReturn n -> mk_vector (uppInt n) -- Always positive + mk_vector x = uppBesides [uppLparen, pprAmode sty am, uppStr ")[RVREL(", x, uppStr ")]"] + +{-UNUSED: +pprAbsC sty (CComment s) _ + = uppNil -- ifPprShowAll sty (uppCat [uppStr "/*", uppStr s, uppStr "*/"]) +-} + +pprAbsC sty (CSplitMarker) _ = uppPStr SLIT("/* SPLIT */") + +-- we optimise various degenerate cases of CSwitches. + +-- -------------------------------------------------------------------------- +-- Assume: CSwitch is also end of basic block +-- costs function yields nullCosts for whole switch +-- ==> inherited costs c are those of basic block up to switch +-- ==> inherit c + costs for the corresponding branch +-- HWL +-- -------------------------------------------------------------------------- + +pprAbsC sty (CSwitch discrim [] deflt) c + = pprAbsC sty deflt (c + costs deflt) + -- Empty alternative list => no costs for discrim as nothing cond. here HWL + +pprAbsC sty (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt + = case (nonemptyAbsC deflt) of + Nothing -> -- one alt and no default + pprAbsC sty alt_code (c + costs alt_code) + -- Nothing conditional in here either HWL + + Just dc -> -- make it an "if" + do_if_stmt sty discrim tag alt_code dc c + +pprAbsC sty (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), + (tag2@(MachInt i2 _), alt_code2)] deflt) c + | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) + = if (i1 == 0) then + do_if_stmt sty discrim tag1 alt_code1 alt_code2 c + else + do_if_stmt sty discrim tag2 alt_code2 alt_code1 c + where + empty_deflt = not (maybeToBool (nonemptyAbsC deflt)) + +pprAbsC sty (CSwitch discrim alts deflt) c -- general case + | isFloatingKind (getAmodeKind discrim) + = pprAbsC sty (foldr ( \ a -> CSwitch discrim [a]) deflt alts) c + | otherwise + = uppAboves [ + uppBesides [uppStr "switch (", pp_discrim, uppStr ") {"], + uppNest 2 (uppAboves (map (ppr_alt sty) alts)), + (case (nonemptyAbsC deflt) of + Nothing -> uppNil + Just dc -> + uppNest 2 (uppAboves [uppPStr SLIT("default:"), + pprAbsC sty dc (c + switch_head_cost + + costs dc), + uppPStr SLIT("break;")])), + uppChar '}' ] + where + pp_discrim + = pprAmode sty discrim + + ppr_alt sty (lit, absC) + = uppAboves [ uppBesides [uppPStr SLIT("case "), pprBasicLit sty lit, uppChar ':'], + uppNest 2 (uppAbove (pprAbsC sty absC (c + switch_head_cost + costs absC)) + (uppPStr SLIT("break;"))) ] + + -- Costs for addressing header of switch and cond. branching -- HWL + switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) + +pprAbsC sty stmt@(COpStmt results op@(CCallOp _ _ _ _ _) args liveness_mask vol_regs) _ + = pprCCall sty op args results liveness_mask vol_regs + +pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _ + = let + non_void_args = grab_non_void_amodes args + non_void_results = grab_non_void_amodes results + -- if just one result, we print in the obvious "assignment" style; + -- if 0 or many results, we emit a macro call, w/ the results + -- followed by the arguments. The macro presumably knows which + -- are which :-) + + the_op = ppr_op_call non_void_results non_void_args + -- liveness mask is *in* the non_void_args + in + BIND (ppr_vol_regs sty vol_regs) _TO_ (pp_saves, pp_restores) -> + if primOpNeedsWrapper op then + uppAboves [ pp_saves, + the_op, + pp_restores + ] + else + the_op + BEND + where + ppr_op_call results args + = uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen, + uppIntersperse uppComma (map ppr_op_result results), + if null results || null args then uppNil else uppComma, + uppIntersperse uppComma (map (pprAmode sty) args), + pp_paren_semi ] + + ppr_op_result r = ppr_amode sty r + -- primop macros do their own casting of result; + -- hence we can toss the provided cast... + +pprAbsC sty (CSimultaneous abs_c) c + = uppBesides [uppStr "{{", pprAbsC sty abs_c c, uppStr "}}"] + +pprAbsC sty stmt@(CMacroStmt macro as) _ + = uppBesides [uppStr (show macro), uppLparen, + uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] -- no casting +pprAbsC sty stmt@(CCallProfCtrMacro op as) _ + = uppBesides [uppPStr op, uppLparen, + uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] +pprAbsC sty stmt@(CCallProfCCMacro op as) _ + = uppBesides [uppPStr op, uppLparen, + uppIntersperse uppComma (map (ppr_amode sty) as),pp_paren_semi] + +pprAbsC sty (CCodeBlock label abs_C) _ + = ASSERT( maybeToBool(nonemptyAbsC abs_C) ) + BIND (pprTempAndExternDecls abs_C) _TO_ (pp_temps, pp_exts) -> + uppAboves [ + uppBesides [uppStr (if (externallyVisibleCLabel label) + then "FN_(" -- abbreviations to save on output + else "IFN_("), + pprCLabel sty label, uppStr ") {"], + case sty of + PprForC _ -> uppAbove pp_exts pp_temps + _ -> uppNil, + uppNest 8 (uppPStr SLIT("FB_")), + uppNest 8 (pprAbsC sty abs_C (costs abs_C)), + uppNest 8 (uppPStr SLIT("FE_")), + uppChar '}' ] + BEND + +pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _ + = uppBesides [ pp_init_hdr, uppStr "_HDR(", + ppr_amode sty (CAddr reg_rel), uppComma, + pprCLabel sty info_lbl, uppComma, + if_profiling sty (pprAmode sty cost_centre), uppComma, + pprHeapOffset sty size, uppComma, uppInt ptr_wds, pp_paren_semi ] + where + info_lbl = infoTableLabelFromCI cl_info + sm_rep = closureSMRep cl_info + size = closureSizeWithoutFixedHdr cl_info + ptr_wds = closurePtrsSize cl_info + + pp_init_hdr = uppStr (if inplace_upd then + getSMUpdInplaceHdrStr sm_rep + else + getSMInitHdrStr sm_rep) + +pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ + = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) -> + uppAboves [ + case sty of + PprForC _ -> pp_exts + _ -> uppNil, + uppBesides [ + uppStr "SET_STATIC_HDR(", + pprCLabel sty closure_lbl, uppComma, + pprCLabel sty info_lbl, uppComma, + if_profiling sty (pprAmode sty cost_centre), uppComma, + ppLocalness closure_lbl, uppComma, + ppLocalnessMacro False{-for data-} info_lbl, + uppChar ')' + ], + uppNest 2 (uppBesides (map (ppr_item sty) amodes)), + uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)), + uppStr "};" ] + BEND + where + info_lbl = infoTableLabelFromCI cl_info + + ppr_item sty item + = if getAmodeKind item == VoidKind + then uppStr ", (W_) 0" -- might not even need this... + else uppBeside (uppStr ", (W_)") (ppr_amode sty item) + + padding_wds = + if not (closureUpdReqd cl_info) then + [] + else + BIND (max 0 (mIN_UPD_SIZE - length amodes)) _TO_ still_needed -> + nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s + BEND + +{- + STATIC_INIT_HDR(c,i,localness) blows into: + localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n> + + then *NO VarHdr STUFF FOR STATIC*... + + then the amodes are dropped in... + ,a1 ,a2 ... ,aN + then a close brace: + }; +-} + +pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr) _ + = uppAboves [ + uppBesides [ + pp_info_rep, + uppStr "_ITBL(", + pprCLabel sty info_lbl, uppComma, + + -- CONST_ITBL needs an extra label for + -- the static version of the object. + if isConstantRep sm_rep + then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma + else uppNil, + + pprCLabel sty slow_lbl, uppComma, + pprAmode sty upd, uppComma, + uppInt (dataConLiveness cl_info), uppComma, + + pp_tag, uppComma, + pp_size, uppComma, + pp_ptr_wds, uppComma, + + ppLocalness info_lbl, uppComma, + ppLocalnessMacro True{-function-} slow_lbl, uppComma, + + if is_selector + then uppBeside (uppInt select_word_i) uppComma + else uppNil, + + if_profiling sty pp_kind, uppComma, + if_profiling sty pp_descr, uppComma, + if_profiling sty pp_type, + uppStr ");" + ], + pp_slow, + case maybe_fast of + Nothing -> uppNil + Just fast -> let stuff = CCodeBlock fast_lbl fast in + pprAbsC sty stuff (costs stuff) + ] + where + info_lbl = infoTableLabelFromCI cl_info + fast_lbl = fastLabelFromCI cl_info + sm_rep = closureSMRep cl_info + + (slow_lbl, pp_slow) + = case (nonemptyAbsC slow) of + Nothing -> (mkErrorStdEntryLabel, uppNil) + Just xx -> (entryLabelFromCI cl_info, + let stuff = CCodeBlock slow_lbl xx in + pprAbsC sty stuff (costs stuff)) + + maybe_selector = maybeSelectorInfo cl_info + is_selector = maybeToBool maybe_selector + (Just (_, select_word_i)) = maybe_selector + + pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep + = uppStr (if is_selector then "SELECT" else (getSMInfoStr sm_rep)) + + pp_tag = uppInt (closureSemiTag cl_info) + + is_phantom = isPhantomRep sm_rep + + pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always) + uppInt (closureNonHdrSize cl_info) + + else if is_phantom then -- do not have sizes for these + uppNil + else + pprHeapOffset sty (closureSizeWithoutFixedHdr cl_info) + + pp_ptr_wds = if is_phantom then + uppNil + else + uppInt (closurePtrsSize cl_info) + + pp_kind = uppStr (closureKind cl_info) + pp_descr = uppBesides [uppChar '"', uppStr (stringToC cl_descr), uppChar '"'] + pp_type = uppBesides [uppChar '"', uppStr (stringToC (closureTypeDescr cl_info)), uppChar '"'] + +pprAbsC sty (CRetVector lbl maybes deflt) c + = uppAboves [ uppStr "{ // CRetVector (lbl????)", + uppNest 8 (uppSep (map (ppr_maybe_amode sty) maybes)), + uppStr "} /*default=*/ {", pprAbsC sty deflt c, + uppStr "}"] + where + ppr_maybe_amode sty Nothing = uppPStr SLIT("/*default*/") + ppr_maybe_amode sty (Just a) = pprAmode sty a + +pprAbsC sty stmt@(CRetUnVector label amode) _ + = uppBesides [uppStr "UNVECTBL(", pp_static, uppComma, pprCLabel sty label, uppComma, + pprAmode sty amode, uppRparen] + where + pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static") + +pprAbsC sty stmt@(CFlatRetVector label amodes) _ + = BIND (pprTempAndExternDecls stmt) _TO_ (_, pp_exts) -> + uppAboves [ + case sty of + PprForC _ -> pp_exts + _ -> uppNil, + uppBesides [ppLocalness label, uppPStr SLIT(" W_ "), + pprCLabel sty label, uppStr "[] = {"], + uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)), + uppStr "};" ] + BEND + where + ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item) + +pprAbsC sty (CCostCentreDecl is_local cc) _ = uppCostCentreDecl sty is_local cc + +#ifdef DPH +-- Only used for debugging (i.e output abstractC instead of APAL) +pprAbsC sty (CNativeInfoTableAndCode _ _ absC) + = uppAboves [uppStr "CNativeInfoTableAndCode (DPH)", + pprAbsC sty absC] +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +ppLocalness label + = uppBeside static const + where + static = if (externallyVisibleCLabel label) then uppNil else uppPStr SLIT("static ") + const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const") + +ppLocalnessMacro for_fun{-vs data-} clabel + = BIND (if externallyVisibleCLabel clabel then "E" else "I") _TO_ prefix -> + BIND (if isReadOnly clabel then "RO_" else "") _TO_ suffix -> + if for_fun + then uppStr (prefix ++ "F_") + else uppStr (prefix ++ "D_" ++ suffix) + BEND BEND +\end{code} + +\begin{code} +grab_non_void_amodes amodes + = filter non_void amodes + +non_void amode + = case (getAmodeKind amode) of + VoidKind -> False + k -> True +\end{code} + +\begin{code} +ppr_vol_regs :: PprStyle -> [MagicId] -> (Unpretty, Unpretty) + +ppr_vol_regs sty [] = (uppNil, uppNil) +ppr_vol_regs sty (VoidReg:rs) = ppr_vol_regs sty rs +ppr_vol_regs sty (r:rs) + = let pp_reg = case r of + VanillaReg pk n -> pprVanillaReg n + _ -> pprMagicId sty r + (more_saves, more_restores) = ppr_vol_regs sty rs + in + (uppAbove (uppBeside (uppPStr SLIT("CALLER_SAVE_")) pp_reg) more_saves, + uppAbove (uppBeside (uppPStr SLIT("CALLER_RESTORE_")) pp_reg) more_restores) + +-- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and +-- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls, +-- depending on the platform. (The "volatile regs" stuff handles all +-- other registers.) Just be *sure* BaseReg is OK before trying to do +-- anything else. +pp_basic_saves + = uppAboves [ + uppPStr SLIT("CALLER_SAVE_Base"), + uppPStr SLIT("CALLER_SAVE_SpA"), + uppPStr SLIT("CALLER_SAVE_SuA"), + uppPStr SLIT("CALLER_SAVE_SpB"), + uppPStr SLIT("CALLER_SAVE_SuB"), + uppPStr SLIT("CALLER_SAVE_Ret"), + uppPStr SLIT("CALLER_SAVE_Activity"), + uppPStr SLIT("CALLER_SAVE_Hp"), + uppPStr SLIT("CALLER_SAVE_HpLim") ] + +pp_basic_restores + = uppAboves [ + uppPStr SLIT("CALLER_RESTORE_Base"), -- must be first! + uppPStr SLIT("CALLER_RESTORE_SpA"), + uppPStr SLIT("CALLER_RESTORE_SuA"), + uppPStr SLIT("CALLER_RESTORE_SpB"), + uppPStr SLIT("CALLER_RESTORE_SuB"), + uppPStr SLIT("CALLER_RESTORE_Ret"), + uppPStr SLIT("CALLER_RESTORE_Activity"), + uppPStr SLIT("CALLER_RESTORE_Hp"), + uppPStr SLIT("CALLER_RESTORE_HpLim"), + uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"), + uppPStr SLIT("CALLER_RESTORE_StkStub") ] +\end{code} + +\begin{code} +if_profiling sty pretty + = case sty of + PprForC sw_chker -> if sw_chker SccProfilingOn + then pretty + else uppChar '0' -- leave it out! + + _ -> {-print it anyway-} pretty + +-- --------------------------------------------------------------------------- +-- Changes for GrAnSim: +-- draw costs for computation in head of if into both branches; +-- as no abstractC data structure is given for the head, one is constructed +-- guessing unknown values and fed into the costs function +-- --------------------------------------------------------------------------- + +do_if_stmt sty discrim tag alt_code deflt c + = case tag of + -- This special case happens when testing the result of a comparison. + -- We can just avoid some redundant clutter in the output. + MachInt n _ | n==0 -> ppr_if_stmt sty (pprAmode sty discrim) + deflt alt_code + (addrModeCosts discrim Rhs) c + other -> let + cond = uppBesides [ pprAmode sty discrim, + uppPStr SLIT(" == "), + pprAmode sty (CLit tag) ] + in + ppr_if_stmt sty cond + alt_code deflt + (addrModeCosts discrim Rhs) c + +ppr_if_stmt sty pp_pred then_part else_part discrim_costs c + = uppAboves [ + uppBesides [uppStr "if (", pp_pred, uppStr ") {"], + uppNest 8 (pprAbsC sty then_part (c + discrim_costs + + (Cost (0, 2, 0, 0, 0)) + + costs then_part)), + (case nonemptyAbsC else_part of Nothing -> uppNil; Just _ -> uppStr "} else {"), + uppNest 8 (pprAbsC sty else_part (c + discrim_costs + + (Cost (0, 1, 0, 0, 0)) + + costs else_part)), + uppChar '}' ] + {- Total costs = inherited costs (before if) + costs for accessing discrim + + costs for cond branch ( = (0, 1, 0, 0, 0) ) + + costs for that alternative + -} +\end{code} + +Historical note: this used to be two separate cases -- one for `ccall' +and one for `casm'. To get round a potential limitation to only 10 +arguments, the numbering of arguments in @process_casm@ was beefed up a +bit. ADR + +Some rough notes on generating code for @CCallOp@: + +1) Evaluate all arguments and stuff them into registers. (done elsewhere) +2) Save any essential registers (heap, stack, etc). + + ToDo: If stable pointers are in use, these must be saved in a place + where the runtime system can get at them so that the Stg world can + be restarted during the call. + +3) Save any temporary registers that are currently in use. +4) Do the call putting result into a local variable +5) Restore essential registers +6) Restore temporaries + + (This happens after restoration of essential registers because we + might need the @Base@ register to access all the others correctly.) + +7) If returning Malloc Pointer, build a closure containing the + appropriate value. + + Otherwise, copy local variable into result register. + +8) If ccall (not casm), declare the function being called as extern so + that C knows if it returns anything other than an int. + +\begin{pseudocode} +{ ResultType _ccall_result; + basic_saves; + saves; + _ccall_result = f( args ); + basic_restores; + restores; + + #if MallocPtr + constructMallocPtr(liveness, return_reg, _ccall_result); + #else + return_reg = _ccall_result; + #end +} +\end{pseudocode} + +Amendment to the above: if we can GC, we have to: + +* make sure we save all our registers away where the garbage collector + can get at them. +* be sure that there are no live registers or we're in trouble. + (This can cause problems if you try something foolish like passing + an array or mallocptr to a _ccall_GC_ thing.) +* increment/decrement the @inCCallGC@ counter before/after the call so + that the runtime check that PerformGC is being used sensibly will work. + +\begin{code} +pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vol_regs + = 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* + uppAboves local_arg_decls, + -- if is_asm then uppNil else declareExtern, + pp_save_context, + process_casm local_vars pp_non_void_args casm_str, + pp_restore_context, + assign_results, + uppChar '}' + ] + where + (pp_saves, pp_restores) = ppr_vol_regs sty vol_regs + (pp_save_context, pp_restore_context) = + if may_gc + then ( uppStr "extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;", + uppStr "inCCallGC--; RestoreAllStgRegs();") + else ( pp_basic_saves `uppAbove` pp_saves, + pp_basic_restores `uppAbove` pp_restores) + + non_void_args = + let nvas = tail args + in ASSERT (all non_void nvas) nvas + -- the first argument will be the "I/O world" token (a VoidKind) + -- all others should be non-void + + non_void_results = + let nvrs = grab_non_void_amodes results + in ASSERT (length nvrs <= 1) nvrs + -- there will usually be two results: a (void) state which we + -- should ignore and a (possibly void) result. + + (local_arg_decls, pp_non_void_args) + = unzip [ ppr_casm_arg sty a i | (a,i) <- non_void_args `zip` [1..] ] + + pp_liveness = pprAmode sty (mkIntCLit liveness_mask) + + (declare_local_vars, local_vars, assign_results) + = ppr_casm_results sty non_void_results pp_liveness + + casm_str = if is_asm then _UNPK_ op_str else ccall_str + + -- Remainder only used for ccall + + ccall_str = uppShow 80 + (uppBesides [ + if null non_void_results + then uppNil + else uppPStr SLIT("%r = "), + uppLparen, uppPStr op_str, uppLparen, + uppIntersperse uppComma ccall_args, + uppStr "));" + ]) + num_args = length non_void_args + ccall_args = take num_args [ uppBeside (uppChar '%') (uppInt i) | i <- [0..] ] +\end{code} + +If the argument is a heap object, we need to reach inside and pull out +the bit the C world wants to see. The only heap objects which can be +passed are @Array@s, @ByteArray@s and @MallocPtr@s. + +\begin{code} +ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty) + -- (a) decl and assignment, (b) local var to be used later + +ppr_casm_arg sty amode a_num + = let + a_kind = getAmodeKind amode + pp_amode = pprAmode sty amode + pp_kind = pprPrimKind sty a_kind + + local_var = uppBeside (uppPStr SLIT("_ccall_arg")) (uppInt a_num) + + (arg_type, pp_amode2) + = case a_kind of + + -- for array arguments, pass a pointer to the body of the array + -- (PTRS_ARR_CTS skips over all the header nonsense) + ArrayKind -> (pp_kind, + uppBesides [uppStr "PTRS_ARR_CTS(", pp_amode, uppRparen]) + ByteArrayKind -> (pp_kind, + uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen]) + + -- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents. + MallocPtrKind -> (uppPStr SLIT("StgMallocPtr"), + uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"]) + other -> (pp_kind, pp_amode) + + declare_local_var + = uppBesides [ arg_type, uppSP, local_var, uppEquals, pp_amode2, uppSemi ] + in + (declare_local_var, local_var) +\end{code} + +For l-values, the critical questions are: + +1) Are there any results at all? + + We only allow zero or one results. + +2) Is the result is a mallocptr? + + The mallocptr must be encapsulated immediately in a heap object. + +\begin{code} +ppr_casm_results :: + PprStyle -- style + -> [CAddrMode] -- list of results (length <= 1) + -> Unpretty -- liveness mask + -> + ( Unpretty, -- declaration of any local vars + [Unpretty], -- list of result vars (same length as results) + Unpretty ) -- assignment (if any) of results in local var to registers + +ppr_casm_results sty [] liveness + = (uppNil, [], uppNil) -- no results + +ppr_casm_results sty [r] liveness + = let + result_reg = ppr_amode sty r + r_kind = getAmodeKind r + + local_var = uppPStr SLIT("_ccall_result") + + (result_type, assign_result) + = case r_kind of + MallocPtrKind -> + (uppPStr SLIT("StgMallocPtr"), + uppBesides [ uppStr "constructMallocPtr(", + liveness, uppComma, + result_reg, uppComma, + local_var, + pp_paren_semi ]) + _ -> + (pprPrimKind sty r_kind, + uppBesides [ result_reg, uppEquals, local_var, uppSemi ]) + + declare_local_var = uppBesides [ result_type, uppSP, local_var, uppSemi ] + in + (declare_local_var, [local_var], assign_result) + +ppr_casm_results sty rs liveness + = panic "ppr_casm_results: ccall/casm with many results" +\end{code} + + +Note the sneaky way _the_ result is represented by a list so that we +can complain if it's used twice. + +ToDo: Any chance of giving line numbers when process-casm fails? + Or maybe we should do a check _much earlier_ in compiler. ADR + +\begin{code} +process_casm :: + [Unpretty] -- results (length <= 1) + -> [Unpretty] -- arguments + -> String -- format string (with embedded %'s) + -> + Unpretty -- code being generated + +process_casm results args string = process results args string + where + process [] _ "" = uppNil + process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n") + + process ress args ('%':cs) + = case cs of + [] -> + error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n") + + ('%':css) -> + uppBeside (uppChar '%') (process ress args css) + + ('r':css) -> + case ress of + [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n") + [r] -> uppBeside r (process [] args css) + _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n") + + other -> + case readDec other of + [(num,css)] -> + if 0 <= num && num < length args + then uppBesides [uppLparen, args !! num, uppRparen, + 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") + + process ress args (other_c:cs) + = uppBeside (uppChar other_c) (process ress args cs) +\end{code} + +%************************************************************************ +%* * +\subsection[a2r-assignments]{Assignments} +%* * +%************************************************************************ + +Printing assignments is a little tricky because of type coercion. + +First of all, the kind of the thing being assigned can be gotten from +the destination addressing mode. (It should be the same as the kind +of the source addressing mode.) If the kind of the assignment is of +@VoidKind@, then don't generate any code at all. + +\begin{code} +pprAssign :: PprStyle -> PrimKind -> CAddrMode -> CAddrMode -> Unpretty + +pprAssign sty VoidKind dest src = uppNil + +#if 0 +pprAssign sty kind dest src + | (kind /= getAmodeKind dest) || (kind /= getAmodeKind src) + = uppCat [uppStr "Bad kind:", pprPrimKind sty kind, + pprPrimKind sty (getAmodeKind dest), pprAmode sty dest, + pprPrimKind sty (getAmodeKind src), pprAmode sty src] +#endif +\end{code} + +Special treatment for floats and doubles, to avoid unwanted conversions. + +\begin{code} +pprAssign sty FloatKind dest@(CVal reg_rel _) src + = uppBesides [ uppStr "ASSIGN_FLT(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] + +pprAssign sty DoubleKind dest@(CVal reg_rel _) src + = uppBesides [ uppStr "ASSIGN_DBL(", ppr_amode sty (CAddr reg_rel), uppComma, pprAmode sty src, pp_paren_semi ] +\end{code} + +Lastly, the question is: will the C compiler think the types of the +two sides of the assignment match? + + We assume that the types will match + if neither side is a @CVal@ addressing mode for any register + which can point into the heap or B stack. + +Why? Because the heap and B stack are used to store miscellaneous things, +whereas the A stack, temporaries, registers, etc., are only used for things +of fixed type. + +\begin{code} +pprAssign sty kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) + = uppBesides [ pprVanillaReg dest, uppEquals, + pprVanillaReg src, uppSemi ] + +pprAssign sty kind dest src + | mixedTypeLocn dest + -- Add in a cast to StgWord (a.k.a. W_) iff the destination is mixed + = uppBesides [ ppr_amode sty dest, uppEquals, + uppStr "(W_)(", -- Here is the cast + ppr_amode sty src, pp_paren_semi ] + +pprAssign sty kind dest src + | mixedPtrLocn dest && getAmodeKind src /= PtrKind + -- Add in a cast to StgPtr (a.k.a. P_) iff the destination is mixed + = uppBesides [ ppr_amode sty dest, uppEquals, + uppStr "(P_)(", -- Here is the cast + ppr_amode sty src, pp_paren_semi ] + +pprAssign sty ByteArrayKind dest src + | mixedPtrLocn src + -- Add in a cast to StgPtr (a.k.a. B_) iff the source is mixed + = uppBesides [ ppr_amode sty dest, uppEquals, + uppStr "(B_)(", -- Here is the cast + ppr_amode sty src, pp_paren_semi ] + +pprAssign sty kind other_dest src + = uppBesides [ ppr_amode sty other_dest, uppEquals, + pprAmode sty src, uppSemi ] +\end{code} + + +%************************************************************************ +%* * +\subsection[a2r-CAddrModes]{Addressing modes} +%* * +%************************************************************************ + +@pprAmode@ is used to print r-values (which may need casts), whereas +@ppr_amode@ is used for l-values {\em and} as a help function for +@pprAmode@. + +\begin{code} +pprAmode, ppr_amode :: PprStyle -> CAddrMode -> Unpretty +\end{code} + +For reasons discussed above under assignments, @CVal@ modes need +to be treated carefully. First come special cases for floats and doubles, +similar to those in @pprAssign@: + +(NB: @PK_FLT@ and @PK_DBL@ require the {\em address} of the value in +question.) + +\begin{code} +pprAmode sty (CVal reg_rel FloatKind) + = uppBesides [ uppStr "PK_FLT(", ppr_amode sty (CAddr reg_rel), uppRparen ] +pprAmode sty (CVal reg_rel DoubleKind) + = uppBesides [ uppStr "PK_DBL(", ppr_amode sty (CAddr reg_rel), uppRparen ] +\end{code} + +Next comes the case where there is some other cast need, and the +no-cast case: + +\begin{code} +pprAmode sty amode + | mixedTypeLocn amode + = uppBesides [ uppLparen, pprPrimKind sty (getAmodeKind amode), uppStr ")(", + ppr_amode sty amode, uppRparen] + | otherwise -- No cast needed + = ppr_amode sty amode +\end{code} + +Now the rest of the cases for ``workhorse'' @ppr_amode@: + +\begin{code} +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 ] + +ppr_amode sty (CAddr reg_rel) + = case (pprRegRelative sty True{-sign wanted-} reg_rel) of + (pp_reg, Nothing) -> pp_reg + (pp_reg, Just offset) -> uppBeside pp_reg offset + +ppr_amode sty (CReg magic_id) = pprMagicId sty magic_id + +ppr_amode sty (CTemp uniq kind) = prettyToUn (pprUnique uniq) + +ppr_amode sty (CLbl label kind) = pprCLabel sty label + +ppr_amode sty (CUnVecLbl direct vectored) + = uppBesides [uppStr "(StgRetAddr) UNVEC(", pprCLabel sty direct, uppComma, + pprCLabel sty vectored, uppRparen] + +ppr_amode sty (CCharLike char) + = uppBesides [uppStr "CHARLIKE_CLOSURE(", pprAmode sty char, uppRparen ] +ppr_amode sty (CIntLike int) + = uppBesides [uppStr "INTLIKE_CLOSURE(", pprAmode sty int, uppRparen ] + +ppr_amode sty (CString str) = uppBesides [uppChar '"', uppStr (stringToC (_UNPK_ str)), uppChar '"'] + -- ToDo: are these *used* for anything? + +ppr_amode sty (CLit lit) = pprBasicLit sty lit + +ppr_amode sty (CLitLit str _) = uppPStr str + +ppr_amode sty (COffset off) = pprHeapOffset sty off + +ppr_amode sty (CCode abs_C) + = uppAboves [ uppStr "{ -- CCode", uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] + +ppr_amode sty (CLabelledCode label abs_C) + = uppAboves [ uppBesides [pprCLabel sty label, uppStr " = { -- CLabelledCode"], + uppNest 8 (pprAbsC sty abs_C (costs abs_C)), uppChar '}' ] + +ppr_amode sty (CJoinPoint _ _) + = panic "ppr_amode: CJoinPoint" + +ppr_amode sty (CTableEntry base index kind) + = uppBesides [uppStr "((", pprPrimKind sty kind, uppStr " *)(", + ppr_amode sty base, uppStr "))[(I_)(", ppr_amode sty index, + uppStr ")]"] + +ppr_amode sty (CMacroExpr pk macro as) + = uppBesides [uppLparen, pprPrimKind sty pk, uppStr ")(", uppStr (show macro), uppLparen, + uppIntersperse uppComma (map (pprAmode sty) as), uppStr "))"] + +ppr_amode sty (CCostCentre cc print_as_string) + = uppCostCentre sty print_as_string cc +\end{code} + +%************************************************************************ +%* * +\subsection[a2r-MagicIds]{Magic ids} +%* * +%************************************************************************ + +@pprRegRelative@ returns a pair of the @Unpretty@ for the register +(some casting may be required), and a @Maybe Unpretty@ for the offset +(zero offset gives a @Nothing@). + +\begin{code} +addPlusSign :: Bool -> Unpretty -> Unpretty +addPlusSign False p = p +addPlusSign True p = uppBeside (uppChar '+') p + +pprSignedInt :: Bool -> Int -> Maybe Unpretty -- Nothing => 0 +pprSignedInt sign_wanted n + = if n == 0 then Nothing else + if n > 0 then Just (addPlusSign sign_wanted (uppInt n)) + else Just (uppInt n) + +pprRegRelative :: PprStyle + -> Bool -- True <=> Print leading plus sign (if +ve) + -> RegRelative + -> (Unpretty, Maybe Unpretty) + +pprRegRelative sty sign_wanted r@(SpARel spA off) + = (pprMagicId sty SpA, pprSignedInt sign_wanted (spARelToInt r)) + +pprRegRelative sty sign_wanted r@(SpBRel spB off) + = (pprMagicId sty SpB, pprSignedInt sign_wanted (spBRelToInt r)) + +pprRegRelative sty sign_wanted r@(HpRel hp off) + = let to_print = hp `subOff` off + pp_Hp = pprMagicId sty Hp + in + if isZeroOff to_print then + (pp_Hp, Nothing) + else + (pp_Hp, Just (uppBeside (uppChar '-') (pprHeapOffset sty to_print))) + -- No parens needed because pprHeapOffset + -- does them when necessary + +pprRegRelative sty sign_wanted (NodeRel off) + = let pp_Node = pprMagicId sty node + in + if isZeroOff off then + (pp_Node, Nothing) + else + (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset sty off))) + +\end{code} + +@pprMagicId@ just prints the register name. @VanillaReg@ registers are +represented by a discriminated union (@StgUnion@), so we use the @PrimKind@ +to select the union tag. + +\begin{code} +pprMagicId :: PprStyle -> MagicId -> Unpretty + +pprMagicId sty BaseReg = uppPStr SLIT("BaseReg") +pprMagicId sty StkOReg = uppPStr SLIT("StkOReg") +pprMagicId sty (VanillaReg pk n) + = uppBesides [ pprVanillaReg n, uppChar '.', + pprUnionTag pk ] +pprMagicId sty (FloatReg n) = uppBeside (uppPStr SLIT("FltReg")) (uppInt IBOX(n)) +pprMagicId sty (DoubleReg n) = uppBeside (uppPStr SLIT("DblReg")) (uppInt IBOX(n)) +pprMagicId sty TagReg = uppPStr SLIT("TagReg") +pprMagicId sty RetReg = uppPStr SLIT("RetReg") +pprMagicId sty SpA = uppPStr SLIT("SpA") +pprMagicId sty SuA = uppPStr SLIT("SuA") +pprMagicId sty SpB = uppPStr SLIT("SpB") +pprMagicId sty SuB = uppPStr SLIT("SuB") +pprMagicId sty Hp = uppPStr SLIT("Hp") +pprMagicId sty HpLim = uppPStr SLIT("HpLim") +pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg") +pprMagicId sty ActivityReg = uppPStr SLIT("ActivityReg") +pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg") +pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg") +pprMagicId sty CurCostCentre = uppPStr SLIT("CCC") +pprMagicId sty VoidReg = {-uppStr "RetVoid!"-} panic "pprMagicId:VoidReg!" +#ifdef DPH +pprMagicId sty (DataReg _ n) = uppBeside (uppPStr SLIT("RD")) (uppInt n) +#endif {- Data Parallel Haskell -} + +pprVanillaReg :: FAST_INT -> Unpretty + +pprVanillaReg n = uppBeside (uppChar 'R') (uppInt IBOX(n)) + +pprUnionTag :: PrimKind -> Unpretty + +pprUnionTag PtrKind = uppChar 'p' +pprUnionTag CodePtrKind = uppPStr SLIT("fp") +pprUnionTag DataPtrKind = uppChar 'd' +pprUnionTag RetKind = uppChar 'r' +pprUnionTag InfoPtrKind = uppChar 'd' +pprUnionTag CostCentreKind = panic "pprUnionTag:CostCentre?" + +pprUnionTag CharKind = uppChar 'c' +pprUnionTag IntKind = uppChar 'i' +pprUnionTag WordKind = uppChar 'w' +pprUnionTag AddrKind = uppChar 'v' +pprUnionTag FloatKind = uppChar 'f' +pprUnionTag DoubleKind = panic "pprUnionTag:Double?" + +pprUnionTag StablePtrKind = uppChar 'i' +pprUnionTag MallocPtrKind = uppChar 'p' + +pprUnionTag ArrayKind = uppChar 'p' +pprUnionTag ByteArrayKind = uppChar 'b' + +pprUnionTag _ = panic "pprUnionTag:Odd kind" + +\end{code} + + +Find and print local and external declarations for a list of +Abstract~C statements. +\begin{code} +pprTempAndExternDecls :: AbstractC -> (Unpretty{-temps-}, Unpretty{-externs-}) +pprTempAndExternDecls AbsCNop = (uppNil, uppNil) + +pprTempAndExternDecls (AbsCStmts stmt1 stmt2) + = initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) -> + ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) -> + BIND (catMaybes [t_p1, t_p2]) _TO_ real_temps -> + BIND (catMaybes [e_p1, e_p2]) _TO_ real_exts -> + returnTE (uppAboves real_temps, uppAboves real_exts) + BEND BEND + ) + +pprTempAndExternDecls other_stmt + = initTE (ppr_decls_AbsC other_stmt `thenTE` \ (maybe_t, maybe_e) -> + returnTE ( + case maybe_t of + Nothing -> uppNil + Just pp -> pp, + + case maybe_e of + Nothing -> uppNil + Just pp -> pp ) + ) + +pprBasicLit :: PprStyle -> BasicLit -> Unpretty +pprPrimKind :: PprStyle -> PrimKind -> Unpretty + +pprBasicLit sty lit = uppStr (showBasicLit sty lit) +pprPrimKind sty k = uppStr (showPrimKind k) +\end{code} + + +%************************************************************************ +%* * +\subsection[a2r-monad]{Monadery} +%* * +%************************************************************************ + +We need some monadery to keep track of temps and externs we have already +printed. This info must be threaded right through the Abstract~C, so +it's most convenient to hide it in this monad. + +WDP 95/02: Switched from \tr{([Unique], [CLabel])} to +\tr{(UniqSet, CLabelSet)}. Allegedly for efficiency. + +\begin{code} +type CLabelSet = FiniteMap CLabel (){-any type will do-} +emptyCLabelSet = emptyFM +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 TeM result = TEenv -> (TEenv, result) + +initTE :: TeM a -> a +initTE sa + = case sa (emptyUniqueSet, emptyCLabelSet) of { (_, result) -> + result } + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenTE #-} +{-# INLINE returnTE #-} +#endif + +thenTE :: TeM a -> (a -> TeM b) -> TeM b +thenTE a b u + = case a u of { (u_1, result_of_a) -> + b result_of_a u_1 } + +mapTE :: (a -> TeM b) -> [a] -> TeM [b] +mapTE f [] = returnTE [] +mapTE f (x:xs) + = f x `thenTE` \ r -> + mapTE f xs `thenTE` \ rs -> + returnTE (r : rs) + +returnTE :: a -> TeM a +returnTE result env = (env, result) + +-- these next two check whether the thing is already +-- recorded, and THEN THEY RECORD IT +-- (subsequent calls will return False for the same uniq/label) + +tempSeenTE :: Unique -> TeM Bool +tempSeenTE uniq env@(seen_uniqs, seen_labels) + = if (uniq `elementOfUniqueSet` seen_uniqs) + then (env, True) + else ((addToUniqueSet seen_uniqs uniq, + seen_labels), + False) + +labelSeenTE :: CLabel -> TeM Bool +labelSeenTE label env@(seen_uniqs, seen_labels) + = if (label `elementOfCLabelSet` seen_labels) + then (env, True) + else ((seen_uniqs, + addToCLabelSet seen_labels label), + False) +\end{code} + +\begin{code} +pprTempDecl :: Unique -> PrimKind -> Unpretty +pprTempDecl uniq kind + = uppBesides [ pprPrimKind PprDebug kind, uppSP, prettyToUn (pprUnique uniq), uppSemi ] + +ppr_for_C = PprForC ( \ x -> False ) -- pretend no special cmd-line flags + +pprExternDecl :: CLabel -> PrimKind -> Unpretty + +pprExternDecl clabel kind + = if not (needsCDecl clabel) then + uppNil -- do not print anything for "known external" things (e.g., < PreludeCore) + else + BIND ( + case kind of + CodePtrKind -> ppLocalnessMacro True{-function-} clabel + _ -> ppLocalnessMacro False{-data-} clabel + ) _TO_ pp_macro_str -> + + uppBesides [ pp_macro_str, uppLparen, pprCLabel ppr_for_C clabel, pp_paren_semi ] + BEND +\end{code} + +\begin{code} +ppr_decls_AbsC :: AbstractC -> TeM (Maybe Unpretty{-temps-}, Maybe Unpretty{-externs-}) + +ppr_decls_AbsC AbsCNop = returnTE (Nothing, Nothing) + +ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2) + = ppr_decls_AbsC stmts_1 `thenTE` \ p1 -> + ppr_decls_AbsC stmts_2 `thenTE` \ p2 -> + returnTE (maybe_uppAboves [p1, p2]) + +ppr_decls_AbsC (CClosureUpdInfo info) + = ppr_decls_AbsC info + +--UNUSED: ppr_decls_AbsC (CComment comment) = returnTE (Nothing, Nothing) + +ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing) + +ppr_decls_AbsC (CAssign dest source) + = ppr_decls_Amode dest `thenTE` \ p1 -> + ppr_decls_Amode source `thenTE` \ p2 -> + returnTE (maybe_uppAboves [p1, p2]) + +ppr_decls_AbsC (CJump target) = ppr_decls_Amode target + +ppr_decls_AbsC (CFallThrough target) = ppr_decls_Amode target + +ppr_decls_AbsC (CReturn target _) = ppr_decls_Amode target + +ppr_decls_AbsC (CSwitch discrim alts deflt) + = ppr_decls_Amode discrim `thenTE` \ pdisc -> + mapTE ppr_alt_stuff alts `thenTE` \ palts -> + ppr_decls_AbsC deflt `thenTE` \ pdeflt -> + returnTE (maybe_uppAboves (pdisc:pdeflt:palts)) + where + ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC + +ppr_decls_AbsC (CCodeBlock label absC) + = ppr_decls_AbsC absC + +ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre inplace_upd) + -- ToDo: strictly speaking, should chk "cost_centre" amode + = labelSeenTE info_lbl `thenTE` \ label_seen -> + returnTE (Nothing, + if label_seen then + Nothing + else + Just (pprExternDecl info_lbl PtrKind)) + where + info_lbl = infoTableLabelFromCI cl_info + +ppr_decls_AbsC (COpStmt results _ args _ _) = ppr_decls_Amodes (results ++ args) +ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc + +ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes + +ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!! + -- you get some nasty re-decls of stdio.h if you compile + -- the prelude while looking inside those amodes; + -- no real reason to, anyway. +ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes + +ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes) + -- ToDo: strictly speaking, should chk "cost_centre" amode + = ppr_decls_Amodes amodes + +ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl closure_descr) + = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 -> + ppr_decls_AbsC slow `thenTE` \ p2 -> + (case maybe_fast of + Nothing -> returnTE (Nothing, Nothing) + Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 -> + returnTE (maybe_uppAboves [p1, p2, p3]) + where + entry_lbl = CLbl slow_lbl CodePtrKind + slow_lbl = case (nonemptyAbsC slow) of + Nothing -> mkErrorStdEntryLabel + Just _ -> entryLabelFromCI cl_info + +ppr_decls_AbsC (CRetVector label maybe_amodes absC) + = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 -> + ppr_decls_AbsC absC `thenTE` \ p2 -> + returnTE (maybe_uppAboves [p1, p2]) + +ppr_decls_AbsC (CRetUnVector label amode) + = ppr_decls_Amode amode + +ppr_decls_AbsC (CFlatRetVector label amodes) + = ppr_decls_Amodes amodes + +#ifdef DPH +ppr_decls_AbsC (CNativeInfoTableAndCode _ _ absC) + = ppr_decls_AbsC absC +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +ppr_decls_Amode :: CAddrMode -> TeM (Maybe Unpretty, Maybe Unpretty) +ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing) +ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing) +ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing) +ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing) +ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing) +ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing) +ppr_decls_Amode (COffset _) = returnTE (Nothing, Nothing) + +-- CIntLike must be a literal -- no decls +ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing) + +-- CCharLike may have be arbitrary value -- may have decls +ppr_decls_Amode (CCharLike char) + = ppr_decls_Amode char + +-- now, the only place where we actually print temps/externs... +ppr_decls_Amode (CTemp uniq kind) + = case kind of + VoidKind -> returnTE (Nothing, Nothing) + other -> + tempSeenTE uniq `thenTE` \ temp_seen -> + returnTE + (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing) + +ppr_decls_Amode (CLbl label VoidKind) + = returnTE (Nothing, Nothing) + +ppr_decls_Amode (CLbl label kind) + = labelSeenTE label `thenTE` \ label_seen -> + returnTE (Nothing, + if label_seen then Nothing else Just (pprExternDecl label kind)) + +{- WRONG: +ppr_decls_Amode (CUnVecLbl direct vectored) + = labelSeenTE direct `thenTE` \ dlbl_seen -> + labelSeenTE vectored `thenTE` \ vlbl_seen -> + let + ddcl = if dlbl_seen then uppNil else pprExternDecl direct CodePtrKind + vdcl = if vlbl_seen then uppNil else pprExternDecl vectored DataPtrKind + in + returnTE (Nothing, + if (dlbl_seen || not (needsCDecl direct)) && + (vlbl_seen || not (needsCDecl vectored)) then Nothing + else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) +-} + +ppr_decls_Amode (CUnVecLbl direct vectored) + = -- We don't mark either label as "seen", because + -- we don't know which one will be used and which one tossed + -- by the C macro... + --labelSeenTE direct `thenTE` \ dlbl_seen -> + --labelSeenTE vectored `thenTE` \ vlbl_seen -> + let + ddcl = {-if dlbl_seen then uppNil else-} pprExternDecl direct CodePtrKind + vdcl = {-if vlbl_seen then uppNil else-} pprExternDecl vectored DataPtrKind + in + returnTE (Nothing, + if ({-dlbl_seen ||-} not (needsCDecl direct)) && + ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing + else Just (uppBesides [uppStr "UNVEC(", ddcl, uppComma, vdcl, uppRparen])) + +ppr_decls_Amode (CTableEntry base index _) + = ppr_decls_Amode base `thenTE` \ p1 -> + ppr_decls_Amode index `thenTE` \ p2 -> + returnTE (maybe_uppAboves [p1, p2]) + +ppr_decls_Amode (CMacroExpr _ _ amodes) + = ppr_decls_Amodes amodes + +ppr_decls_Amode other = returnTE (Nothing, Nothing) + + +maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty) +maybe_uppAboves ps + = BIND (unzip ps) _TO_ (ts, es) -> + BIND (catMaybes ts) _TO_ real_ts -> + BIND (catMaybes es) _TO_ real_es -> + (if (null real_ts) then Nothing else Just (uppAboves real_ts), + if (null real_es) then Nothing else Just (uppAboves real_es)) + BEND BEND BEND +\end{code} + +\begin{code} +ppr_decls_Amodes :: [CAddrMode] -> TeM (Maybe Unpretty, Maybe Unpretty) +ppr_decls_Amodes amodes + = mapTE ppr_decls_Amode amodes `thenTE` \ ps -> + returnTE ( maybe_uppAboves ps ) +\end{code} diff --git a/ghc/compiler/abstractSyn/AbsSyn.hi b/ghc/compiler/abstractSyn/AbsSyn.hi new file mode 100644 index 0000000..ad4aab0 --- /dev/null +++ b/ghc/compiler/abstractSyn/AbsSyn.hi @@ -0,0 +1,798 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsSyn where +import AbsSynFuns(cmpInstanceTypes, collectBinders, collectMonoBinders, collectMonoBindersAndLocs, collectPatBinders, collectQualBinders, collectTopLevelBinders, collectTypedBinders, collectTypedPatBinders, extractMonoTyNames, getNonPrelOuterTyCon, mkDictApp, mkDictLam, mkTyApp, mkTyLam) +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CharSeq(CSeq) +import Class(Class, ClassOp, cmpClass) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import FiniteMap(FiniteMap) +import HsBinds(Bind(..), Binds(..), MonoBinds(..), ProtoNameBind(..), ProtoNameBinds(..), ProtoNameClassOpSig(..), ProtoNameMonoBinds(..), ProtoNameSig(..), RenamedBind(..), RenamedBinds(..), RenamedClassOpSig(..), RenamedMonoBinds(..), RenamedSig(..), Sig(..), TypecheckedBind(..), TypecheckedBinds(..), TypecheckedMonoBinds(..), nullBinds, nullMonoBinds) +import HsCore(UfCostCentre, UfId, UnfoldingCoreAlts, UnfoldingCoreAtom, UnfoldingCoreBinding, UnfoldingCoreExpr, UnfoldingPrimOp) +import HsDecls(ClassDecl(..), ConDecl(..), DataTypeSig(..), DefaultDecl(..), FixityDecl(..), InstDecl(..), ProtoNameClassDecl(..), ProtoNameConDecl(..), ProtoNameDataTypeSig(..), ProtoNameDefaultDecl(..), ProtoNameFixityDecl(..), ProtoNameInstDecl(..), ProtoNameSpecialisedInstanceSig(..), ProtoNameTyDecl(..), RenamedClassDecl(..), RenamedConDecl(..), RenamedDataTypeSig(..), RenamedDefaultDecl(..), RenamedFixityDecl(..), RenamedInstDecl(..), RenamedSpecialisedInstanceSig(..), RenamedTyDecl(..), SpecialisedInstanceSig(..), TyDecl(..), eqConDecls) +import HsExpr(ArithSeqInfo(..), Expr(..), ProtoNameArithSeqInfo(..), ProtoNameExpr(..), ProtoNameQual(..), Qual(..), RenamedArithSeqInfo(..), RenamedExpr(..), RenamedQual(..), TypecheckedArithSeqInfo(..), TypecheckedExpr(..), TypecheckedQual(..)) +import HsImpExp(IE(..), IfaceImportDecl(..), ImExportListInfo(..), ImportedInterface(..), Interface(..), ProtoNameImportedInterface(..), ProtoNameInterface(..), RenamedImportedInterface(..), RenamedInterface(..), Renaming(..), getIEStrings, getRawIEStrings) +import HsLit(Literal(..), negLiteral) +import HsMatches(GRHS(..), GRHSsAndBinds(..), Match(..), ProtoNameGRHS(..), ProtoNameGRHSsAndBinds(..), ProtoNameMatch(..), RenamedGRHS(..), RenamedGRHSsAndBinds(..), RenamedMatch(..), TypecheckedGRHS(..), TypecheckedGRHSsAndBinds(..), TypecheckedMatch(..)) +import HsPat(InPat(..), ProtoNamePat(..), RenamedPat(..), TypecheckedPat(..), irrefutablePat, isConPat, isLitPat, patsAreAllCons, patsAreAllLits, typeOfPat, unfailablePat, unfailablePats) +import HsPragmas(ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, ImpStrictness, ImpUnfolding, InstancePragmas, ProtoNameClassOpPragmas(..), ProtoNameClassPragmas(..), ProtoNameDataPragmas(..), ProtoNameGenPragmas(..), ProtoNameInstancePragmas(..), RenamedClassOpPragmas(..), RenamedClassPragmas(..), RenamedDataPragmas(..), RenamedGenPragmas(..), RenamedInstancePragmas(..), TypePragmas) +import HsTypes(ClassAssertion(..), Context(..), MonoType(..), PolyType(..), ProtoNameContext(..), ProtoNameMonoType(..), ProtoNamePolyType(..), RenamedContext(..), RenamedMonoType(..), RenamedPolyType(..), cmpPolyType, eqMonoType, pprContext) +import Id(DictVar(..), Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import InstEnv(InstTemplate) +import Maybes(Labda) +import Name(Name(..)) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp, pprPrimOp) +import ProtoName(ProtoName) +import RenameAuxFuns(PreludeNameFun(..)) +import SimplEnv(UnfoldingDetails, UnfoldingGuidance) +import SrcLoc(SrcLoc) +import TyCon(Arity(..), TyCon, cmpTyCon) +import TyVar(TyVar, TyVarTemplate, cmpTyVar) +import UniType(TauType(..), UniType, cmpUniType) +import UniqFM(UniqFM) +import Unique(Unique) +class OptIdInfo a where + noInfo :: a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-} + getInfo :: IdInfo -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-} + addInfo :: IdInfo -> a -> IdInfo + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-} + ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-} +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data Bind a b = EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) +data Binds a b = EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) +data MonoBinds a b = EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc +type ProtoNameBind = Bind ProtoName (InPat ProtoName) +type ProtoNameBinds = Binds ProtoName (InPat ProtoName) +type ProtoNameClassOpSig = Sig ProtoName +type ProtoNameMonoBinds = MonoBinds ProtoName (InPat ProtoName) +type ProtoNameSig = Sig ProtoName +type RenamedBind = Bind Name (InPat Name) +type RenamedBinds = Binds Name (InPat Name) +type RenamedClassOpSig = Sig Name +type RenamedMonoBinds = MonoBinds Name (InPat Name) +type RenamedSig = Sig Name +data Sig a = Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc +type TypecheckedBind = Bind Id TypecheckedPat +type TypecheckedBinds = Binds Id TypecheckedPat +type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat +data UfCostCentre a {-# GHC_PRAGMA UfPreludeDictsCC Bool | UfAllDictsCC _PackedString _PackedString Bool | UfUserCC _PackedString _PackedString _PackedString Bool Bool | UfAutoCC (UfId a) _PackedString _PackedString Bool Bool | UfDictCC (UfId a) _PackedString _PackedString Bool Bool #-} +data UnfoldingCoreAtom a {-# GHC_PRAGMA UfCoVarAtom (UfId a) | UfCoLitAtom BasicLit #-} +data UnfoldingCoreExpr a {-# GHC_PRAGMA UfCoVar (UfId a) | UfCoLit BasicLit | UfCoCon a [PolyType a] [UnfoldingCoreAtom a] | UfCoPrim (UnfoldingPrimOp a) [PolyType a] [UnfoldingCoreAtom a] | UfCoLam [(a, PolyType a)] (UnfoldingCoreExpr a) | UfCoTyLam a (UnfoldingCoreExpr a) | UfCoApp (UnfoldingCoreExpr a) (UnfoldingCoreAtom a) | UfCoTyApp (UnfoldingCoreExpr a) (PolyType a) | UfCoCase (UnfoldingCoreExpr a) (UnfoldingCoreAlts a) | UfCoLet (UnfoldingCoreBinding a) (UnfoldingCoreExpr a) | UfCoSCC (UfCostCentre a) (UnfoldingCoreExpr a) #-} +data UnfoldingPrimOp a {-# GHC_PRAGMA UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp #-} +data ClassDecl a b = ClassDecl [(a, a)] a a [Sig a] (MonoBinds a b) (ClassPragmas a) SrcLoc +data ConDecl a = ConDecl a [MonoType a] SrcLoc +data DataTypeSig a = AbstractTypeSig a SrcLoc | SpecDataSig a (MonoType a) SrcLoc +data DefaultDecl a = DefaultDecl [MonoType a] SrcLoc +data FixityDecl a = InfixL a Int | InfixR a Int | InfixN a Int +data InstDecl a b = InstDecl [(a, a)] a (MonoType a) (MonoBinds a b) Bool _PackedString _PackedString [Sig a] (InstancePragmas a) SrcLoc +type ProtoNameClassDecl = ClassDecl ProtoName (InPat ProtoName) +type ProtoNameConDecl = ConDecl ProtoName +type ProtoNameDataTypeSig = DataTypeSig ProtoName +type ProtoNameDefaultDecl = DefaultDecl ProtoName +type ProtoNameFixityDecl = FixityDecl ProtoName +type ProtoNameInstDecl = InstDecl ProtoName (InPat ProtoName) +type ProtoNameSpecialisedInstanceSig = SpecialisedInstanceSig ProtoName +type ProtoNameTyDecl = TyDecl ProtoName +type RenamedClassDecl = ClassDecl Name (InPat Name) +type RenamedConDecl = ConDecl Name +type RenamedDataTypeSig = DataTypeSig Name +type RenamedDefaultDecl = DefaultDecl Name +type RenamedFixityDecl = FixityDecl Name +type RenamedInstDecl = InstDecl Name (InPat Name) +type RenamedSpecialisedInstanceSig = SpecialisedInstanceSig Name +type RenamedTyDecl = TyDecl Name +data SpecialisedInstanceSig a = InstSpecSig a (MonoType a) SrcLoc +data TyDecl a = TyData [(a, a)] a [a] [ConDecl a] [a] (DataPragmas a) SrcLoc | TySynonym a [a] (MonoType a) TypePragmas SrcLoc +data ArithSeqInfo a b = From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) +data Expr a b = Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id +type ProtoNameArithSeqInfo = ArithSeqInfo ProtoName (InPat ProtoName) +type ProtoNameExpr = Expr ProtoName (InPat ProtoName) +type ProtoNameQual = Qual ProtoName (InPat ProtoName) +data Qual a b = GeneratorQual b (Expr a b) | FilterQual (Expr a b) +type RenamedArithSeqInfo = ArithSeqInfo Name (InPat Name) +type RenamedExpr = Expr Name (InPat Name) +type RenamedQual = Qual Name (InPat Name) +type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat +type TypecheckedExpr = Expr Id TypecheckedPat +type TypecheckedQual = Qual Id TypecheckedPat +data IE = IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString +data IfaceImportDecl = IfaceImportDecl _PackedString [IE] [Renaming] SrcLoc +type ImExportListInfo = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) +data ImportedInterface a b = ImportAll (Interface a b) [Renaming] | ImportSome (Interface a b) [IE] [Renaming] | ImportButHide (Interface a b) [IE] [Renaming] +data Interface a b = MkInterface _PackedString [IfaceImportDecl] [FixityDecl a] [TyDecl a] [ClassDecl a b] [InstDecl a b] [Sig a] SrcLoc +type ProtoNameImportedInterface = ImportedInterface ProtoName (InPat ProtoName) +type ProtoNameInterface = Interface ProtoName (InPat ProtoName) +type RenamedImportedInterface = ImportedInterface Name (InPat Name) +type RenamedInterface = Interface Name (InPat Name) +data Renaming = MkRenaming _PackedString _PackedString +data Literal = CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) +data GRHS a b = GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc +data GRHSsAndBinds a b = GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType +data Match a b = PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) +type ProtoNameGRHS = GRHS ProtoName (InPat ProtoName) +type ProtoNameGRHSsAndBinds = GRHSsAndBinds ProtoName (InPat ProtoName) +type ProtoNameMatch = Match ProtoName (InPat ProtoName) +type RenamedGRHS = GRHS Name (InPat Name) +type RenamedGRHSsAndBinds = GRHSsAndBinds Name (InPat Name) +type RenamedMatch = Match Name (InPat Name) +type TypecheckedGRHS = GRHS Id TypecheckedPat +type TypecheckedGRHSsAndBinds = GRHSsAndBinds Id TypecheckedPat +type TypecheckedMatch = Match Id TypecheckedPat +data InPat a = WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal +type ProtoNamePat = InPat ProtoName +type RenamedPat = InPat Name +data TypecheckedPat = WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) +data ClassOpPragmas a {-# GHC_PRAGMA NoClassOpPragmas | ClassOpPragmas (GenPragmas a) (GenPragmas a) #-} +data ClassPragmas a {-# GHC_PRAGMA NoClassPragmas | SuperDictPragmas [GenPragmas a] #-} +data DataPragmas a {-# GHC_PRAGMA DataPragmas [ConDecl a] [[Labda (MonoType a)]] #-} +data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-} +data InstancePragmas a {-# GHC_PRAGMA NoInstancePragmas | SimpleInstancePragma (GenPragmas a) | ConstantInstancePragma (GenPragmas a) [(a, GenPragmas a)] | SpecialisedInstancePragma (GenPragmas a) [([Labda (MonoType a)], Int, InstancePragmas a)] #-} +type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName +type ProtoNameClassPragmas = ClassPragmas ProtoName +type ProtoNameDataPragmas = DataPragmas ProtoName +type ProtoNameGenPragmas = GenPragmas ProtoName +type ProtoNameInstancePragmas = InstancePragmas ProtoName +type RenamedClassOpPragmas = ClassOpPragmas Name +type RenamedClassPragmas = ClassPragmas Name +type RenamedDataPragmas = DataPragmas Name +type RenamedGenPragmas = GenPragmas Name +type RenamedInstancePragmas = InstancePragmas Name +data TypePragmas {-# GHC_PRAGMA NoTypePragmas | AbstractTySynonym #-} +type ClassAssertion a = (a, a) +type Context a = [(a, a)] +data MonoType a = MonoTyVar a | MonoTyCon a [MonoType a] | FunMonoTy (MonoType a) (MonoType a) | ListMonoTy (MonoType a) | TupleMonoTy [PolyType a] | MonoTyVarTemplate a | MonoDict a (MonoType a) +data PolyType a = UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) +type ProtoNameContext = [(ProtoName, ProtoName)] +type ProtoNameMonoType = MonoType ProtoName +type ProtoNamePolyType = PolyType ProtoName +type RenamedContext = [(Name, Name)] +type RenamedMonoType = MonoType Name +type RenamedPolyType = PolyType Name +type DictVar = Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-} +data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-} +data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-} +data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-} +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-} +data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-} +data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-} +data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-} +data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data Module a b = Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type PreludeNameFun = _PackedString -> Labda Name +type Arity = Int +type ProtoNameModule = Module ProtoName (InPat ProtoName) +type RenamedModule = Module Name (InPat Name) +data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-} +data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +type TauType = UniType +type TypecheckedModule = Module Id TypecheckedPat +data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-} +data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +cmpInstanceTypes :: MonoType ProtoName -> MonoType ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +collectBinders :: Bind a (InPat a) -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectMonoBinders :: MonoBinds a (InPat a) -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectMonoBindersAndLocs :: MonoBinds a (InPat a) -> [(a, SrcLoc)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectPatBinders :: InPat a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectQualBinders :: [Qual Name (InPat Name)] -> [Name] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectTopLevelBinders :: Binds a (InPat a) -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectTypedBinders :: Bind Id TypecheckedPat -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectTypedPatBinders :: TypecheckedPat -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractMonoTyNames :: (a -> a -> Bool) -> MonoType a -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +getNonPrelOuterTyCon :: MonoType ProtoName -> Labda ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: MonoType ProtoName) -> case u0 of { _ALG_ _ORIG_ HsTypes MonoTyCon (u1 :: ProtoName) (u2 :: [MonoType ProtoName]) -> _!_ _ORIG_ Maybes Ni [ProtoName] [u1]; (u3 :: MonoType ProtoName) -> _!_ _ORIG_ Maybes Hamna [ProtoName] [] } _N_ #-} +mkDictApp :: Expr Id TypecheckedPat -> [Id] -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [Id]) -> case u1 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-} +mkDictLam :: [Id] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [Id]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkTyApp :: Expr Id TypecheckedPat -> [UniType] -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [UniType]) -> case u1 of { _ALG_ (:) (u2 :: UniType) (u3 :: [UniType]) -> _!_ _ORIG_ HsExpr TyApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-} +mkTyLam :: [TyVar] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [TyVar]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: TyVar) (u3 :: [TyVar]) -> _!_ _ORIG_ HsExpr TyLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +cmpClass :: Class -> Class -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +nullBinds :: Binds a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +nullMonoBinds :: MonoBinds a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +eqConDecls :: [ConDecl ProtoName] -> [ConDecl ProtoName] -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +getIEStrings :: [IE] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getRawIEStrings :: [IE] -> ([(_PackedString, ExportFlag)], [_PackedString]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +negLiteral :: Literal -> Literal + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +irrefutablePat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isConPat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isLitPat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +patsAreAllCons :: [TypecheckedPat] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +patsAreAllLits :: [TypecheckedPat] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfPat :: TypecheckedPat -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unfailablePat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unfailablePats :: [TypecheckedPat] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +cmpPolyType :: (a -> a -> Int#) -> PolyType a -> PolyType a -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +eqMonoType :: MonoType ProtoName -> MonoType ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +pprContext :: Outputable a => PprStyle -> [(a, a)] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-} +pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpTyVar :: TyVar -> TyVar -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +instance Eq BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Demand -> Demand -> Bool), (Demand -> Demand -> Bool)] [_CONSTM_ Eq (==) (Demand), _CONSTM_ Eq (/=) (Demand)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq FBConsum + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBConsum -> FBConsum -> Bool), (FBConsum -> FBConsum -> Bool)] [_CONSTM_ Eq (==) (FBConsum), _CONSTM_ Eq (/=) (FBConsum)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq FBProd + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBProd -> FBProd -> Bool), (FBProd -> FBProd -> Bool)] [_CONSTM_ Eq (==) (FBProd), _CONSTM_ Eq (/=) (FBProd)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq FBType + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBType -> FBType -> Bool), (FBType -> FBType -> Bool)] [_CONSTM_ Eq (==) (FBType), _CONSTM_ Eq (/=) (FBType)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Eq UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool)] [_CONSTM_ Eq (==) (UpdateInfo), _CONSTM_ Eq (/=) (UpdateInfo)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Name -> Name -> Bool), (Name -> Name -> Bool)] [_CONSTM_ Eq (==) (Name), _CONSTM_ Eq (/=) (Name)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance OptIdInfo ArgUsageInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArgUsageInfo, (IdInfo -> ArgUsageInfo), (IdInfo -> ArgUsageInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArgUsageInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo getInfo (ArgUsageInfo), _CONSTM_ OptIdInfo addInfo (ArgUsageInfo), _CONSTM_ OptIdInfo ppInfo (ArgUsageInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoArgUsageInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArgUsageInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u8; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo ArityInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArityInfo, (IdInfo -> ArityInfo), (IdInfo -> ArityInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArityInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo getInfo (ArityInfo), _CONSTM_ OptIdInfo addInfo (ArityInfo), _CONSTM_ OptIdInfo ppInfo (ArityInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownArity [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArityInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo DeforestInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DeforestInfo, (IdInfo -> DeforestInfo), (IdInfo -> DeforestInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DeforestInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo getInfo (DeforestInfo), _CONSTM_ OptIdInfo addInfo (DeforestInfo), _CONSTM_ OptIdInfo ppInfo (DeforestInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo Don'tDeforest [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAEAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DeforestInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u7; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)E" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAE" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo DemandInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DemandInfo, (IdInfo -> DemandInfo), (IdInfo -> DemandInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DemandInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DemandInfo), _CONSTM_ OptIdInfo getInfo (DemandInfo), _CONSTM_ OptIdInfo addInfo (DemandInfo), _CONSTM_ OptIdInfo ppInfo (DemandInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownDemand [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DemandInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LALLLLLLLL)L" _N_ _N_, + ppInfo = _A_ 3 _U_ 10122 _N_ _S_ "SAL" {_A_ 2 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo FBTypeInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [FBTypeInfo, (IdInfo -> FBTypeInfo), (IdInfo -> FBTypeInfo -> IdInfo), (PprStyle -> (Id -> Id) -> FBTypeInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (FBTypeInfo), _CONSTM_ OptIdInfo getInfo (FBTypeInfo), _CONSTM_ OptIdInfo addInfo (FBTypeInfo), _CONSTM_ OptIdInfo ppInfo (FBTypeInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoFBTypeInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: FBTypeInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u9; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20222 _N_ _S_ "SAS" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo SpecEnv + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [SpecEnv, (IdInfo -> SpecEnv), (IdInfo -> SpecEnv -> IdInfo), (PprStyle -> (Id -> Id) -> SpecEnv -> Int -> Bool -> PrettyRep)] [_ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo getInfo (SpecEnv), _CONSTM_ OptIdInfo addInfo (SpecEnv), _CONSTM_ OptIdInfo ppInfo (SpecEnv)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ IdInfo nullSpecEnv _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAU(L)AAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u3; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 11 _N_ _S_ "U(LLU(L)LLLLLLL)U(L)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLU(S)" {_A_ 3 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo StrictnessInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [StrictnessInfo, (IdInfo -> StrictnessInfo), (IdInfo -> StrictnessInfo -> IdInfo), (PprStyle -> (Id -> Id) -> StrictnessInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (StrictnessInfo), _CONSTM_ OptIdInfo getInfo (StrictnessInfo), _CONSTM_ OptIdInfo addInfo (StrictnessInfo), _CONSTM_ OptIdInfo ppInfo (StrictnessInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoStrictnessInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StrictnessInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-} +instance OptIdInfo UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [UpdateInfo, (IdInfo -> UpdateInfo), (IdInfo -> UpdateInfo -> IdInfo), (PprStyle -> (Id -> Id) -> UpdateInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo getInfo (UpdateInfo), _CONSTM_ OptIdInfo addInfo (UpdateInfo), _CONSTM_ OptIdInfo ppInfo (UpdateInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoUpdateInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UpdateInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Demand}}, (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Demand), (Demand -> Demand -> Demand), (Demand -> Demand -> _CMP_TAG)] [_DFUN_ Eq (Demand), _CONSTM_ Ord (<) (Demand), _CONSTM_ Ord (<=) (Demand), _CONSTM_ Ord (>=) (Demand), _CONSTM_ Ord (>) (Demand), _CONSTM_ Ord max (Demand), _CONSTM_ Ord min (Demand), _CONSTM_ Ord _tagCmp (Demand)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq UpdateInfo}}, (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> _CMP_TAG)] [_DFUN_ Eq (UpdateInfo), _CONSTM_ Ord (<) (UpdateInfo), _CONSTM_ Ord (<=) (UpdateInfo), _CONSTM_ Ord (>=) (UpdateInfo), _CONSTM_ Ord (>) (UpdateInfo), _CONSTM_ Ord max (UpdateInfo), _CONSTM_ Ord min (UpdateInfo), _CONSTM_ Ord _tagCmp (UpdateInfo)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Name}}, (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Name), (Name -> Name -> Name), (Name -> Name -> _CMP_TAG)] [_DFUN_ Eq (Name), _CONSTM_ Ord (<) (Name), _CONSTM_ Ord (<=) (Name), _CONSTM_ Ord (>=) (Name), _CONSTM_ Ord (>) (Name), _CONSTM_ Ord max (Name), _CONSTM_ Ord min (Name), _CONSTM_ Ord _tagCmp (Name)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing a => NamedThing (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-} +instance NamedThing TypecheckedPat + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TypecheckedPat -> ExportFlag), (TypecheckedPat -> Bool), (TypecheckedPat -> (_PackedString, _PackedString)), (TypecheckedPat -> _PackedString), (TypecheckedPat -> [_PackedString]), (TypecheckedPat -> SrcLoc), (TypecheckedPat -> Unique), (TypecheckedPat -> Bool), (TypecheckedPat -> UniType), (TypecheckedPat -> Bool)] [_CONSTM_ NamedThing getExportFlag (TypecheckedPat), _CONSTM_ NamedThing isLocallyDefined (TypecheckedPat), _CONSTM_ NamedThing getOrigName (TypecheckedPat), _CONSTM_ NamedThing getOccurrenceName (TypecheckedPat), _CONSTM_ NamedThing getInformingModules (TypecheckedPat), _CONSTM_ NamedThing getSrcLoc (TypecheckedPat), _CONSTM_ NamedThing getTheUnique (TypecheckedPat), _CONSTM_ NamedThing hasType (TypecheckedPat), _ORIG_ HsPat typeOfPat, _CONSTM_ NamedThing fromPreludeCore (TypecheckedPat)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TypecheckedPat) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ HsPat typeOfPat _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Name -> ExportFlag), (Name -> Bool), (Name -> (_PackedString, _PackedString)), (Name -> _PackedString), (Name -> [_PackedString]), (Name -> SrcLoc), (Name -> Unique), (Name -> Bool), (Name -> UniType), (Name -> Bool)] [_CONSTM_ NamedThing getExportFlag (Name), _CONSTM_ NamedThing isLocallyDefined (Name), _CONSTM_ NamedThing getOrigName (Name), _CONSTM_ NamedThing getOccurrenceName (Name), _CONSTM_ NamedThing getInformingModules (Name), _CONSTM_ NamedThing getSrcLoc (Name), _CONSTM_ NamedThing getTheUnique (Name), _CONSTM_ NamedThing hasType (Name), _CONSTM_ NamedThing getType (Name), _CONSTM_ NamedThing fromPreludeCore (Name)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Name" ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Name) -> _!_ False [] [] _N_, + getType = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { UniType } [ _NOREP_S_ "NamedThing.Name.getType" ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-} +instance NamedThing ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +instance NamedThing ProtoName + {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ProtoName -> ExportFlag), (ProtoName -> Bool), (ProtoName -> (_PackedString, _PackedString)), (ProtoName -> _PackedString), (ProtoName -> [_PackedString]), (ProtoName -> SrcLoc), (ProtoName -> Unique), (ProtoName -> Bool), (ProtoName -> UniType), (ProtoName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ProtoName), _CONSTM_ NamedThing isLocallyDefined (ProtoName), _CONSTM_ NamedThing getOrigName (ProtoName), _CONSTM_ NamedThing getOccurrenceName (ProtoName), _CONSTM_ NamedThing getInformingModules (ProtoName), _CONSTM_ NamedThing getSrcLoc (ProtoName), _CONSTM_ NamedThing getTheUnique (ProtoName), _CONSTM_ NamedThing hasType (ProtoName), _CONSTM_ NamedThing getType (ProtoName), _CONSTM_ NamedThing fromPreludeCore (ProtoName)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: ProtoName) -> case u0 of { _ALG_ _ORIG_ ProtoName Unk (u1 :: _PackedString) -> u1; _ORIG_ ProtoName Imp (u2 :: _PackedString) (u3 :: _PackedString) (u4 :: [_PackedString]) (u5 :: _PackedString) -> u5; _ORIG_ ProtoName Prel (u6 :: Name) -> _APP_ _CONSTM_ NamedThing getOccurrenceName (Name) [ u6 ]; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ProtoName) -> _!_ False [] [] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Module a b) + {-# GHC_PRAGMA _M_ AbsSyn {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_ + ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable a => Outputable (FiniteMap a b) + {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Bind a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (MonoBinds a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (Sig a) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (UnfoldingCoreAtom a) + {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (UnfoldingCoreExpr a) + {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (UnfoldingPrimOp a) + {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ClassDecl a b) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (ConDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (DataTypeSig a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (DefaultDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (FixityDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (InstDecl a b) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (SpecialisedInstanceSig a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (TyDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ArithSeqInfo a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Qual a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable IE + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IE) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable IfaceImportDecl + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IfaceImportDecl) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLA)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ImportedInterface a b) + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Interface a b) + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable Renaming + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Renaming) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AU(LL)" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Literal + {-# GHC_PRAGMA _M_ HsLit {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Literal) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Match a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: Match u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: Match", u8, u9 ] _N_ #-} +instance Outputable a => Outputable (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable TypecheckedPat + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (ClassOpPragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (ClassPragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (GenPragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (InstancePragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (MonoType a) + {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (PolyType a) + {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Demand) _N_ + ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Inst + {-# GHC_PRAGMA _M_ Inst {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Inst) _N_ + ppr = _A_ 2 _U_ 1222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Name) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +instance Outputable FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_ + ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} +instance Outputable ProtoName + {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ProtoName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +instance Outputable SrcLoc + {-# GHC_PRAGMA _M_ SrcLoc {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (SrcLoc) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_ + ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Text Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Demand, [Char])]), (Int -> Demand -> [Char] -> [Char]), ([Char] -> [([Demand], [Char])]), ([Demand] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Demand), _CONSTM_ Text showsPrec (Demand), _CONSTM_ Text readList (Demand), _CONSTM_ Text showList (Demand)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Demand, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Demand) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> Demand -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_, + readList = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + showList = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance Text UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(UpdateInfo, [Char])]), (Int -> UpdateInfo -> [Char] -> [Char]), ([Char] -> [([UpdateInfo], [Char])]), ([UpdateInfo] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (UpdateInfo), _CONSTM_ Text showsPrec (UpdateInfo), _CONSTM_ Text readList (UpdateInfo), _CONSTM_ Text showList (UpdateInfo)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: UpdateInfo) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> UpdateInfo -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/AbsSyn.lhs b/ghc/compiler/abstractSyn/AbsSyn.lhs new file mode 100644 index 0000000..b7f494a --- /dev/null +++ b/ghc/compiler/abstractSyn/AbsSyn.lhs @@ -0,0 +1,301 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[AbsSyntax]{Abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. + +The abstract syntax, used in the front end of the compiler, follows +that of a paper on the static semantics of Haskell by Simon Peyton +Jones and Phil Wadler. + +The abstract syntax is parameterised with respect to variables +(abbrev: \tr{name}) and patterns (abbrev: \tr{pat}); here is a typical +example: +\begin{pseudocode} +type ProtoNameExpr = Expr ProtoName ProtoNamePat +type TypecheckedExpr = Expr Id TypecheckedPat +\end{pseudocode} +Some parts of the syntax are unparameterised, because there is no +need for them to be. + +\begin{code} +#include "HsVersions.h" + +module AbsSyn ( + -- the mostly-parameterised data types + ArithSeqInfo(..), + Bind(..), + Binds(..), + ClassDecl(..), + ClassPragmas, -- abstract + ConDecl(..), + DefaultDecl(..), + Expr(..), + FixityDecl(..), + GRHSsAndBinds(..), + GRHS(..), + IE(..), + ImportedInterface(..), + IfaceImportDecl(..), + InPat(..), + InstDecl(..), + InstancePragmas, -- abstract + Interface(..), + Literal(..), + Match(..), + Module(..), + MonoBinds(..), + MonoType(..), + PolyType(..), + Qual(..), + Renaming(..), + Sig(..), + GenPragmas, -- abstract + ClassOpPragmas, -- abstract + TyDecl(..), + DataPragmas, -- abstract + TypePragmas, -- abstract + TypecheckedPat(..), + SpecialisedInstanceSig(..), -- a user pragma + DataTypeSig(..), + + Context(..), -- synonyms + ClassAssertion(..), + + -- synonyms for the (unparameterised) typechecker input + ProtoNameArithSeqInfo(..), + ProtoNameBind(..), + ProtoNameBinds(..), + ProtoNameClassDecl(..), + ProtoNameClassPragmas(..), + ProtoNameConDecl(..), + ProtoNameContext(..), + ProtoNameDefaultDecl(..), + ProtoNameExpr(..), + ProtoNameFixityDecl(..), + ProtoNameGRHSsAndBinds(..), + ProtoNameGRHS(..), + ProtoNameImportedInterface(..), + ProtoNameInstDecl(..), + ProtoNameInstancePragmas(..), + ProtoNameInterface(..), + ProtoNameMatch(..), + ProtoNameModule(..), + ProtoNameMonoBinds(..), + ProtoNameMonoType(..), + ProtoNamePat(..), + ProtoNamePolyType(..), + ProtoNameQual(..), + ProtoNameSig(..), + ProtoNameClassOpSig(..), + ProtoNameGenPragmas(..), + ProtoNameClassOpPragmas(..), + ProtoNameTyDecl(..), + ProtoNameDataPragmas(..), + ProtoNameSpecialisedInstanceSig(..), + ProtoNameDataTypeSig(..), + + RenamedArithSeqInfo(..), + RenamedBind(..), + RenamedBinds(..), + RenamedClassDecl(..), + RenamedClassPragmas(..), + RenamedConDecl(..), + RenamedContext(..), + RenamedDefaultDecl(..), + RenamedExpr(..), + RenamedFixityDecl(..), + RenamedGRHSsAndBinds(..), + RenamedGRHS(..), + RenamedImportedInterface(..), + RenamedInstDecl(..), + RenamedInstancePragmas(..), + RenamedInterface(..), + RenamedMatch(..), + RenamedModule(..), + RenamedMonoBinds(..), + RenamedMonoType(..), + RenamedPat(..), + RenamedPolyType(..), + RenamedQual(..), + RenamedSig(..), + RenamedClassOpSig(..), + RenamedGenPragmas(..), + RenamedClassOpPragmas(..), + RenamedTyDecl(..), + RenamedDataPragmas(..), + RenamedSpecialisedInstanceSig(..), + RenamedDataTypeSig(..), + + -- synonyms for the (unparameterised) typechecker output + TypecheckedArithSeqInfo(..), + TypecheckedBind(..), + TypecheckedBinds(..), + TypecheckedExpr(..), + TypecheckedGRHSsAndBinds(..), + TypecheckedGRHS(..), + TypecheckedMatch(..), + TypecheckedMonoBinds(..), + TypecheckedModule(..), + TypecheckedQual(..), + + -- little help functions (AbsSynFuns) + collectTopLevelBinders, + collectBinders, collectTypedBinders, + collectMonoBinders, + collectMonoBindersAndLocs, + collectQualBinders, + collectPatBinders, + collectTypedPatBinders, + extractMonoTyNames, + cmpInstanceTypes, getNonPrelOuterTyCon, + getIEStrings, getRawIEStrings, ImExportListInfo(..), +--OLD: getMentionedVars, + mkDictApp, + mkDictLam, + mkTyApp, + mkTyLam, + nullBinds, + nullMonoBinds, + isLitPat, patsAreAllLits, isConPat, patsAreAllCons, + irrefutablePat, +#ifdef DPH + patsAreAllProcessor, +#endif + unfailablePat, unfailablePats, + pprContext, + typeOfPat, + negLiteral, + + eqConDecls, eqMonoType, cmpPolyType, + + -- imported things so we get a closed interface + Outputable(..), NamedThing(..), + ExportFlag, SrcLoc, + Pretty(..), PprStyle, PrettyRep, + + OptIdInfo(..), -- I hate the instance virus! + IdInfo, SpecEnv, StrictnessInfo, UpdateInfo, ArityInfo, + DemandInfo, Demand, ArgUsageInfo, ArgUsage, DeforestInfo, + FBTypeInfo, FBType, FBConsum, FBProd, + + Name(..), -- NB: goes out *WITH* constructors + Id, DictVar(..), Inst, ProtoName, TyVar, UniType, TauType(..), + Maybe, PreludeNameFun(..), Unique, + FullName, ShortName, Arity(..), TyCon, Class, ClassOp, + UnfoldingGuidance, BinderInfo, BasicLit, PrimOp, PrimKind, + IdEnv(..), UniqFM, FiniteMap, + CoreExpr, CoreAtom, UnfoldingCoreAtom, UnfoldingCoreExpr, + UnfoldingPrimOp, UfCostCentre, Bag + IF_ATTACK_PRAGMAS(COMMA cmpClass COMMA cmpTyCon COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType COMMA pprPrimOp) +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif +#ifdef DPH + ,ParQuals(..), ProtoNameParQuals(..), + RenamedParQuals(..), TypecheckedParQuals(..), + collectParQualBinders +#endif {- Data Parallel Haskell -} + ) where + + +import AbsSynFuns -- help functions + +import HsBinds -- the main stuff to export +import HsCore +import HsDecls +import HsExpr +import HsImpExp +import HsLit +import HsMatches +import HsPat +import HsPragmas +import HsTypes + +import AbsPrel ( PrimKind, PrimOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( TyVar, TyCon, Arity(..), Class, ClassOp, TauType(..) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import BasicLit ( BasicLit ) +import FiniteMap ( FiniteMap ) +import Id ( Id, DictVar(..), DataCon(..) ) +import IdInfo +import Inst ( Inst ) +import Maybes ( Maybe ) +import Name +import NameTypes ( ShortName, FullName ) -- .. for pragmas only +import Outputable +import Pretty +import ProtoName ( ProtoName(..) ) -- .. for pragmas only +import SrcLoc ( SrcLoc ) +import Unique ( Unique ) +import Util +\end{code} + +All we actually declare here is the top-level structure for a module. +\begin{code} +data Module name pat + = Module + FAST_STRING -- module name + [IE] -- export list + [ImportedInterface name pat] + -- We snaffle interesting stuff out of the + -- imported interfaces early on, adding that + -- info to TyDecls/etc; so this list is + -- often empty, downstream. + [FixityDecl name] + [TyDecl name] + [DataTypeSig name] -- user pragmas that modify TyDecls; + -- (much like "Sigs" modify value "Binds") + [ClassDecl name pat] + [InstDecl name pat] + [SpecialisedInstanceSig name] -- user pragmas that modify InstDecls + [DefaultDecl name] + (Binds name pat) -- the main stuff! + [Sig name] -- "Sigs" are folded into the "Binds" + -- pretty early on, so this list is + -- often either empty or just the + -- interface signatures. + SrcLoc +\end{code} + +\begin{code} +type ProtoNameModule = Module ProtoName ProtoNamePat +type RenamedModule = Module Name RenamedPat +type TypecheckedModule = Module Id TypecheckedPat +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name, NamedThing pat, Outputable pat) => + Outputable (Module name pat) where + + ppr sty (Module name exports imports fixities + typedecls typesigs classdecls instdecls instsigs + defdecls binds sigs src_loc) + = ppAboves [ + ifPprShowAll sty (ppr sty src_loc), + if (null exports) + then (ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")]) + else (ppAboves [ + ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen], + ppNest 8 (interpp'SP sty exports), + ppNest 4 (ppPStr SLIT(") where")) + ]), + ppr sty imports, ppr sty fixities, + ppr sty typedecls, ppr sty typesigs, + ppr sty classdecls, + ppr sty instdecls, ppr sty instsigs, + ppr sty defdecls, + ppr sty binds, ppr sty sigs + ] +\end{code} diff --git a/ghc/compiler/abstractSyn/AbsSynFuns.hi b/ghc/compiler/abstractSyn/AbsSynFuns.hi new file mode 100644 index 0000000..b34015c --- /dev/null +++ b/ghc/compiler/abstractSyn/AbsSynFuns.hi @@ -0,0 +1,51 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsSynFuns where +import HsBinds(Bind, Binds, MonoBinds) +import HsDecls(ClassDecl, FixityDecl, InstDecl) +import HsExpr(Expr, Qual) +import HsImpExp(IE) +import HsPat(InPat, TypecheckedPat) +import HsTypes(MonoType) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import RenameAuxFuns(PreludeNameFun(..)) +import SrcLoc(SrcLoc) +import TyVar(TyVar) +import UniType(UniType) +type PreludeNameFun = _PackedString -> Labda Name +cmpInstanceTypes :: MonoType ProtoName -> MonoType ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +collectBinders :: Bind a (InPat a) -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectMonoBinders :: MonoBinds a (InPat a) -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectMonoBindersAndLocs :: MonoBinds a (InPat a) -> [(a, SrcLoc)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectPatBinders :: InPat a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectQualBinders :: [Qual Name (InPat Name)] -> [Name] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectTopLevelBinders :: Binds a (InPat a) -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectTypedBinders :: Bind Id TypecheckedPat -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +collectTypedPatBinders :: TypecheckedPat -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractMonoTyNames :: (a -> a -> Bool) -> MonoType a -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +getMentionedVars :: (_PackedString -> Labda Name) -> [IE] -> [FixityDecl ProtoName] -> [ClassDecl ProtoName (InPat ProtoName)] -> [InstDecl ProtoName (InPat ProtoName)] -> Binds ProtoName (InPat ProtoName) -> (Bool, [_PackedString]) + {-# GHC_PRAGMA _A_ 6 _U_ 210111 _N_ _S_ "LSALLL" {_A_ 5 _U_ 21111 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getNonPrelOuterTyCon :: MonoType ProtoName -> Labda ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: MonoType ProtoName) -> case u0 of { _ALG_ _ORIG_ HsTypes MonoTyCon (u1 :: ProtoName) (u2 :: [MonoType ProtoName]) -> _!_ _ORIG_ Maybes Ni [ProtoName] [u1]; (u3 :: MonoType ProtoName) -> _!_ _ORIG_ Maybes Hamna [ProtoName] [] } _N_ #-} +mkDictApp :: Expr Id TypecheckedPat -> [Id] -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [Id]) -> case u1 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-} +mkDictLam :: [Id] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [Id]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkTyApp :: Expr Id TypecheckedPat -> [UniType] -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [UniType]) -> case u1 of { _ALG_ (:) (u2 :: UniType) (u3 :: [UniType]) -> _!_ _ORIG_ HsExpr TyApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-} +mkTyLam :: [TyVar] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [TyVar]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: TyVar) (u3 :: [TyVar]) -> _!_ _ORIG_ HsExpr TyLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/abstractSyn/AbsSynFuns.lhs b/ghc/compiler/abstractSyn/AbsSynFuns.lhs new file mode 100644 index 0000000..08bbd36 --- /dev/null +++ b/ghc/compiler/abstractSyn/AbsSynFuns.lhs @@ -0,0 +1,563 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[AbsSynFuns]{Abstract syntax: help functions} + +\begin{code} +#include "HsVersions.h" + +module AbsSynFuns ( + collectTopLevelBinders, + collectBinders, collectTypedBinders, + collectMonoBinders, + collectMonoBindersAndLocs, + collectPatBinders, + collectQualBinders, + collectTypedPatBinders, +#ifdef DPH + collectParQualBinders, +#endif {- Data Parallel Haskell -} + cmpInstanceTypes, + extractMonoTyNames, +{-OLD:-}getMentionedVars, -- MENTIONED + getNonPrelOuterTyCon, + mkDictApp, + mkDictLam, + mkTyApp, + mkTyLam, + + PreludeNameFun(..) + ) where + +IMPORT_Trace + +import AbsSyn + +import HsTypes ( cmpMonoType ) +import Id ( Id, DictVar(..), DictFun(..) ) +import Maybes ( Maybe(..) ) +import ProtoName ( ProtoName(..), cmpProtoName ) +import Rename ( PreludeNameFun(..) ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-MonoBinds]{Bindings: @MonoBinds@} +%* * +%************************************************************************ + +Get all the binders in some @ProtoNameMonoBinds@, IN THE ORDER OF +APPEARANCE; e.g., in: +\begin{verbatim} +... +where + (x, y) = ... + f i j = ... + [a, b] = ... +\end{verbatim} +it should return @[x, y, f, a, b]@ (remember, order important). + +\begin{code} +collectTopLevelBinders :: Binds name (InPat name) -> [name] +collectTopLevelBinders EmptyBinds = [] +collectTopLevelBinders (SingleBind b) = collectBinders b +collectTopLevelBinders (BindWith b _) = collectBinders b +collectTopLevelBinders (ThenBinds b1 b2) + = (collectTopLevelBinders b1) ++ (collectTopLevelBinders b2) + +{- --------- DO THIS WHEN VarMonoBind binds a "name" rather than a "Id" + +collectBinders :: Bind name (InPat name) -> [name] +collectBinders = collectGenericBinders collectPatBinders +collectTypedBinders :: TypecheckedBind -> TypecheckedPat -> [name] +collectTypedBinders = collectGenericBinders collectTypedPatBinders + +collectGenericBinders :: (pat -> [name]) -> Bind name pat -> [name] +collectGenericBinders pat_fn EmptyBind = [] +collectGenericBinders pat_fn (NonRecBind monobinds) + = collectGenericMonoBinders pat_fn monobinds +collectGenericBinders pat_fn (RecBind monobinds) + = collectGenericMonoBinders pat_fn monobinds + +collectMonoBinders :: MonoBinds name (InPat name) -> [name] +collectMonoBinders = collectGenericMonoBinders collectPatBinders + + +collectGenericMonoBinders :: (pat -> [name]) -> MonoBinds name pat -> [name] +collectGenericMonoBinders pat_fn EmptyMonoBinds = [] +collectGenericMonoBinders pat_fn (AndMonoBinds bs1 bs2) + = (collectGenericMonoBinders pat_fn bs1) ++ (collectGenericMonoBinders pat_fn bs2) +collectGenericMonoBinders pat_fn (PatMonoBind pat grhss_w_binds locn) + = pat_fn pat +collectGenericMonoBinders pat_fn (FunMonoBind f matches locn) = [f] +collectGenericMonoBinders pat_fn (VarMonoBind v expr) = [v] + +------------------ -} + +-- ------- UNTIL THEN, WE DUPLICATE CODE -----------} + +collectBinders :: Bind name (InPat name) -> [name] +collectBinders EmptyBind = [] +collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds +collectBinders (RecBind monobinds) = collectMonoBinders monobinds + +collectTypedBinders :: TypecheckedBind -> [Id] +collectTypedBinders EmptyBind = [] +collectTypedBinders (NonRecBind monobinds) = collectTypedMonoBinders monobinds +collectTypedBinders (RecBind monobinds) = collectTypedMonoBinders monobinds + +collectMonoBinders :: MonoBinds name (InPat name) -> [name] +collectMonoBinders EmptyMonoBinds = [] +collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat +collectMonoBinders (FunMonoBind f matches _) = [f] +collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders" +collectMonoBinders (AndMonoBinds bs1 bs2) + = (collectMonoBinders bs1) ++ (collectMonoBinders bs2) + +collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id] +collectTypedMonoBinders EmptyMonoBinds = [] +collectTypedMonoBinders (PatMonoBind pat grhss_w_binds _) = collectTypedPatBinders pat +collectTypedMonoBinders (FunMonoBind f matches _) = [f] +collectTypedMonoBinders (VarMonoBind v expr) = [v] +collectTypedMonoBinders (AndMonoBinds bs1 bs2) + = (collectTypedMonoBinders bs1) ++ (collectTypedMonoBinders bs2) + +-- ---------- END OF DUPLICATED CODE + +-- We'd like the binders -- and where they came from -- +-- so we can make new ones with equally-useful origin info. + +collectMonoBindersAndLocs + :: MonoBinds name (InPat name) -> [(name, SrcLoc)] + +collectMonoBindersAndLocs EmptyMonoBinds = [] + +collectMonoBindersAndLocs (AndMonoBinds bs1 bs2) + = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2 + +collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn) + = collectPatBinders pat `zip` repeat locn + +collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)] + +collectMonoBindersAndLocs (VarMonoBind v expr) + = trace "collectMonoBindersAndLocs:VarMonoBind" [] + -- ToDo: this is dubious, i.e., wrong, but harmless? +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-Expr]{Help functions: @Expr@} +%* * +%************************************************************************ + +And some little help functions that remove redundant redundancy: +\begin{code} +mkTyApp :: TypecheckedExpr -> [UniType] -> TypecheckedExpr +mkTyApp expr [] = expr +mkTyApp expr tys = TyApp expr tys + +mkDictApp :: TypecheckedExpr -> [DictVar] -> TypecheckedExpr +mkDictApp expr [] = expr +mkDictApp expr dict_vars = DictApp expr dict_vars + +mkTyLam :: [TyVar] -> TypecheckedExpr -> TypecheckedExpr +mkTyLam [] expr = expr +mkTyLam tyvars expr = TyLam tyvars expr + +mkDictLam :: [DictVar] -> TypecheckedExpr -> TypecheckedExpr +mkDictLam [] expr = expr +mkDictLam dicts expr = DictLam dicts expr +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-Qual]{Help functions: @Quals@} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH +collectParQualBinders :: RenamedParQuals -> [Name] +collectParQualBinders (AndParQuals q1 q2) + = collectParQualBinders q1 ++ collectParQualBinders q2 + +collectParQualBinders (DrawnGenIn pats pat expr) + = concat ((map collectPatBinders pats)++[collectPatBinders pat]) + +collectParQualBinders (IndexGen exprs pat expr) + = (collectPatBinders pat) + +collectParQualBinders (ParFilter expr) = [] +#endif {- Data Parallel HAskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-ParQuals]{Help functions: @ParQuals@} +%* * +%************************************************************************ + +\begin{code} +collectQualBinders :: [RenamedQual] -> [Name] + +collectQualBinders quals + = concat (map collect quals) + where + collect (GeneratorQual pat expr) = collectPatBinders pat + collect (FilterQual expr) = [] +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-pats]{Help functions: patterns} +%* * +%************************************************************************ + +With un-parameterised patterns, we have to have ``duplicate'' copies +of one or two functions: +\begin{code} +collectPatBinders :: InPat a -> [a] +collectPatBinders (VarPatIn var) = [var] +collectPatBinders (LazyPatIn pat) = collectPatBinders pat +collectPatBinders (AsPatIn a pat) = a : (collectPatBinders pat) +collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats) +collectPatBinders (ConOpPatIn p1 c p2)= (collectPatBinders p1) ++ (collectPatBinders p2) +collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats) +collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats) +collectPatBinders (NPlusKPatIn n _) = [n] +#ifdef DPH +collectPatBinders (ProcessorPatIn pats pat) + = concat (map collectPatBinders pats) ++ (collectPatBinders pat) +#endif +collectPatBinders any_other_pat = [ {-no binders-} ] +\end{code} + +Nota bene: DsBinds relies on the fact that at least for simple +tuple patterns @collectTypedPatBinders@ returns the binders in +the same order as they appear in the tuple. + +\begin{code} +collectTypedPatBinders :: TypecheckedPat -> [Id] +collectTypedPatBinders (VarPat var) = [var] +collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat +collectTypedPatBinders (AsPat a pat) = a : (collectTypedPatBinders pat) +collectTypedPatBinders (ConPat _ _ pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (ConOpPat p1 _ p2 _) = (collectTypedPatBinders p1) ++ (collectTypedPatBinders p2) +collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (TuplePat pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (NPlusKPat n _ _ _ _ _) = [n] +#ifdef DPH +collectTypedPatBinders (ProcessorPat pats _ pat) + = (concat (map collectTypedPatBinders pats)) ++ + (collectTypedPatBinders pat) +#endif {- Data Parallel Haskell -} +collectTypedPatBinders any_other_pat = [ {-no binders-} ] +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-MonoType]{Help functions: @MonoType@} +%* * +%************************************************************************ + +Get the type variable names from a @MonoType@. Don't use class @Eq@ +because @ProtoNames@ aren't in it. + +\begin{code} +extractMonoTyNames :: (name -> name -> Bool) -> MonoType name -> [name] + +extractMonoTyNames eq monotype + = get monotype [] + where + get (MonoTyVar name) acc | name `is_elem` acc = acc + | otherwise = name : acc + get (MonoTyCon con tys) acc = foldr get acc tys + get (ListMonoTy ty) acc = get ty acc + get (FunMonoTy ty1 ty2) acc = get ty1 (get ty2 acc) + get (TupleMonoTy tys) acc + = foldr get_poly acc tys + where + get_poly (UnoverloadedTy ty) acc = get ty acc + get_poly (ForAllTy _ ty) acc = get ty acc + get_poly (OverloadedTy ctxt ty) acc = panic "extractMonoTyNames" + get (MonoDict _ ty) acc = get ty acc + get (MonoTyVarTemplate _) acc = acc +#ifdef DPH + get (MonoTyProc tys ty) acc = foldr get (get ty acc) tys + get (MonoTyPod ty) acc = get ty acc +#endif {- Data Parallel Haskell -} + + is_elem n [] = False + is_elem n (x:xs) = n `eq` x || n `is_elem` xs +\end{code} + +@cmpInstanceTypes@ compares two @MonoType@s which are being used as +``instance types.'' This is used when comparing as-yet-unrenamed +instance decls to eliminate duplicates. We allow things (e.g., +overlapping instances) which standard Haskell doesn't, so we must +cater for that. Generally speaking, the instance-type +``shape''-checker in @tcInstDecl@ will catch any mischief later on. + +All we do is call @cmpMonoType@, passing it a tyvar-comparing function +that always claims that tyvars are ``equal;'' the result is that we +end up comparing the non-tyvar-ish structure of the two types. + +\begin{code} +cmpInstanceTypes :: ProtoNameMonoType -> ProtoNameMonoType -> TAG_ + +cmpInstanceTypes ty1 ty2 + = cmpMonoType funny_cmp ty1 ty2 + where + funny_cmp :: ProtoName -> ProtoName -> TAG_ + + {- The only case we are really trying to catch + is when both types are tyvars: which are both + "Unk"s and names that start w/ a lower-case letter! (Whew.) + -} + funny_cmp (Unk u1) (Unk u2) + | isLower s1 && isLower s2 = EQ_ + where + s1 = _HEAD_ u1 + s2 = _HEAD_ u2 + + funny_cmp x y = cmpProtoName x y -- otherwise completely normal +\end{code} + +@getNonPrelOuterTyCon@ is a yukky function required when deciding +whether to import an instance decl. If the class name or type +constructor are ``wanted'' then we should import it, otherwise not. +But the built-in core constructors for lists, tuples and arrows are +never ``wanted'' in this sense. @getNonPrelOuterTyCon@ catches just a +user-defined tycon and returns it. + +\begin{code} +getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName + +getNonPrelOuterTyCon (MonoTyCon con _) = Just con +getNonPrelOuterTyCon _ = Nothing +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSynFuns-mentioned-vars]{Collect mentioned variables} +%* * +%************************************************************************ + +This is just a {\em hack} whichs collects, from a module body, all the +variables that are ``mentioned,'' either as top-level binders or as +free variables. We can then use this list when walking over +interfaces, using it to avoid imported variables that are patently of +no interest. + +We have to be careful to look out for \tr{M..} constructs in the +export list; if so, the game is up (and we must so report). + +\begin{code} +{- OLD:MENTIONED-} +getMentionedVars :: PreludeNameFun -- a prelude-name lookup function, so + -- we can avoid recording prelude things + -- as "mentioned" + -> [IE]{-exports-} -- All the bits of the module body to + -> [ProtoNameFixityDecl]-- look in for "mentioned" vars. + -> [ProtoNameClassDecl] + -> [ProtoNameInstDecl] + -> ProtoNameBinds + + -> (Bool, -- True <=> M.. construct in exports + [FAST_STRING]) -- list of vars "mentioned" in the module body + +getMentionedVars val_nf exports fixes class_decls inst_decls binds + = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) -> + (module_dotdot_seen, + concat [export_mentioned, + mention_Fixity fixes, + mention_ClassDecls val_nf class_decls, + mention_InstDecls val_nf inst_decls, + mention_Binds val_nf True{-top-level-} binds]) + } +\end{code} + +\begin{code} +mention_IE :: [IE] -> (Bool, [FAST_STRING]) + +mention_IE exps + = foldr men (False, []) exps + where + men (IEVar str) (dotdot_seen, so_far) = (dotdot_seen, str : so_far) + men (IEModuleContents _) (_, so_far) = (True, so_far) + men other_ie acc = acc +\end{code} + +\begin{code} +mention_Fixity :: [ProtoNameFixityDecl] -> [FAST_STRING] + +mention_Fixity fixity_decls = [] + -- ToDo: if we ever do something proper with fixity declarations, + -- this might need to do something. +\end{code} + +\begin{code} +mention_ClassDecls :: PreludeNameFun -> [ProtoNameClassDecl] -> [FAST_STRING] + +mention_ClassDecls val_nf [] = [] +mention_ClassDecls val_nf (ClassDecl _ _ _ _ binds _ _ : rest) + = mention_MonoBinds val_nf True{-toplev-} binds + ++ mention_ClassDecls val_nf rest +\end{code} + +\begin{code} +mention_InstDecls :: PreludeNameFun -> [ProtoNameInstDecl] -> [FAST_STRING] + +mention_InstDecls val_nf [] = [] +mention_InstDecls val_nf (InstDecl _ _ _ binds _ _ _ _ _ _ : rest) + = mention_MonoBinds val_nf True{-toplev-} binds + ++ mention_InstDecls val_nf rest +\end{code} + +\begin{code} +mention_Binds :: PreludeNameFun -> Bool -> ProtoNameBinds -> [FAST_STRING] + +mention_Binds val_nf toplev EmptyBinds = [] +mention_Binds val_nf toplev (ThenBinds a b) + = mention_Binds val_nf toplev a ++ mention_Binds val_nf toplev b +mention_Binds val_nf toplev (SingleBind a) = mention_Bind val_nf toplev a +mention_Binds val_nf toplev (BindWith a _) = mention_Bind val_nf toplev a +\end{code} + +\begin{code} +mention_Bind :: PreludeNameFun -> Bool -> ProtoNameBind -> [FAST_STRING] + +mention_Bind val_nf toplev EmptyBind = [] +mention_Bind val_nf toplev (NonRecBind a) = mention_MonoBinds val_nf toplev a +mention_Bind val_nf toplev (RecBind a) = mention_MonoBinds val_nf toplev a +\end{code} + +\begin{code} +mention_MonoBinds :: PreludeNameFun -> Bool -> ProtoNameMonoBinds -> [FAST_STRING] + +mention_MonoBinds val_nf toplev EmptyMonoBinds = [] +mention_MonoBinds val_nf toplev (AndMonoBinds a b) + = mention_MonoBinds val_nf toplev a ++ mention_MonoBinds val_nf toplev b +mention_MonoBinds val_nf toplev (PatMonoBind p gb _) + = let + rest = mention_GRHSsAndBinds val_nf gb + in + if toplev + then (map stringify (collectPatBinders p)) ++ rest + else rest + +mention_MonoBinds val_nf toplev (FunMonoBind v ms _) + = let + rest = concat (map (mention_Match val_nf) ms) + in + if toplev then (stringify v) : rest else rest + +stringify :: ProtoName -> FAST_STRING +stringify (Unk s) = s +\end{code} + +\begin{code} +mention_Match :: PreludeNameFun -> ProtoNameMatch -> [FAST_STRING] + +mention_Match val_nf (PatMatch _ m) = mention_Match val_nf m +mention_Match val_nf (GRHSMatch gb) = mention_GRHSsAndBinds val_nf gb +\end{code} + +\begin{code} +mention_GRHSsAndBinds :: PreludeNameFun -> ProtoNameGRHSsAndBinds -> [FAST_STRING] + +mention_GRHSsAndBinds val_nf (GRHSsAndBindsIn gs bs) + = mention_GRHSs val_nf gs ++ mention_Binds val_nf False bs +\end{code} + +\begin{code} +mention_GRHSs :: PreludeNameFun -> [ProtoNameGRHS] -> [FAST_STRING] + +mention_GRHSs val_nf grhss + = concat (map mention_grhs grhss) + where + mention_grhs (OtherwiseGRHS e _) = mention_Expr val_nf [] e + mention_grhs (GRHS g e _) + = mention_Expr val_nf [] g ++ mention_Expr val_nf [] e +\end{code} + +\begin{code} +mention_Expr :: PreludeNameFun -> [FAST_STRING] -> ProtoNameExpr -> [FAST_STRING] + +mention_Expr val_nf acc (Var v) + = case v of + Unk str | _LENGTH_ str >= 3 + -> case (val_nf str) of + Nothing -> str : acc + Just _ -> acc + other -> acc + +mention_Expr val_nf acc (Lit _) = acc +mention_Expr val_nf acc (Lam m) = acc ++ (mention_Match val_nf m) +mention_Expr val_nf acc (App a b) = mention_Expr val_nf (mention_Expr val_nf acc a) b +mention_Expr val_nf acc (OpApp a b c) = mention_Expr val_nf (mention_Expr val_nf (mention_Expr val_nf acc a) b) c +mention_Expr val_nf acc (SectionL a b) = mention_Expr val_nf (mention_Expr val_nf acc a) b +mention_Expr val_nf acc (SectionR a b) = mention_Expr val_nf (mention_Expr val_nf acc a) b +mention_Expr val_nf acc (CCall _ es _ _ _) = mention_Exprs val_nf acc es +mention_Expr val_nf acc (SCC _ e) = mention_Expr val_nf acc e +mention_Expr val_nf acc (Case e ms) = mention_Expr val_nf acc e ++ concat (map (mention_Match val_nf) ms) +mention_Expr val_nf acc (ListComp e q) = mention_Expr val_nf acc e ++ mention_Quals val_nf q +mention_Expr val_nf acc (Let b e) = (mention_Expr val_nf acc e) ++ (mention_Binds val_nf False{-not toplev-} b) +mention_Expr val_nf acc (ExplicitList es) = mention_Exprs val_nf acc es +mention_Expr val_nf acc (ExplicitTuple es) = mention_Exprs val_nf acc es +mention_Expr val_nf acc (ExprWithTySig e _) = mention_Expr val_nf acc e +mention_Expr val_nf acc (If b t e) = mention_Expr val_nf (mention_Expr val_nf (mention_Expr val_nf acc b) t) e +mention_Expr val_nf acc (ArithSeqIn s) = mention_ArithSeq val_nf acc s +#ifdef DPH +mention_Expr val_nf acc (ParallelZF e q) = (mention_Expr val_nf acc e) ++ + (mention_ParQuals val_nf q) +mention_Expr val_nf acc (ExplicitPodIn es) = mention_Exprs val_nf acc es +mention_Expr val_nf acc (ExplicitProcessor es e) = mention_Expr val_nf (mention_Exprs val_nf acc es) e +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +mention_Exprs :: PreludeNameFun -> [FAST_STRING] -> [ProtoNameExpr] -> [FAST_STRING] + +mention_Exprs val_nf acc [] = acc +mention_Exprs val_nf acc (e:es) = mention_Exprs val_nf (mention_Expr val_nf acc e) es +\end{code} + +\begin{code} +mention_ArithSeq :: PreludeNameFun -> [FAST_STRING] -> ProtoNameArithSeqInfo -> [FAST_STRING] + +mention_ArithSeq val_nf acc (From e1) + = mention_Expr val_nf acc e1 +mention_ArithSeq val_nf acc (FromThen e1 e2) + = mention_Expr val_nf (mention_Expr val_nf acc e1) e2 +mention_ArithSeq val_nf acc (FromTo e1 e2) + = mention_Expr val_nf (mention_Expr val_nf acc e1) e2 +mention_ArithSeq val_nf acc (FromThenTo e1 e2 e3) + = mention_Expr val_nf (mention_Expr val_nf (mention_Expr val_nf acc e1) e2) e3 +\end{code} + +\begin{code} +mention_Quals :: PreludeNameFun -> [ProtoNameQual] -> [FAST_STRING] + +mention_Quals val_nf quals + = concat (map mention quals) + where + mention (GeneratorQual _ e) = mention_Expr val_nf [] e + mention (FilterQual e) = mention_Expr val_nf [] e +\end{code} + +\begin{code} +#ifdef DPH +mention_ParQuals :: PreludeNameFun -> ProtoNameParQuals -> [FAST_STRING] +mention_ParQuals val_nf (ParFilter e) = mention_Expr val_nf [] e +mention_ParQuals val_nf (DrawnGenIn _ _ e) = mention_Expr val_nf [] e +mention_ParQuals val_nf (AndParQuals a b) = mention_ParQuals val_nf a ++ + mention_ParQuals val_nf b +mention_ParQuals val_nf (IndexGen es _ e) = mention_Exprs val_nf [] es + ++ mention_Expr val_nf [] e +#endif {- Data Parallel Haskell -} + +{- END OLD:MENTIONED -} +\end{code} diff --git a/ghc/compiler/abstractSyn/HsBinds.hi b/ghc/compiler/abstractSyn/HsBinds.hi new file mode 100644 index 0000000..29ce3af --- /dev/null +++ b/ghc/compiler/abstractSyn/HsBinds.hi @@ -0,0 +1,51 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsBinds where +import HsExpr(Expr) +import HsMatches(GRHSsAndBinds, Match) +import HsPat(InPat, TypecheckedPat) +import HsPragmas(ClassOpPragmas, GenPragmas) +import HsTypes(PolyType) +import Id(Id) +import Inst(Inst) +import Maybes(Labda) +import Name(Name) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import SimplEnv(UnfoldingGuidance) +import SrcLoc(SrcLoc) +import TyVar(TyVar) +data Bind a b = EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) +data Binds a b = EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) +data MonoBinds a b = EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc +type ProtoNameBind = Bind ProtoName (InPat ProtoName) +type ProtoNameBinds = Binds ProtoName (InPat ProtoName) +type ProtoNameClassOpSig = Sig ProtoName +type ProtoNameMonoBinds = MonoBinds ProtoName (InPat ProtoName) +type ProtoNameSig = Sig ProtoName +type RenamedBind = Bind Name (InPat Name) +type RenamedBinds = Binds Name (InPat Name) +type RenamedClassOpSig = Sig Name +type RenamedMonoBinds = MonoBinds Name (InPat Name) +type RenamedSig = Sig Name +data Sig a = Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc +type TypecheckedBind = Bind Id TypecheckedPat +type TypecheckedBinds = Binds Id TypecheckedPat +type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat +bindIsRecursive :: Bind Id TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: Bind Id TypecheckedPat) -> case u0 of { _ALG_ _ORIG_ HsBinds EmptyBind -> _!_ False [] []; _ORIG_ HsBinds NonRecBind (u1 :: MonoBinds Id TypecheckedPat) -> _!_ False [] []; _ORIG_ HsBinds RecBind (u2 :: MonoBinds Id TypecheckedPat) -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} +nullBind :: Bind a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +nullBinds :: Binds a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +nullMonoBinds :: MonoBinds a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Bind a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (MonoBinds a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (Sig a) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsBinds.lhs b/ghc/compiler/abstractSyn/HsBinds.lhs new file mode 100644 index 0000000..c0716d2 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsBinds.lhs @@ -0,0 +1,329 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @Binds@, @Bind@, @Sig@, @MonoBinds@. + +\begin{code} +#include "HsVersions.h" + +module HsBinds where + +import AbsUniType ( pprUniType, TyVar, UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import HsExpr ( Expr ) +import HsMatches ( pprMatches, pprGRHSsAndBinds, Match, GRHSsAndBinds ) +import HsPat ( ProtoNamePat(..), RenamedPat(..), + TypecheckedPat, InPat + IF_ATTACK_PRAGMAS(COMMA typeOfPat) + ) +import HsPragmas ( GenPragmas, ClassOpPragmas ) +import HsTypes ( PolyType ) +import Id ( Id, DictVar(..) ) +import IdInfo ( UnfoldingGuidance ) +import Inst ( Inst ) +import Name ( Name ) +import Outputable +import Pretty +import ProtoName ( ProtoName(..) ) -- .. for pragmas only +import SrcLoc ( SrcLoc ) +import Unique ( Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-Binds]{Bindings: @Binds@} +%* * +%************************************************************************ + +The following syntax may produce new syntax which is not part of the input, +and which is instead a translation of the input to the typechecker. +Syntax translations are marked TRANSLATION in comments. New empty +productions are useful in development but may not appear in the final +grammar. + +Collections of bindings, created by dependency analysis and translation: + +\begin{code} +data Binds bdee pat -- binders and bindees + = EmptyBinds + + | ThenBinds (Binds bdee pat) + (Binds bdee pat) + + | SingleBind (Bind bdee pat) + + | BindWith -- Bind with a type signature. + -- These appear only on typechecker input + -- (PolyType [in Sigs] can't appear on output) + (Bind bdee pat) -- really ProtoNameBind, but... + -- (see "really" comment below) + [Sig bdee] + + | AbsBinds -- Binds abstraction; TRANSLATION + [TyVar] + [DictVar] + [(Id, Id)] -- (old, new) pairs + [(Inst, Expr bdee pat)] -- local dictionaries + (Bind bdee pat) -- "the business end" + + -- Creates bindings for *new* (polymorphic, overloaded) locals + -- in terms of *old* (monomorphic, non-overloaded) ones. + -- + -- See section 9 of static semantics paper for more details. + -- (You can get a PhD for explaining the True Meaning + -- of this last construct.) +\end{code} + +The corresponding unparameterised synonyms: + +\begin{code} +type ProtoNameBinds = Binds ProtoName ProtoNamePat +type RenamedBinds = Binds Name RenamedPat +type TypecheckedBinds = Binds Id TypecheckedPat +\end{code} + +\begin{code} +nullBinds :: Binds bdee pat -> Bool +nullBinds EmptyBinds = True +nullBinds (ThenBinds b1 b2) = (nullBinds b1) && (nullBinds b2) +nullBinds (SingleBind b) = nullBind b +nullBinds (BindWith b _) = nullBind b +nullBinds (AbsBinds _ _ _ ds b) = (null ds) && (nullBind b) +\end{code} + +ToDo: make this recursiveness checking also require that +there be something there, i.e., not null ? +\begin{code} +{- UNUSED: +bindsAreRecursive :: TypecheckedBinds -> Bool + +bindsAreRecursive EmptyBinds = False +bindsAreRecursive (ThenBinds b1 b2) + = (bindsAreRecursive b1) || (bindsAreRecursive b2) +bindsAreRecursive (SingleBind b) = bindIsRecursive b +bindsAreRecursive (BindWith b _) = bindIsRecursive b +bindsAreRecursive (AbsBinds _ _ _ ds b) + = (bindsAreRecursive d) || (bindIsRecursive b) +-} +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (Binds bdee pat) where + + ppr sty EmptyBinds = ppNil + ppr sty (ThenBinds binds1 binds2) + = ppAbove (ppr sty binds1) (ppr sty binds2) + ppr sty (SingleBind bind) = ppr sty bind + ppr sty (BindWith bind sigs) + = ppAbove (if null sigs then ppNil else ppr sty sigs) (ppr sty bind) + ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds) + = ppAbove (ppSep [ppPStr SLIT("AbsBinds"), + ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack], + ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack], + ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]]) + (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds))) +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-Sig]{@Sig@: type signatures and value-modifying user pragmas} +%* * +%************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. + +\begin{code} +data Sig name + = Sig name -- a bog-std type signature + (PolyType name) + (GenPragmas name) -- only interface ones have pragmas + SrcLoc + + | ClassOpSig name -- class-op sigs have different pragmas + (PolyType name) + (ClassOpPragmas name) -- only interface ones have pragmas + SrcLoc + + | SpecSig name -- specialise a function or datatype ... + (PolyType name) -- ... to these types + (Maybe name) -- ... maybe using this as the code for it + SrcLoc + + | InlineSig name -- INLINE f [howto] + UnfoldingGuidance -- "howto": how gung-ho we are about inlining + SrcLoc + + -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER + | DeforestSig name -- Deforest using this function definition + SrcLoc + + | MagicUnfoldingSig + name -- Associate the "name"d function with + FAST_STRING -- the compiler-builtin unfolding (known + SrcLoc -- by the String name) + +type ProtoNameSig = Sig ProtoName +type RenamedSig = Sig Name + +type ProtoNameClassOpSig = Sig ProtoName +type RenamedClassOpSig = Sig Name +\end{code} + +\begin{code} +instance (Outputable name) => Outputable (Sig name) where + ppr sty (Sig var ty pragmas _) + = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")]) + 4 (ppAbove (ppr sty ty) + (ifnotPprForUser sty (ppr sty pragmas))) + + ppr sty (ClassOpSig var ty pragmas _) + = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")]) + 4 (ppAbove (ppr sty ty) + (ifnotPprForUser sty (ppr sty pragmas))) + + ppr sty (DeforestSig var _) + = ppHang (ppCat [ppStr "{-# DEFOREST", ppr sty var]) + 4 (ppStr "#-}") + + ppr sty (SpecSig var ty using _) + = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), ppr sty var, ppPStr SLIT("::")]) + 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")]) + where + pp_using Nothing = ppNil + pp_using (Just me) = ppCat [ppChar '=', ppr sty me] + + ppr sty (InlineSig var _ _) + = ppHang (ppCat [ppPStr SLIT("{-# INLINE"), ppr sty var]) + 4 (ppCat [ppPStr SLIT(""), ppPStr SLIT("#-}")]) + + ppr sty (MagicUnfoldingSig var str _) + = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), ppr sty var, ppPStr str, ppPStr SLIT("#-}")] +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-Bind]{Binding: @Bind@} +%* * +%************************************************************************ + +\begin{code} +data Bind bdee pat -- binders and bindees + = EmptyBind -- because it's convenient when parsing signatures + | NonRecBind (MonoBinds bdee pat) + | RecBind (MonoBinds bdee pat) +\end{code} + +The corresponding unparameterised synonyms: + +\begin{code} +type ProtoNameBind = Bind ProtoName ProtoNamePat +type RenamedBind = Bind Name RenamedPat +type TypecheckedBind = Bind Id TypecheckedPat +\end{code} + +\begin{code} +nullBind :: Bind bdee pat -> Bool +nullBind EmptyBind = True +nullBind (NonRecBind bs) = nullMonoBinds bs +nullBind (RecBind bs) = nullMonoBinds bs +\end{code} + +\begin{code} +bindIsRecursive :: TypecheckedBind -> Bool +bindIsRecursive EmptyBind = False +bindIsRecursive (NonRecBind _) = False +bindIsRecursive (RecBind _) = True +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (Bind bdee pat) where + ppr sty EmptyBind = ppNil + ppr sty (NonRecBind binds) + = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}")) + (ppr sty binds) + ppr sty (RecBind binds) + = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}")) + (ppr sty binds) +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-MonoBinds]{Bindings: @MonoBinds@} +%* * +%************************************************************************ + +Global bindings (where clauses) + +\begin{code} +data MonoBinds bdee pat -- binders and bindees + = EmptyMonoBinds -- TRANSLATION + | AndMonoBinds (MonoBinds bdee pat) + (MonoBinds bdee pat) + | PatMonoBind pat + (GRHSsAndBinds bdee pat) + SrcLoc + | VarMonoBind Id -- TRANSLATION + (Expr bdee pat) + | FunMonoBind bdee + [Match bdee pat] -- must have at least one Match + SrcLoc +\end{code} + +The corresponding unparameterised synonyms: +\begin{code} +type ProtoNameMonoBinds = MonoBinds ProtoName ProtoNamePat +type RenamedMonoBinds = MonoBinds Name RenamedPat +type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat +\end{code} + +\begin{code} +nullMonoBinds :: MonoBinds bdee pat -> Bool +nullMonoBinds EmptyMonoBinds = True +nullMonoBinds (AndMonoBinds bs1 bs2) = (nullMonoBinds bs1) && (nullMonoBinds bs2) +nullMonoBinds other_monobind = False +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (MonoBinds bdee pat) where + ppr sty EmptyMonoBinds = ppNil + ppr sty (AndMonoBinds binds1 binds2) + = ppAbove (ppr sty binds1) (ppr sty binds2) + + ppr sty (PatMonoBind pat grhss_n_binds locn) + = ppAboves [ + ifPprShowAll sty (ppr sty locn), + (if (hasType pat) then + ppHang (ppCat [ppr sty pat, ppStr "::"]) 4 (pprUniType sty (getType pat)) + else + ppNil + ), + (ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)) ] + + ppr sty (FunMonoBind fun matches locn) + = ppAboves [ + ifPprShowAll sty (ppr sty locn), + if (hasType fun) then + ppHang (ppCat [pprNonOp sty fun, ppStr "::"]) 4 + (pprUniType sty (getType fun)) + else + ppNil, + pprMatches sty (False, pprNonOp sty fun) matches + ] + + ppr sty (VarMonoBind name expr) + = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr) +\end{code} diff --git a/ghc/compiler/abstractSyn/HsCore.hi b/ghc/compiler/abstractSyn/HsCore.hi new file mode 100644 index 0000000..cd79024 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsCore.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsCore where +import BasicLit(BasicLit) +import HsTypes(MonoType, PolyType) +import Maybes(Labda) +import Outputable(Outputable) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import ProtoName(ProtoName) +data UfCostCentre a = UfPreludeDictsCC Bool | UfAllDictsCC _PackedString _PackedString Bool | UfUserCC _PackedString _PackedString _PackedString Bool Bool | UfAutoCC (UfId a) _PackedString _PackedString Bool Bool | UfDictCC (UfId a) _PackedString _PackedString Bool Bool +data UfId a = BoringUfId a | SuperDictSelUfId a a | ClassOpUfId a a | DictFunUfId a (PolyType a) | ConstMethodUfId a a (PolyType a) | DefaultMethodUfId a a | SpecUfId (UfId a) [Labda (MonoType a)] | WorkerUfId (UfId a) +data UnfoldingCoreAlts a = UfCoAlgAlts [(a, [(a, PolyType a)], UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) +data UnfoldingCoreAtom a = UfCoVarAtom (UfId a) | UfCoLitAtom BasicLit +data UnfoldingCoreBinding a = UfCoNonRec (a, PolyType a) (UnfoldingCoreExpr a) | UfCoRec [((a, PolyType a), UnfoldingCoreExpr a)] +data UnfoldingCoreDefault a = UfCoNoDefault | UfCoBindDefault (a, PolyType a) (UnfoldingCoreExpr a) +data UnfoldingCoreExpr a = UfCoVar (UfId a) | UfCoLit BasicLit | UfCoCon a [PolyType a] [UnfoldingCoreAtom a] | UfCoPrim (UnfoldingPrimOp a) [PolyType a] [UnfoldingCoreAtom a] | UfCoLam [(a, PolyType a)] (UnfoldingCoreExpr a) | UfCoTyLam a (UnfoldingCoreExpr a) | UfCoApp (UnfoldingCoreExpr a) (UnfoldingCoreAtom a) | UfCoTyApp (UnfoldingCoreExpr a) (PolyType a) | UfCoCase (UnfoldingCoreExpr a) (UnfoldingCoreAlts a) | UfCoLet (UnfoldingCoreBinding a) (UnfoldingCoreExpr a) | UfCoSCC (UfCostCentre a) (UnfoldingCoreExpr a) +data UnfoldingPrimOp a = UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp +type UnfoldingType a = PolyType a +eqUfExpr :: UnfoldingCoreExpr ProtoName -> UnfoldingCoreExpr ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable a => Outputable (UnfoldingCoreAtom a) + {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (UnfoldingCoreExpr a) + {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (UnfoldingPrimOp a) + {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsCore.lhs b/ghc/compiler/abstractSyn/HsCore.lhs new file mode 100644 index 0000000..1481007 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsCore.lhs @@ -0,0 +1,353 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994 +% +%************************************************************************ +%* * +\section[HsCore]{Core-syntax unfoldings in Haskell interface files} +%* * +%************************************************************************ + +We could either use this, or parameterise @CoreExpr@ on @UniTypes@ and +@TyVars@ as well. Currently trying the former. + +\begin{code} +#include "HsVersions.h" + +module HsCore ( + -- types: + UnfoldingCoreExpr(..), UnfoldingCoreAlts(..), + UnfoldingCoreDefault(..), UnfoldingCoreBinding(..), + UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..), + UnfoldingPrimOp(..), UfCostCentre(..), + + -- function: + eqUfExpr + ) where + +IMPORT_Trace + +import AbsPrel ( PrimOp, PrimKind ) +import AbsSynFuns ( cmpInstanceTypes ) +import BasicLit ( BasicLit ) +import HsTypes -- ( cmpPolyType, PolyType(..), MonoType ) +import Maybes ( Maybe(..) ) +import Name ( Name ) +import Outputable -- class for printing, forcing +import Pretty -- pretty-printing utilities +import PrimOps ( tagOf_PrimOp -- HACK + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import ProtoName ( cmpProtoName, eqProtoName, ProtoName(..) ) -- .. for pragmas +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[HsCore-types]{Types for read/written Core unfoldings} +%* * +%************************************************************************ + +\begin{code} +data UnfoldingCoreExpr name + = UfCoVar (UfId name) + | UfCoLit BasicLit + | UfCoCon name -- must be a "BoringUfId"... + [UnfoldingType name] + [UnfoldingCoreAtom name] + | UfCoPrim (UnfoldingPrimOp name) + [UnfoldingType name] + [UnfoldingCoreAtom name] + | UfCoLam [UfBinder name] + (UnfoldingCoreExpr name) + | UfCoTyLam name + (UnfoldingCoreExpr name) + | UfCoApp (UnfoldingCoreExpr name) + (UnfoldingCoreAtom name) + | UfCoTyApp (UnfoldingCoreExpr name) + (UnfoldingType name) + | UfCoCase (UnfoldingCoreExpr name) + (UnfoldingCoreAlts name) + | UfCoLet (UnfoldingCoreBinding name) + (UnfoldingCoreExpr name) + | UfCoSCC (UfCostCentre name) + (UnfoldingCoreExpr name) + +type ProtoNameCoreExpr = UnfoldingCoreExpr ProtoName + +data UnfoldingPrimOp name + = UfCCallOp FAST_STRING -- callee + Bool -- True <=> casm, rather than ccall + Bool -- True <=> might cause GC + [UnfoldingType name] -- arg types, incl state token + -- (which will be first) + (UnfoldingType name) -- return type + | UfOtherOp PrimOp + +data UnfoldingCoreAlts name + = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)] + (UnfoldingCoreDefault name) + | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr name)] + (UnfoldingCoreDefault name) + +data UnfoldingCoreDefault name + = UfCoNoDefault + | UfCoBindDefault (UfBinder name) + (UnfoldingCoreExpr name) + +data UnfoldingCoreBinding name + = UfCoNonRec (UfBinder name) + (UnfoldingCoreExpr name) + | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)] + +data UnfoldingCoreAtom name + = UfCoVarAtom (UfId name) + | UfCoLitAtom BasicLit + +data UfCostCentre name + = UfPreludeDictsCC + Bool -- True <=> is dupd + | UfAllDictsCC FAST_STRING -- module and group + FAST_STRING + Bool -- True <=> is dupd + | UfUserCC FAST_STRING + FAST_STRING FAST_STRING -- module and group + Bool -- True <=> is dupd + Bool -- True <=> is CAF + | UfAutoCC (UfId name) + FAST_STRING FAST_STRING -- module and group + Bool Bool -- as above + | UfDictCC (UfId name) + FAST_STRING FAST_STRING -- module and group + Bool Bool -- as above + +type UfBinder name = (name, UnfoldingType name) + +data UfId name + = BoringUfId name + | SuperDictSelUfId name name -- class and superclass + | ClassOpUfId name name -- class and class op + | DictFunUfId name -- class and type + (UnfoldingType name) + | ConstMethodUfId name name -- class, class op, and type + (UnfoldingType name) + | DefaultMethodUfId name name -- class and class op + | SpecUfId (UfId name) -- its unspecialised "parent" + [Maybe (MonoType name)] + | WorkerUfId (UfId name) -- its non-working "parent" + -- more to come? + +type UnfoldingType name = PolyType name +\end{code} + +%************************************************************************ +%* * +\subsection[HsCore-print]{Printing Core unfoldings} +%* * +%************************************************************************ + +\begin{code} +instance Outputable name => Outputable (UnfoldingCoreExpr name) where + ppr sty (UfCoVar v) = pprUfId sty v + ppr sty (UfCoLit l) = ppr sty l + + ppr sty (UfCoCon c tys as) + = ppCat [ppStr "(UfCoCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"] + ppr sty (UfCoPrim o tys as) + = ppCat [ppStr "(UfCoPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"] + + ppr sty (UfCoLam bs body) + = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body] + ppr sty (UfCoTyLam tv body) + = ppCat [ppStr "/\\", ppr sty tv, ppStr "->", ppr sty body] + + ppr sty (UfCoApp fun arg) + = ppCat [ppStr "(UfCoApp", ppr sty fun, ppr sty arg, ppStr ")"] + ppr sty (UfCoTyApp expr ty) + = ppCat [ppStr "(UfCoTyApp", ppr sty expr, ppr sty ty, ppStr ")"] + + ppr sty (UfCoCase scrut alts) + = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"] + where + pp_alts (UfCoAlgAlts alts deflt) + = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] + where + pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs] + pp_alts (UfCoPrimAlts alts deflt) + = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt] + where + pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs] + + pp_deflt UfCoNoDefault = ppNil + pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs] + + ppr sty (UfCoLet (UfCoNonRec b rhs) body) + = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body] + ppr sty (UfCoLet (UfCoRec pairs) body) + = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body] + where + pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs] + + ppr sty (UfCoSCC uf_cc body) + = ppCat [ppStr "_scc_ ", ppr sty body] + +instance Outputable name => Outputable (UnfoldingPrimOp name) where + ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty) + = let + before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ") + after = if is_casm then ppStr "'' " else ppSP + in + ppBesides [before, ppPStr str, after, + ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty] + ppr sty (UfOtherOp op) + = ppr sty op + +instance Outputable name => Outputable (UnfoldingCoreAtom name) where + ppr sty (UfCoVarAtom v) = pprUfId sty v + ppr sty (UfCoLitAtom l) = ppr sty l + +pprUfId sty (BoringUfId v) = ppr sty v +pprUfId sty (SuperDictSelUfId c sc) + = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"] +pprUfId sty (ClassOpUfId c op) + = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"] +pprUfId sty (DictFunUfId c ty) + = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"] +pprUfId sty (ConstMethodUfId c op ty) + = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"] +pprUfId sty (DefaultMethodUfId c ty) + = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"] + +pprUfId sty (SpecUfId unspec ty_maybes) + = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec, + ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"] + where + pp_ty_maybe Nothing = ppStr "_N_" + pp_ty_maybe (Just t) = ppr sty t + +pprUfId sty (WorkerUfId unwrkr) + = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"] +\end{code} + +%************************************************************************ +%* * +\subsection[HsCore-equality]{Comparing Core unfoldings} +%* * +%************************************************************************ + +We want to check that they are {\em exactly} the same. + +\begin{code} +eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool + +eqUfExpr (UfCoVar v1) (UfCoVar v2) = eqUfId v1 v2 +eqUfExpr (UfCoLit l1) (UfCoLit l2) = l1 == l2 + +eqUfExpr (UfCoCon c1 tys1 as1) (UfCoCon c2 tys2 as2) + = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2 +eqUfExpr (UfCoPrim o1 tys1 as1) (UfCoPrim o2 tys2 as2) + = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2 + where + eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True + eq_op (UfOtherOp o1) (UfOtherOp o2) + = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2 + +eqUfExpr (UfCoLam bs1 body1) (UfCoLam bs2 body2) + = eq_lists eq_binder bs1 bs2 && eqUfExpr body1 body2 +eqUfExpr (UfCoTyLam tv1 body1) (UfCoTyLam tv2 body2) + = eq_name tv1 tv2 && eqUfExpr body1 body2 + +eqUfExpr (UfCoApp fun1 arg1) (UfCoApp fun2 arg2) + = eqUfExpr fun1 fun2 && eq_atom arg1 arg2 +eqUfExpr (UfCoTyApp expr1 ty1) (UfCoTyApp expr2 ty2) + = eqUfExpr expr1 expr2 && eq_type ty1 ty2 + +eqUfExpr (UfCoCase scrut1 alts1) (UfCoCase scrut2 alts2) + = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2 + where + eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2) + = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2 + where + eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2) + = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2 + + eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2) + = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2 + where + eq_alt (l1,rhs1) (l2,rhs2) + = l1 == l2 && eqUfExpr rhs1 rhs2 + + eq_alts _ _ = False -- catch-all + + eq_deflt UfCoNoDefault UfCoNoDefault = True + eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2) + = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 + eq_deflt _ _ = False + +eqUfExpr (UfCoLet (UfCoNonRec b1 rhs1) body1) (UfCoLet (UfCoNonRec b2 rhs2) body2) + = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2 + +eqUfExpr (UfCoLet (UfCoRec pairs1) body1) (UfCoLet (UfCoRec pairs2) body2) + = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2 + where + eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 + +eqUfExpr (UfCoSCC cc1 body1) (UfCoSCC cc2 body2) + = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2) + +eqUfExpr _ _ = False -- Catch-all +\end{code} + +\begin{code} +eqUfId (BoringUfId n1) (BoringUfId n2) + = eq_name n1 n2 +eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2) + = eq_name a1 a2 && eq_name b1 b2 +eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2) + = eq_name a1 a2 && eq_name b1 b2 +eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2) + = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ****** + where + eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2) + = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False } + eq_tycon ty1 ty2 + = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else + +eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2) + = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2 +eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2) + = eq_name a1 a2 && eq_name b1 b2 +eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2) + = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2 + where + eq_ty_maybe Nothing Nothing = True + eq_ty_maybe (Just ty1) (Just ty2) + = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2) + -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02] + eq_ty_maybe _ _ = False +eqUfId (WorkerUfId id1) (WorkerUfId id2) + = eqUfId id1 id2 +eqUfId _ _ = False -- catch-all +\end{code} + +\begin{code} +eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2 +eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2 +eq_atom _ _ = False + +eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2 + +eq_name :: ProtoName -> ProtoName -> Bool +eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names + +eq_type ty1 ty2 + = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False } +\end{code} + +\begin{code} +eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool + +eq_lists eq [] [] = True +eq_lists eq [] _ = False +eq_lists eq _ [] = False +eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys +\end{code} diff --git a/ghc/compiler/abstractSyn/HsDecls.hi b/ghc/compiler/abstractSyn/HsDecls.hi new file mode 100644 index 0000000..76524b7 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsDecls.hi @@ -0,0 +1,54 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsDecls where +import HsBinds(MonoBinds, Sig) +import HsPat(InPat) +import HsPragmas(ClassPragmas, DataPragmas, InstancePragmas, TypePragmas) +import HsTypes(MonoType) +import Name(Name) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +data ClassDecl a b = ClassDecl [(a, a)] a a [Sig a] (MonoBinds a b) (ClassPragmas a) SrcLoc +data ConDecl a = ConDecl a [MonoType a] SrcLoc +data DataTypeSig a = AbstractTypeSig a SrcLoc | SpecDataSig a (MonoType a) SrcLoc +data DefaultDecl a = DefaultDecl [MonoType a] SrcLoc +data FixityDecl a = InfixL a Int | InfixR a Int | InfixN a Int +data InstDecl a b = InstDecl [(a, a)] a (MonoType a) (MonoBinds a b) Bool _PackedString _PackedString [Sig a] (InstancePragmas a) SrcLoc +type ProtoNameClassDecl = ClassDecl ProtoName (InPat ProtoName) +type ProtoNameConDecl = ConDecl ProtoName +type ProtoNameDataTypeSig = DataTypeSig ProtoName +type ProtoNameDefaultDecl = DefaultDecl ProtoName +type ProtoNameFixityDecl = FixityDecl ProtoName +type ProtoNameInstDecl = InstDecl ProtoName (InPat ProtoName) +type ProtoNameSpecialisedInstanceSig = SpecialisedInstanceSig ProtoName +type ProtoNameTyDecl = TyDecl ProtoName +type RenamedClassDecl = ClassDecl Name (InPat Name) +type RenamedConDecl = ConDecl Name +type RenamedDataTypeSig = DataTypeSig Name +type RenamedDefaultDecl = DefaultDecl Name +type RenamedFixityDecl = FixityDecl Name +type RenamedInstDecl = InstDecl Name (InPat Name) +type RenamedSpecialisedInstanceSig = SpecialisedInstanceSig Name +type RenamedTyDecl = TyDecl Name +data SpecialisedInstanceSig a = InstSpecSig a (MonoType a) SrcLoc +data TyDecl a = TyData [(a, a)] a [a] [ConDecl a] [a] (DataPragmas a) SrcLoc | TySynonym a [a] (MonoType a) TypePragmas SrcLoc +eqConDecls :: [ConDecl ProtoName] -> [ConDecl ProtoName] -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ClassDecl a b) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (ConDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (DataTypeSig a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (DefaultDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (FixityDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (InstDecl a b) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (SpecialisedInstanceSig a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a) => Outputable (TyDecl a) + {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsDecls.lhs b/ghc/compiler/abstractSyn/HsDecls.lhs new file mode 100644 index 0000000..8063775 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsDecls.lhs @@ -0,0 +1,299 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[HsDecls]{Abstract syntax: global declarations} + +Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@, +@InstDecl@, @DefaultDecl@. + +\begin{code} +#include "HsVersions.h" + +module HsDecls where + +import HsBinds ( nullMonoBinds, ProtoNameMonoBinds(..), + MonoBinds, Sig + ) +import HsPat ( ProtoNamePat(..), RenamedPat(..), InPat ) +import HsPragmas ( DataPragmas, TypePragmas, ClassPragmas, + InstancePragmas, ClassOpPragmas + ) +import HsTypes +import Id ( Id ) +import Name ( Name ) +import Outputable +import Pretty +import ProtoName ( cmpProtoName, ProtoName(..) ) -- .. for pragmas only +import SrcLoc ( SrcLoc ) +import Unique ( Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[FixityDecl]{A fixity declaration} +%* * +%************************************************************************ + +These are only used in generating interfaces at the moment. They are +not used in pretty-printing. + +\begin{code} +data FixityDecl name + = InfixL name Int + | InfixR name Int + | InfixN name Int + +type ProtoNameFixityDecl = FixityDecl ProtoName +type RenamedFixityDecl = FixityDecl Name +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name) + => Outputable (FixityDecl name) where + ppr sty (InfixL var prec) = ppCat [ppStr "infixl", ppInt prec, pprOp sty var] + ppr sty (InfixR var prec) = ppCat [ppStr "infixr", ppInt prec, pprOp sty var] + ppr sty (InfixN var prec) = ppCat [ppStr "infix ", ppInt prec, pprOp sty var] +\end{code} + +%************************************************************************ +%* * +\subsection[TyDecl]{An algebraic datatype or type-synonym declaration (plus @DataTypeSig@...)} +%* * +%************************************************************************ + +\begin{code} +data TyDecl name + = TyData (Context name) -- context (not used yet) + name -- type constructor + [name] -- type variables + [ConDecl name] -- data constructors + [name] -- derivings + (DataPragmas name) + SrcLoc + + | TySynonym name -- type constructor + [name] -- type variables + (MonoType name) -- synonym expansion + TypePragmas + SrcLoc + +type ProtoNameTyDecl = TyDecl ProtoName +type RenamedTyDecl = TyDecl Name +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name) + => Outputable (TyDecl name) where + + ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc) + = ppAbove (ifPprShowAll sty (ppr sty src_loc)) -- ToDo: pragmas + (ppHang (ppCat [ppStr "data", pprContext sty context, ppr sty tycon, interppSP sty tyvars]) + 4 + (ppSep [ + ppr sty condecls, + if (null derivings) then + ppNil + else + ppBesides [ppStr "deriving (", interpp'SP sty derivings, ppStr ")"]])) + + ppr sty (TySynonym tycon tyvars mono_ty pragmas src_loc) + = ppHang (ppCat [ppStr "type", ppr sty tycon, interppSP sty tyvars]) + 4 (ppCat [ppEquals, ppr sty mono_ty, + ifPprShowAll sty (ppr sty src_loc)]) -- ToDo: pragmas +\end{code} + +A type for recording what type synonyms the user wants treated as {\em +abstract} types. It's called a ``Sig'' because it's sort of like a +``type signature'' for an synonym declaration. + +Note: the Right Way to do this abstraction game is for the language to +support it. +\begin{code} +data DataTypeSig name + = AbstractTypeSig name -- tycon to abstract-ify + SrcLoc + | SpecDataSig name -- tycon to specialise + (MonoType name) + SrcLoc + + +type ProtoNameDataTypeSig = DataTypeSig ProtoName +type RenamedDataTypeSig = DataTypeSig Name + +instance (NamedThing name, Outputable name) + => Outputable (DataTypeSig name) where + + ppr sty (AbstractTypeSig tycon _) + = ppCat [ppStr "{-# ABSTRACT", ppr sty tycon, ppStr "#-}"] + + ppr sty (SpecDataSig tycon ty _) + = ppCat [ppStr "{-# SPECIALSIE data", ppr sty ty, ppStr "#-}"] +\end{code} + +%************************************************************************ +%* * +\subsection[ConDecl]{A data-constructor declaration} +%* * +%************************************************************************ + +A data constructor for an algebraic data type. + +\begin{code} +data ConDecl name = ConDecl name [MonoType name] SrcLoc + +type ProtoNameConDecl = ConDecl ProtoName +type RenamedConDecl = ConDecl Name +\end{code} + +In checking interfaces, we need to ``compare'' @ConDecls@. Use with care! +\begin{code} +eqConDecls cons1 cons2 + = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False } + where + cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _) + = case cmpProtoName n1 n2 of + EQ_ -> cmpList (cmpMonoType cmpProtoName) tys1 tys2 + xxx -> xxx +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where + + ppr sty (ConDecl con mono_tys src_loc) + = ppCat [pprNonOp sty con, + ppInterleave ppNil (map (pprParendMonoType sty) mono_tys)] +\end{code} + +%************************************************************************ +%* * +\subsection[ClassDecl]{A class declaration} +%* * +%************************************************************************ + +\begin{code} +data ClassDecl name pat + = ClassDecl (Context name) -- context... + name -- name of the class + name -- the class type variable + [Sig name] -- methods' signatures + (MonoBinds name pat) -- default methods + (ClassPragmas name) + SrcLoc + +type ProtoNameClassDecl = ClassDecl ProtoName ProtoNamePat +type RenamedClassDecl = ClassDecl Name RenamedPat +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name, + NamedThing pat, Outputable pat) + => Outputable (ClassDecl name pat) where + + ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc) + = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas, + ppr sty tyvar, ppStr "where"], + -- ToDo: really shouldn't print "where" unless there are sigs + ppNest 4 (ppAboves (map (ppr sty) sigs)), + ppNest 4 (ppr sty methods), + ppNest 4 (ppr sty pragmas)] +\end{code} + +%************************************************************************ +%* * +\subsection[InstDecl]{An instance declaration (also, @SpecialisedInstanceSig@)} +%* * +%************************************************************************ + +\begin{code} +data InstDecl name pat + = InstDecl (Context name) + name -- class + (MonoType name) + (MonoBinds name pat) + Bool -- True <=> This instance decl is from the + -- module being compiled; False <=> It is from + -- an imported interface. + + FAST_STRING{-ModuleName-} + -- The module where the instance decl + -- originally came from; easy enough if it's + -- the module being compiled; otherwise, the + -- info comes from a pragma. + + FAST_STRING + -- Name of the module who told us about this + -- inst decl (the `informer') ToDo: listify??? + + [Sig name] -- actually user-supplied pragmatic info + (InstancePragmas name) -- interface-supplied pragmatic info + SrcLoc + +type ProtoNameInstDecl = InstDecl ProtoName ProtoNamePat +type RenamedInstDecl = InstDecl Name RenamedPat +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name, + NamedThing pat, Outputable pat) + => Outputable (InstDecl name pat) where + + ppr sty (InstDecl context clas ty binds local modname imod uprags pragmas src_loc) + = let + top_matter = ppCat [ppStr "instance", pprContext sty context, ppr sty clas, ppr sty ty] + in + if nullMonoBinds binds && null uprags then + ppAbove top_matter (ppNest 4 (ppr sty pragmas)) + else + ppAboves [ + ppCat [top_matter, ppStr "where"], + ppNest 4 (ppr sty uprags), + ppNest 4 (ppr sty binds), + ppNest 4 (ppr sty pragmas) ] +\end{code} + +A type for recording what instances the user wants to specialise; +called a ``Sig'' because it's sort of like a ``type signature'' for an +instance. +\begin{code} +data SpecialisedInstanceSig name + = InstSpecSig name -- class + (MonoType name) -- type to specialise to + SrcLoc + +type ProtoNameSpecialisedInstanceSig = SpecialisedInstanceSig ProtoName +type RenamedSpecialisedInstanceSig = SpecialisedInstanceSig Name + +instance (NamedThing name, Outputable name) + => Outputable (SpecialisedInstanceSig name) where + + ppr sty (InstSpecSig clas ty _) + = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"] +\end{code} + +%************************************************************************ +%* * +\subsection[DefaultDecl]{A @default@ declaration} +%* * +%************************************************************************ + +There can only be one default declaration per module, but it is hard +for the parser to check that; we pass them all through in the abstract +syntax, and that restriction must be checked in the front end. + +\begin{code} +data DefaultDecl name + = DefaultDecl [MonoType name] + SrcLoc + +type ProtoNameDefaultDecl = DefaultDecl ProtoName +type RenamedDefaultDecl = DefaultDecl Name +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name) + => Outputable (DefaultDecl name) where + + ppr sty (DefaultDecl tys src_loc) + = ppBesides [ppStr "default (", interpp'SP sty tys, ppStr ")"] +\end{code} diff --git a/ghc/compiler/abstractSyn/HsExpr.hi b/ghc/compiler/abstractSyn/HsExpr.hi new file mode 100644 index 0000000..8f21886 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsExpr.hi @@ -0,0 +1,38 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsExpr where +import HsBinds(Binds) +import HsLit(Literal) +import HsMatches(Match) +import HsPat(InPat, TypecheckedPat) +import HsTypes(PolyType) +import Id(Id) +import Name(Name) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +import TyVar(TyVar) +import UniType(UniType) +data ArithSeqInfo a b = From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) +data Expr a b = Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id +type ProtoNameArithSeqInfo = ArithSeqInfo ProtoName (InPat ProtoName) +type ProtoNameExpr = Expr ProtoName (InPat ProtoName) +type ProtoNameQual = Qual ProtoName (InPat ProtoName) +data Qual a b = GeneratorQual b (Expr a b) | FilterQual (Expr a b) +type RenamedArithSeqInfo = ArithSeqInfo Name (InPat Name) +type RenamedExpr = Expr Name (InPat Name) +type RenamedQual = Qual Name (InPat Name) +type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat +type TypecheckedExpr = Expr Id TypecheckedPat +type TypecheckedQual = Qual Id TypecheckedPat +pprExpr :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Expr a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 22222222 _N_ _N_ _N_ _N_ #-} +pprParendExpr :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Expr a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 22222222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ArithSeqInfo a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Qual a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsExpr.lhs b/ghc/compiler/abstractSyn/HsExpr.lhs new file mode 100644 index 0000000..131958c --- /dev/null +++ b/ghc/compiler/abstractSyn/HsExpr.lhs @@ -0,0 +1,506 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[HsExpr]{Abstract Haskell syntax: expressions} + +\begin{code} +#include "HsVersions.h" + +module HsExpr where + +import AbsUniType ( pprUniType, pprParendUniType, TyVar, UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Name ( Name ) +import Unique ( Unique ) +import HsBinds ( Binds ) +import HsLit ( Literal ) +import HsMatches ( pprMatches, pprMatch, Match ) +import HsPat ( ProtoNamePat(..), RenamedPat(..), + TypecheckedPat, InPat + IF_ATTACK_PRAGMAS(COMMA typeOfPat) + ) +import HsTypes ( PolyType ) +import Id ( Id, DictVar(..), DictFun(..) ) +import Outputable +import ProtoName ( ProtoName(..) ) -- .. for pragmas only +import Pretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-Expr]{Expressions proper} +%* * +%************************************************************************ + +\begin{code} +data Expr bdee pat + = Var bdee -- variable + | Lit Literal -- literal + + | Lam (Match bdee pat) -- lambda + | App (Expr bdee pat) -- application + (Expr bdee pat) + + -- Operator applications and sections. + -- NB Bracketed ops such as (+) come out as Vars. + + | OpApp (Expr bdee pat) (Expr bdee pat) (Expr bdee pat) + -- middle expr is the "op" + + -- ADR Question? Why is the "op" in a section an expr when it will + -- have to be of the form (Var op) anyway? + -- WDP Answer: But when the typechecker gets ahold of it, it may + -- apply the var to a few types; it will then be an expression. + + | SectionL (Expr bdee pat) (Expr bdee pat) + -- right expr is the "op" + | SectionR (Expr bdee pat) (Expr bdee pat) + -- left expr is the "op" + + | CCall FAST_STRING -- call into the C world; string is + [Expr bdee pat] -- the C function; exprs are the + -- arguments to pass. + Bool -- True <=> might cause Haskell + -- garbage-collection (must generate + -- more paranoid code) + Bool -- True <=> it's really a "casm" + -- NOTE: this CCall is the *boxed* + -- version; the desugarer will convert + -- it into the unboxed "ccall#". + UniType -- The result type; will be *bottom* + -- until the typechecker gets ahold of it + + | SCC FAST_STRING -- set cost centre annotation + (Expr bdee pat) -- expr whose cost is to be measured + + | Case (Expr bdee pat) + [Match bdee pat] -- must have at least one Match + + | If -- conditional + (Expr bdee pat) -- predicate + (Expr bdee pat) -- then part + (Expr bdee pat) -- else part + + | Let (Binds bdee pat) -- let(rec) + (Expr bdee pat) + + | ListComp (Expr bdee pat) -- list comprehension + [Qual bdee pat] -- at least one Qual(ifier) + + | ExplicitList -- syntactic list + [Expr bdee pat] + | ExplicitListOut -- TRANSLATION + UniType -- Unitype gives type of components of list + [Expr bdee pat] + + | ExplicitTuple -- tuple + [Expr bdee pat] + -- NB: Unit is ExplicitTuple [] + -- for tuples, we can get the types + -- direct from the components + + | ExprWithTySig -- signature binding + (Expr bdee pat) + (PolyType bdee) + | ArithSeqIn -- arithmetic sequence + (ArithSeqInfo bdee pat) + | ArithSeqOut + (Expr bdee pat) -- (typechecked, of course) + (ArithSeqInfo bdee pat) +#ifdef DPH + | ParallelZF + (Expr bdee pat) + (ParQuals bdee pat) + | ExplicitPodIn + [Expr bdee pat] + | ExplicitPodOut + UniType -- Unitype gives type of components of list + [Expr bdee pat] + | ExplicitProcessor + [Expr bdee pat] + (Expr bdee pat) +#endif {- Data Parallel Haskell -} +\end{code} + +Everything from here on appears only in typechecker output; hence, the +explicit @Id@s. +\begin{code} + | TyLam -- TRANSLATION + [TyVar] -- Not TyVarTemplate, which only occur in a + -- binding position in a forall type. + (Expr bdee pat) + | TyApp -- TRANSLATION + (Expr bdee pat) -- generated by Spec + [UniType] + + -- DictLam and DictApp are "inverses" + | DictLam + [DictVar] + (Expr bdee pat) + | DictApp + (Expr bdee pat) + [DictVar] -- dictionary names + + -- ClassDictLam and Dictionary are "inverses" (see note below) + | ClassDictLam + [DictVar] + [Id] + -- The ordering here allows us to do away with dicts and methods + + -- [I don't understand this comment. WDP. Perhaps a ptr to + -- a complete description of what's going on ? ] + (Expr bdee pat) + | Dictionary + [DictVar] -- superclass dictionary names + [Id] -- method names + | SingleDict -- a simple special case of Dictionary + DictVar -- local dictionary name +\end{code} + +\begin{code} +type ProtoNameExpr = Expr ProtoName ProtoNamePat + +type RenamedExpr = Expr Name RenamedPat + +type TypecheckedExpr = Expr Id TypecheckedPat +\end{code} + +A @Dictionary@, unless of length 0 or 1, becomes a tuple. A +@ClassDictLam dictvars methods expr@ is, therefore: +\begin{verbatim} +\ x -> case x of ( dictvars-and-methods-tuple ) -> expr +\end{verbatim} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (Expr bdee pat) where + ppr = pprExpr +\end{code} + +\begin{code} +pprExpr :: (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + PprStyle -> Expr bdee pat -> Pretty + +pprExpr sty (Var v) + = if (isOpLexeme v) then + ppBesides [ppLparen, ppr sty v, ppRparen] + else + ppr sty v + +pprExpr sty (Lit lit) = ppr sty lit +pprExpr sty (Lam match) + = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)] + +pprExpr sty expr@(App e1 e2) + = let (fun, args) = collect_args expr [] in + ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args)) + where + collect_args (App fun arg) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +pprExpr sty (OpApp e1 op e2) + = case op of + Var v -> pp_infixly v + _ -> pp_prefixly + where + pp_e1 = pprParendExpr sty e1 + pp_e2 = pprParendExpr sty e2 + + pp_prefixly + = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2]) + + pp_infixly v + = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]] + +pprExpr sty (SectionL expr op) + = case op of + Var v -> pp_infixly v + _ -> pp_prefixly + where + pp_expr = pprParendExpr sty expr + + pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op]) + 4 (ppCat [pp_expr, ppStr "_x )"]) + pp_infixly v + = ppSep [ ppBesides [ppLparen, pp_expr], + ppBesides [pprOp sty v, ppRparen] ] + +pprExpr sty (SectionR op expr) + = case op of + Var v -> pp_infixly v + _ -> pp_prefixly + where + pp_expr = pprParendExpr sty expr + + pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppStr "_x"]) + 4 (ppBesides [pp_expr, ppRparen]) + pp_infixly v + = ppSep [ ppBesides [ppLparen, pprOp sty v], + ppBesides [pp_expr, ppRparen] ] + +pprExpr sty (CCall fun args _ is_asm result_ty) + = ppHang (if is_asm + then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"] + else ppCat [ppStr "_ccall_", ppPStr fun]) + 4 (ppSep (map (pprParendExpr sty) args + {-++ [ppCat [ppStr "{-", ppr sty result_ty, ppStr "-}"]]-})) + -- printing the result type can give reader panics (ToDo: fix) + +pprExpr sty (SCC label expr) + = ppSep [ ppBesides [ppStr "scc", ppBesides [ppChar '"', ppPStr label, ppChar '"'] ], + pprParendExpr sty expr ] + +pprExpr sty (Case expr matches) + = ppSep [ ppSep [ppStr "case", ppNest 4 (pprExpr sty expr), ppStr "of"], + ppNest 2 (pprMatches sty (True, ppNil) matches) ] + +pprExpr sty (ListComp expr quals) + = ppHang (ppCat [ppStr "[", pprExpr sty expr, ppStr "|"]) + 4 (ppSep [interpp'SP sty quals, ppRbrack]) + +-- special case: let ... in let ... +pprExpr sty (Let binds expr@(Let _ _)) + = ppSep [ppHang (ppStr "let") 2 (ppCat [ppr sty binds, ppStr "in"]), + ppr sty expr] + +pprExpr sty (Let binds expr) + = ppSep [ppHang (ppStr "let") 2 (ppr sty binds), + ppHang (ppStr "in") 2 (ppr sty expr)] + +pprExpr sty (ExplicitList exprs) + = ppBesides [ppLbrack, ppInterleave ppComma (map (pprExpr sty) exprs), ppRbrack] +pprExpr sty (ExplicitListOut ty exprs) + = ppBesides [ ppLbrack, ppInterleave ppComma (map (pprExpr sty) exprs), ppRbrack, + case sty of + PprForUser -> ppNil + _ -> ppBesides [ppStr " (", pprUniType sty ty, ppStr ")"] ] + +pprExpr sty (ExplicitTuple exprs) + = ppBesides [ppLparen, ppInterleave ppComma (map (pprExpr sty) exprs), ppRparen] +pprExpr sty (ExprWithTySig expr sig) + = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppStr " ::"]) + 4 (ppBesides [ppr sty sig, ppRparen]) + +pprExpr sty (If e1 e2 e3) + = ppSep [ppCat [ppStr "if", ppNest 2 (pprExpr sty e1), ppStr "then"], + ppNest 4 (pprExpr sty e2), + ppStr "else", + ppNest 4 (pprExpr sty e3)] +pprExpr sty (ArithSeqIn info) + = ppCat [ppLbrack, ppr sty info, ppRbrack] +pprExpr sty (ArithSeqOut expr info) + = case sty of + PprForUser -> + ppBesides [ppLbrack, ppr sty info, ppRbrack] + _ -> + ppBesides [ppLbrack, ppLparen, ppr sty expr, ppRparen, ppr sty info, ppRbrack] +#ifdef DPH +pprExpr sty (ParallelZF expr pquals) + = ppHang (ppCat [ppStr "<<" , pprExpr sty expr , ppStr "|"]) + 4 (ppSep [ppr sty pquals, ppStr ">>"]) + +pprExpr sty (ExplicitPodIn exprs) + = ppBesides [ppStr "<<", ppInterleave ppComma (map (pprExpr sty) exprs) , + ppStr ">>"] + +pprExpr sty (ExplicitPodOut ty exprs) + = ppBesides [ppStr "(",ppStr "<<", + ppInterleave ppComma (map (pprExpr sty) exprs), + ppStr ">>", ppStr " ::" , ppStr "<<" , pprUniType sty ty , + ppStr ">>" , ppStr ")"] + +pprExpr sty (ExplicitProcessor exprs expr) + = ppBesides [ppStr "(|", ppInterleave ppComma (map (pprExpr sty) exprs) , + ppSemi , pprExpr sty expr, ppStr "|)"] + +#endif {- Data Parallel Haskell -} + +-- for these translation-introduced things, we don't show them +-- if style is PprForUser + +pprExpr sty (TyLam tyvars expr) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"]) + 4 (pprExpr sty expr) + +pprExpr sty (TyApp expr [ty]) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppBeside pp_note (pprExpr sty expr)) 4 (pprParendUniType sty ty) + where + pp_note = ifPprShowAll sty (ppStr "{-TyApp-} ") + +pprExpr sty (TyApp expr tys) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppBeside pp_note (pprExpr sty expr)) + 4 (ppBesides [ppLbrack, interpp'SP sty tys, ppRbrack]) + where + pp_note = ifPprShowAll sty (ppStr "{-TyApp-} ") + +pprExpr sty (DictLam dictvars expr) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"]) + 4 (pprExpr sty expr) + +pprExpr sty (DictApp expr [dname]) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppBeside pp_note (pprExpr sty expr)) 4 (ppr sty dname) + where + pp_note = ifPprShowAll sty (ppStr "{-DictApp-} ") + +pprExpr sty (DictApp expr dnames) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppBeside pp_note (pprExpr sty expr)) + 4 (ppBesides [ppLbrack, interpp'SP sty dnames, ppRbrack]) + where + pp_note = ifPprShowAll sty (ppStr "{-DictApp-} ") + +pprExpr sty (ClassDictLam dicts methods expr) + = case sty of + PprForUser -> pprExpr sty expr + _ -> ppHang (ppCat [ppStr "\\{-classdict-}", + ppBesides [ppLbrack, interppSP sty dicts, ppRbrack], + ppBesides [ppLbrack, interppSP sty methods, ppRbrack], + ppStr "->"]) + 4 (pprExpr sty expr) + +pprExpr sty (Dictionary dictNames methods) + = ppSep [ppBesides [ppLparen, ppStr "{-dict-}"], + ppBesides [ppLbrack, interpp'SP sty dictNames, ppRbrack], + ppBesides [ppLbrack, interpp'SP sty methods, ppRbrack, ppRparen]] + +pprExpr sty (SingleDict dname) + = ppCat [ppStr "{-singleDict-}", ppr sty dname] +\end{code} + +Parenthesize unless very simple: +\begin{code} +pprParendExpr :: (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + PprStyle -> Expr bdee pat -> Pretty +pprParendExpr sty e@(Var _) = pprExpr sty e +pprParendExpr sty e@(Lit _) = pprExpr sty e +pprParendExpr sty other_e = ppBesides [ppLparen, pprExpr sty other_e, ppRparen] +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyntax-enums-list-comps]{Enumerations and list comprehensions} +%* * +%************************************************************************ + +\begin{code} +data ArithSeqInfo bdee pat + = From (Expr bdee pat) + | FromThen (Expr bdee pat) (Expr bdee pat) + | FromTo (Expr bdee pat) (Expr bdee pat) + | FromThenTo (Expr bdee pat) (Expr bdee pat) (Expr bdee pat) + +type ProtoNameArithSeqInfo = ArithSeqInfo ProtoName ProtoNamePat +type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat +type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (ArithSeqInfo bdee pat) where + ppr sty (From e1) = ppBesides [ppr sty e1, ppStr " .. "] + ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, ppStr " .. "] + ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, ppStr " .. ", ppr sty e3] + ppr sty (FromThenTo e1 e2 e3) + = ppBesides [ppr sty e1, pp'SP, ppr sty e2, ppStr " .. ", ppr sty e3] +\end{code} + +``Qualifiers'' in list comprehensions: +\begin{code} +data Qual bdee pat + = GeneratorQual pat (Expr bdee pat) + | FilterQual (Expr bdee pat) + +type ProtoNameQual = Qual ProtoName ProtoNamePat +type RenamedQual = Qual Name RenamedPat +type TypecheckedQual = Qual Id TypecheckedPat +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (Qual bdee pat) where + ppr sty (GeneratorQual pat expr) + = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] + ppr sty (FilterQual expr) = ppr sty expr +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyntax-parallel-quals]{Parallel Qualifiers for ZF expressions} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH +data ParQuals var pat + = AndParQuals (ParQuals var pat) + (ParQuals var pat) + | DrawnGenIn [pat] + pat + (Expr var pat) -- (|pat1,...,patN;pat|)<<-exp + + | DrawnGenOut [pat] -- Same information as processor + [(Expr var pat)] -- Conversion fn of type t -> Integer + pat -- to keep things together :-) + (Expr var pat) + | IndexGen [(Expr var pat)] + pat + (Expr var pat) -- (|exp1,...,expN;pat|)<<-exp + | ParFilter (Expr var pat) + +type ProtoNameParQuals = ParQuals ProtoName ProtoNamePat +type RenamedParQuals = ParQuals Name RenamedPat +type TypecheckedParQuals = ParQuals Id TypecheckedPat + +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (ParQuals bdee pat) where + ppr sty (AndParQuals quals1 quals2) + = ppBesides [ppr sty quals1, pp'SP, ppr sty quals2] + ppr sty (DrawnGenIn pats pat expr) + = ppCat [ppStr "(|", + ppInterleave ppComma (map (ppr sty) pats), + ppSemi, ppr sty pat,ppStr "|)", + ppStr "<<-", ppr sty expr] + + ppr sty (DrawnGenOut pats convs pat expr) + = case sty of + PprForUser -> basic_ppr + _ -> ppHang basic_ppr 4 exprs_ppr + where + basic_ppr = ppCat [ppStr "(|", + ppInterleave ppComma (map (ppr sty) pats), + ppSemi, ppr sty pat,ppStr "|)", + ppStr "<<-", ppr sty expr] + + exprs_ppr = ppBesides [ppStr "{- " , + ppr sty convs, + ppStr " -}"] + + ppr sty (IndexGen exprs pat expr) + = ppCat [ppStr "(|", + ppInterleave ppComma (map (pprExpr sty) exprs), + ppSemi, ppr sty pat, ppStr "|)", + ppStr "<<=", ppr sty expr] + + ppr sty (ParFilter expr) = ppr sty expr +#endif {-Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/abstractSyn/HsImpExp.hi b/ghc/compiler/abstractSyn/HsImpExp.hi new file mode 100644 index 0000000..df2f2e6 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsImpExp.hi @@ -0,0 +1,42 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsImpExp where +import FiniteMap(FiniteMap) +import HsBinds(Sig) +import HsDecls(ClassDecl, FixityDecl, InstDecl, TyDecl) +import HsPat(InPat) +import Name(Name) +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +data IE = IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString +data IfaceImportDecl = IfaceImportDecl _PackedString [IE] [Renaming] SrcLoc +type ImExportListInfo = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) +data ImportedInterface a b = ImportAll (Interface a b) [Renaming] | ImportSome (Interface a b) [IE] [Renaming] | ImportButHide (Interface a b) [IE] [Renaming] +data Interface a b = MkInterface _PackedString [IfaceImportDecl] [FixityDecl a] [TyDecl a] [ClassDecl a b] [InstDecl a b] [Sig a] SrcLoc +type ProtoNameImportedInterface = ImportedInterface ProtoName (InPat ProtoName) +type ProtoNameInterface = Interface ProtoName (InPat ProtoName) +type RenamedImportedInterface = ImportedInterface Name (InPat Name) +type RenamedInterface = Interface Name (InPat Name) +data Renaming = MkRenaming _PackedString _PackedString +getIEStrings :: [IE] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getRawIEStrings :: [IE] -> ([(_PackedString, ExportFlag)], [_PackedString]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +pprRenamings :: PprStyle -> [Renaming] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +instance Outputable IE + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IE) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable IfaceImportDecl + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IfaceImportDecl) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLA)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ImportedInterface a b) + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Interface a b) + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable Renaming + {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Renaming) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AU(LL)" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsImpExp.lhs b/ghc/compiler/abstractSyn/HsImpExp.lhs new file mode 100644 index 0000000..3db0fda --- /dev/null +++ b/ghc/compiler/abstractSyn/HsImpExp.lhs @@ -0,0 +1,226 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[HsImpExp]{Abstract syntax: imports, exports, interfaces} + +\begin{code} +#include "HsVersions.h" + +module HsImpExp where + +import FiniteMap +import HsDecls ( FixityDecl, TyDecl, ClassDecl, InstDecl ) +import HsBinds ( Sig ) +import HsPat ( ProtoNamePat(..), RenamedPat(..), InPat ) +import Id ( Id ) +import Name ( Name ) +import Outputable +import Pretty +import ProtoName ( ProtoName(..) ) -- .. for pragmas only +import SrcLoc ( SrcLoc ) +import Unique ( Unique ) +import Util -- pragmas only +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-ImpExpDecls]{Import and export declaration lists} +%* * +%************************************************************************ + +One per \tr{import} declaration in a module. +\begin{code} +data ImportedInterface name pat + = ImportAll (Interface name pat) -- the contents of the interface + -- (incl module name) + [Renaming] + + | ImportSome (Interface name pat) + [IE] -- the only things being imported + [Renaming] + + | ImportButHide (Interface name pat) + [IE] -- import everything "but hide" these entities + [Renaming] +\end{code} + +Synonyms: +\begin{code} +type ProtoNameImportedInterface = ImportedInterface ProtoName ProtoNamePat +type RenamedImportedInterface = ImportedInterface Name RenamedPat +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name, + NamedThing pat, Outputable pat) + => Outputable (ImportedInterface name pat) where + + ppr sty (ImportAll iface renamings) + = ppAbove (ppCat [ppStr "import", ppr sty iface]) + (pprRenamings sty renamings) + + ppr sty (ImportSome iface imports renamings) + = ppAboves [ppCat [ppStr "import", ppr sty iface], + ppNest 8 (ppBesides [ppStr " (", interpp'SP sty imports, ppStr ") "]), + pprRenamings sty renamings] + + ppr sty (ImportButHide iface imports renamings) + = ppAboves [ppCat [ppStr "import", ppr sty iface], + ppNest 8 (ppBesides [ppStr "hiding (", interpp'SP sty imports, ppStr ") "]), + pprRenamings sty renamings] +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-entities]{Imported and exported entities} +%* * +%************************************************************************ +\begin{code} +data IE + = IEVar FAST_STRING + | IEThingAbs FAST_STRING -- Constructor/Type/Class (can't tell) + | IEThingAll FAST_STRING -- Class/Type plus all methods/constructors + | IEConWithCons FAST_STRING -- import tycon w/ some cons + [FAST_STRING] + | IEClsWithOps FAST_STRING -- import tycls w/ some methods + [FAST_STRING] + | IEModuleContents FAST_STRING -- (Export Only) +\end{code} + +\begin{code} +instance Outputable IE where + ppr sty (IEVar var) = ppPStr var + ppr sty (IEThingAbs thing) = ppPStr thing + ppr sty (IEThingAll thing) = ppBesides [ppPStr thing, ppStr "(..)"] + ppr sty (IEConWithCons tycon datacons) + = ppBesides [ppPStr tycon, ppLparen, ppInterleave ppComma (map ppPStr datacons), ppRparen] + ppr sty (IEClsWithOps cls methods) + = ppBesides [ppPStr cls, ppLparen, ppInterleave ppComma (map ppPStr methods), ppRparen] + ppr sty (IEModuleContents mod) = ppBesides [ppPStr mod, ppStr ".."] +\end{code} + +We want to know what names are exported (the first list of the result) +and what modules are exported (the second list of the result). +\begin{code} +type ImExportListInfo + = ( FiniteMap FAST_STRING ExportFlag, + -- Assoc list of im/exported things & + -- their "export" flags (im/exported + -- abstractly, concretely, etc.) + -- Hmm... slight misnomer there (WDP 95/02) + FiniteSet FAST_STRING ) + -- List of modules to be exported + -- entirely; NB: *not* everything with + -- original names in these modules; + -- but: everything that these modules' + -- interfaces told us about. + -- Note: This latter component can + -- only arise on export lists. + +getIEStrings :: [IE] -> ImExportListInfo +getRawIEStrings :: [IE] -> ([(FAST_STRING, ExportFlag)], [FAST_STRING]) + -- "Raw" gives the raw lists of things; we need this for + -- checking for duplicates. + +getIEStrings exps + = case (getRawIEStrings exps) of { (pairs, mods) -> + (listToFM pairs, mkSet mods) } + +getRawIEStrings exps + = foldr do_one ([],[]) exps + where + do_one (IEVar n) (prs, mods) + = ((n, ExportAll):prs, mods) + do_one (IEThingAbs n) (prs, mods) + = ((n, ExportAbs):prs, mods) + do_one (IEThingAll n) (prs, mods) + = ((n, ExportAll):prs, mods) + do_one (IEConWithCons n ns) (prs, mods) -- needn't do anything + = ((n, ExportAll):prs, mods) -- with the indiv cons/ops + do_one (IEClsWithOps n ns) (prs, mods) + = ((n, ExportAll):prs, mods) + do_one (IEModuleContents n) (prs, mods) + = (prs, n : mods) +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-Renaming]{Renamings} +%* * +%************************************************************************ + +\begin{code} +data Renaming = MkRenaming FAST_STRING FAST_STRING +\end{code} + +\begin{code} +pprRenamings :: PprStyle -> [Renaming] -> Pretty +pprRenamings sty [] = ppNil +pprRenamings sty rs = ppBesides [ppStr "renaming (", interpp'SP sty rs, ppStr ")"] +\end{code} + +\begin{code} +instance Outputable Renaming where + ppr sty (MkRenaming from too) = ppCat [ppPStr from, ppStr "to", ppPStr too] +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyn-Interface]{Interfaces} +%* * +%************************************************************************ + +\begin{code} +data Interface name pat + = MkInterface FAST_STRING -- module name + [IfaceImportDecl] + [FixityDecl name] -- none yet (ToDo) + [TyDecl name] -- data decls may have no constructors + [ClassDecl name pat] -- Without default methods + [InstDecl name pat] -- Without method defns + [Sig name] + SrcLoc +\end{code} + +\begin{code} +type ProtoNameInterface = Interface ProtoName ProtoNamePat +type RenamedInterface = Interface Name RenamedPat +\end{code} + +\begin{code} +instance (NamedThing name, Outputable name, + NamedThing pat, Outputable pat) + => Outputable (Interface name pat) where + + ppr PprForUser (MkInterface name _ _ _ _ _ _ _) = ppPStr name + + ppr sty (MkInterface name iimpdecls fixities tydecls classdecls instdecls sigs anns) + = ppHang (ppBeside (ppPStr name) (ppStr " {-")) + 4 (ppAboves [ + ifPprShowAll sty (ppr sty anns), + ppCat [ppStr "interface", ppPStr name, ppStr "where"], + ppNest 4 (ppAboves [ + ppr sty iimpdecls, ppr sty fixities, + ppr sty tydecls, ppr sty classdecls, + ppr sty instdecls, ppr sty sigs]), + ppStr "-}"]) +\end{code} + +\begin{code} +data IfaceImportDecl + = IfaceImportDecl FAST_STRING -- module we're being told about + [IE] -- things we're being told about + [Renaming] -- AAYYYYEEEEEEEEEE!!! (help) + SrcLoc +\end{code} + +\begin{code} +instance Outputable IfaceImportDecl where + + ppr sty (IfaceImportDecl mod names renamings src_loc) + = ppHang (ppCat [ppStr "import", ppPStr mod, ppLparen]) + 4 (ppSep [ppCat [interpp'SP sty names, ppRparen], + pprRenamings sty renamings]) +\end{code} + + diff --git a/ghc/compiler/abstractSyn/HsLit.hi b/ghc/compiler/abstractSyn/HsLit.hi new file mode 100644 index 0000000..c19a0d3 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsLit.hi @@ -0,0 +1,13 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsLit where +import Outputable(Outputable) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import UniType(UniType) +data Literal = CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) +negLiteral :: Literal -> Literal + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance Outputable Literal + {-# GHC_PRAGMA _M_ HsLit {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Literal) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsLit.lhs b/ghc/compiler/abstractSyn/HsLit.lhs new file mode 100644 index 0000000..bf5ae19 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsLit.lhs @@ -0,0 +1,76 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[HsLit]{Abstract syntax: source-language literals} + +\begin{code} +#include "HsVersions.h" + +module HsLit where + +import AbsPrel ( PrimKind ) +import Outputable +import Pretty +import Util +\end{code} + +\begin{code} +data Literal + = CharLit Char -- characters + | CharPrimLit Char -- unboxed char literals + | StringLit FAST_STRING -- strings + | StringPrimLit FAST_STRING -- packed string + + | IntLit Integer -- integer-looking literals + | FracLit Rational -- frac-looking literals + -- Up through dict-simplification, IntLit and FracLit simply + -- mean the literal was integral- or fractional-looking; i.e., + -- whether it had an explicit decimal-point in it. *After* + -- dict-simplification, they mean (boxed) "Integer" and + -- "Rational" [Ratio Integer], respectively. + + -- Dict-simplification tries to replace such lits w/ more + -- specific ones, using the unboxed variants that follow... + | LitLitLitIn FAST_STRING -- to pass ``literal literals'' through to C + -- also: "overloaded" type; but + -- must resolve to boxed-primitive! + -- (WDP 94/10) + | LitLitLit FAST_STRING + UniType -- and now we know the type + -- Must be a boxed-primitive type + + | IntPrimLit Integer -- unboxed Int literals +#if __GLASGOW_HASKELL__ <= 22 + | FloatPrimLit Double -- unboxed Float literals + | DoublePrimLit Double -- unboxed Double literals +#else + | FloatPrimLit Rational -- unboxed Float literals + | DoublePrimLit Rational -- unboxed Double literals +#endif +\end{code} + +\begin{code} +negLiteral (IntLit i) = IntLit (-i) +negLiteral (FracLit f) = FracLit (-f) +\end{code} + +\begin{code} +instance Outputable Literal where + ppr sty (CharLit c) = ppStr (show c) + ppr sty (CharPrimLit c) = ppBeside (ppStr (show c)) (ppChar '#') + ppr sty (StringLit s) = ppStr (show s) + ppr sty (StringPrimLit s) = ppBeside (ppStr (show s)) (ppChar '#') + ppr sty (IntLit i) = ppInteger i +#if __GLASGOW_HASKELL__ <= 22 + ppr sty (FracLit f) = ppDouble (fromRational f) -- ToDo: better?? + ppr sty (FloatPrimLit f) = ppBeside (ppDouble f) (ppChar '#') + ppr sty (DoublePrimLit d) = ppBeside (ppDouble d) (ppStr "##") +#else + ppr sty (FracLit f) = ppRational f + ppr sty (FloatPrimLit f) = ppBeside (ppRational f) (ppChar '#') + ppr sty (DoublePrimLit d) = ppBeside (ppRational d) (ppStr "##") +#endif + ppr sty (IntPrimLit i) = ppBeside (ppInteger i) (ppChar '#') + ppr sty (LitLitLitIn s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"] + ppr sty (LitLitLit s k) = ppBesides [ppStr "``", ppPStr s, ppStr "''"] +\end{code} diff --git a/ghc/compiler/abstractSyn/HsMatches.hi b/ghc/compiler/abstractSyn/HsMatches.hi new file mode 100644 index 0000000..bec156c --- /dev/null +++ b/ghc/compiler/abstractSyn/HsMatches.hi @@ -0,0 +1,39 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsMatches where +import HsBinds(Binds) +import HsExpr(Expr) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import Name(Name) +import Outputable(NamedThing, Outputable) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +import UniType(UniType) +data GRHS a b = GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc +data GRHSsAndBinds a b = GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType +data Match a b = PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) +type ProtoNameGRHS = GRHS ProtoName (InPat ProtoName) +type ProtoNameGRHSsAndBinds = GRHSsAndBinds ProtoName (InPat ProtoName) +type ProtoNameMatch = Match ProtoName (InPat ProtoName) +type RenamedGRHS = GRHS Name (InPat Name) +type RenamedGRHSsAndBinds = GRHSsAndBinds Name (InPat Name) +type RenamedMatch = Match Name (InPat Name) +type TypecheckedGRHS = GRHS Id TypecheckedPat +type TypecheckedGRHSsAndBinds = GRHSsAndBinds Id TypecheckedPat +type TypecheckedMatch = Match Id TypecheckedPat +pprGRHS :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Bool -> GRHS a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222221122 _N_ _N_ _N_ _N_ #-} +pprGRHSsAndBinds :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Bool -> GRHSsAndBinds a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222122 _N_ _N_ _N_ _N_ #-} +pprMatch :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Bool -> Match a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 7 _U_ 222222122 _N_ _S_ "LLLLLLS" _N_ _N_ #-} +pprMatches :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> (Bool, Int -> Bool -> PrettyRep) -> [Match a b] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222221222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Match a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: Match u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: Match", u8, u9 ] _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsMatches.lhs b/ghc/compiler/abstractSyn/HsMatches.lhs new file mode 100644 index 0000000..15620ed --- /dev/null +++ b/ghc/compiler/abstractSyn/HsMatches.lhs @@ -0,0 +1,215 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides} + +The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes. + +\begin{code} +#include "HsVersions.h" + +module HsMatches where + +import AbsUniType ( UniType + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import HsBinds ( Binds, nullBinds ) +import HsExpr ( Expr ) +import HsPat ( ProtoNamePat(..), RenamedPat(..), + TypecheckedPat, InPat + IF_ATTACK_PRAGMAS(COMMA typeOfPat) + ) +import Name ( Name ) +import Unique ( Unique ) +import Id ( Id ) +import Outputable +import Pretty +import ProtoName ( ProtoName(..) ) -- .. for pragmas only +import SrcLoc ( SrcLoc ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyntax-Match]{@Match@} +%* * +%************************************************************************ + +Sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, +if a function @g@ is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then a single @Match@ would be either @(x,y) = y@ or +@((x:ys),y) = y+1@, and @[Match]@ would be +@[((x,y) = y), (((x:ys),y) = y+1)]@. + +It is always the case that each element of an @[Match]@ list has the +same number of @PatMatch@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. + +So, a single ``match'': +\begin{code} +data Match bdee pat + = PatMatch pat + (Match bdee pat) + | GRHSMatch (GRHSsAndBinds bdee pat) + +type ProtoNameMatch = Match ProtoName ProtoNamePat +type RenamedMatch = Match Name RenamedPat +type TypecheckedMatch = Match Id TypecheckedPat +\end{code} + +Printing, of one and several @Matches@. +\begin{code} +pprMatch :: (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + PprStyle -> Bool -> Match bdee pat -> Pretty + +pprMatch sty is_case first_match + = ppHang (ppSep (map (ppr sty) row_of_pats)) + 8 grhss_etc_stuff + where + (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match + + ppr_match sty is_case (PatMatch pat match) + = (pat:pats, grhss_stuff) + where + (pats, grhss_stuff) = ppr_match sty is_case match + + ppr_match sty is_case (GRHSMatch grhss_n_binds) + = ([], pprGRHSsAndBinds sty is_case grhss_n_binds) +\end{code} + +We know the list must have at least one @Match@ in it. +\begin{code} +pprMatches :: (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + PprStyle -> (Bool, Pretty) -> [Match bdee pat] -> Pretty + +pprMatches sty print_info@(is_case, name) [match] + = if is_case then + pprMatch sty is_case match + else + ppHang name 4 (pprMatch sty is_case match) + +pprMatches sty print_info (match1 : rest) + = ppAbove (pprMatches sty print_info [match1]) + (pprMatches sty print_info rest) +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (Match bdee pat) where + ppr sty b = panic "ppr: Match" +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyntax-GRHSsAndBinds]{Guarded RHSs plus their Binds} +%* * +%************************************************************************ + +Possibly \tr{NoGuardNoBinds{In,Out}}, etc.? ToDo + +\begin{code} +data GRHSsAndBinds bdee pat + = GRHSsAndBindsIn [GRHS bdee pat] -- at least one GRHS + (Binds bdee pat) + + | GRHSsAndBindsOut [GRHS bdee pat] -- at least one GRHS + (Binds bdee pat) + UniType + +type ProtoNameGRHSsAndBinds = GRHSsAndBinds ProtoName ProtoNamePat +type RenamedGRHSsAndBinds = GRHSsAndBinds Name RenamedPat +type TypecheckedGRHSsAndBinds = GRHSsAndBinds Id TypecheckedPat +\end{code} + +\begin{code} +pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds) + = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss)) + (if (nullBinds binds) + then ppNil + else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ]) + +pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty) + = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss)) + (if (nullBinds binds) + then ppNil + else ppAboves [ ifPprShowAll sty + (ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]), + ppStr "where", ppNest 4 (ppr sty binds) ]) +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (GRHSsAndBinds bdee pat) where + ppr sty b = panic "ppr:GRHSsAndBinds" +\end{code} + +%************************************************************************ +%* * +\subsection[AbsSyntax-GRHS]{A guarded right-hand-side} +%* * +%************************************************************************ + +Sets of guarded right hand sides. In +\begin{verbatim} +f (x,y) | x==True = y + | otherwise = y*2 +\end{verbatim} +a guarded right hand side is either +@(x==True = y)@, or @(otherwise = y*2)@. + +For each match, there may be several guarded right hand +sides, as the definition of @f@ shows. + +\begin{code} +data GRHS bdee pat + = GRHS (Expr bdee pat) -- guard(ed)... + (Expr bdee pat) -- ... right-hand side + SrcLoc + + | OtherwiseGRHS (Expr bdee pat) -- guard-free + SrcLoc +\end{code} + +And, as always: +\begin{code} +type ProtoNameGRHS = GRHS ProtoName ProtoNamePat +type RenamedGRHS = GRHS Name RenamedPat +type TypecheckedGRHS = GRHS Id TypecheckedPat +\end{code} + +\begin{code} +pprGRHS :: (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + PprStyle -> Bool -> GRHS bdee pat -> Pretty + +pprGRHS sty is_case (GRHS guard expr locn) + = ppAboves [ + ifPprShowAll sty (ppr sty locn), + ppHang (ppCat [ppStr "|", ppr sty guard, ppStr (if is_case then "->" else "=")]) + 4 (ppr sty expr) + ] + +pprGRHS sty is_case (OtherwiseGRHS expr locn) + = ppAboves [ + ifPprShowAll sty (ppr sty locn), + ppHang (ppStr (if is_case then "->" else "=")) + 4 (ppr sty expr) + ] +\end{code} + +\begin{code} +instance (NamedThing bdee, Outputable bdee, + NamedThing pat, Outputable pat) => + Outputable (GRHS bdee pat) where + ppr sty b = panic "ppr: GRHSs" +\end{code} diff --git a/ghc/compiler/abstractSyn/HsPat.hi b/ghc/compiler/abstractSyn/HsPat.hi new file mode 100644 index 0000000..94da9f2 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsPat.hi @@ -0,0 +1,58 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsPat where +import HsExpr(Expr) +import HsLit(Literal) +import Id(Id) +import Name(Name) +import Outputable(NamedThing, Outputable) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +import UniType(UniType) +data InPat a = WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal +type ProtoNamePat = InPat ProtoName +type RenamedPat = InPat Name +data TypecheckedPat = WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) +irrefutablePat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isConPat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isLitPat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +only_con :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +patsAreAllCons :: [TypecheckedPat] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +patsAreAllLits :: [TypecheckedPat] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pprConPatTy :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +pprInPat :: Outputable a => PprStyle -> InPat a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 22122 _N_ _N_ _N_ _N_ #-} +pprTypecheckedPat :: PprStyle -> TypecheckedPat -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +typeOfPat :: TypecheckedPat -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unfailablePat :: TypecheckedPat -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unfailablePats :: [TypecheckedPat] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing a => NamedThing (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-} +instance NamedThing TypecheckedPat + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TypecheckedPat -> ExportFlag), (TypecheckedPat -> Bool), (TypecheckedPat -> (_PackedString, _PackedString)), (TypecheckedPat -> _PackedString), (TypecheckedPat -> [_PackedString]), (TypecheckedPat -> SrcLoc), (TypecheckedPat -> Unique), (TypecheckedPat -> Bool), (TypecheckedPat -> UniType), (TypecheckedPat -> Bool)] [_CONSTM_ NamedThing getExportFlag (TypecheckedPat), _CONSTM_ NamedThing isLocallyDefined (TypecheckedPat), _CONSTM_ NamedThing getOrigName (TypecheckedPat), _CONSTM_ NamedThing getOccurrenceName (TypecheckedPat), _CONSTM_ NamedThing getInformingModules (TypecheckedPat), _CONSTM_ NamedThing getSrcLoc (TypecheckedPat), _CONSTM_ NamedThing getTheUnique (TypecheckedPat), _CONSTM_ NamedThing hasType (TypecheckedPat), _ORIG_ HsPat typeOfPat, _CONSTM_ NamedThing fromPreludeCore (TypecheckedPat)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TypecheckedPat) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ HsPat typeOfPat _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-} +instance Outputable a => Outputable (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable TypecheckedPat + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsPat.lhs b/ghc/compiler/abstractSyn/HsPat.lhs new file mode 100644 index 0000000..35b54e4 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsPat.lhs @@ -0,0 +1,352 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[PatSyntax]{Abstract Haskell syntax---patterns} + +\begin{code} +#include "HsVersions.h" + +module HsPat where + +import AbsPrel ( mkTupleTy, mkListTy + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +#ifdef DPH + , mkProcessorTy +#endif + ) +import AbsUniType +import HsLit ( Literal ) +import HsExpr ( Expr, TypecheckedExpr(..) ) +import Id +import IdInfo +import Maybes ( maybeToBool, Maybe(..) ) +import Name ( Name ) +import ProtoName ( ProtoName(..) ) -- .. for pragmas only +import Outputable +import Pretty +import Unique ( Unique ) +import Util +\end{code} + +Patterns come in distinct before- and after-typechecking flavo(u)rs. +\begin{code} +data InPat name + = WildPatIn --X wild card + | VarPatIn name --X variable + | LitPatIn Literal -- literal + | LazyPatIn (InPat name) --X lazy pattern + | AsPatIn name --X as pattern + (InPat name) + | ConPatIn name --X constructed type + [(InPat name)] + | ConOpPatIn (InPat name) + name + (InPat name) + | ListPatIn [InPat name] --X syntactic list + -- must have >= 1 elements + | TuplePatIn [InPat name] --X tuple + -- UnitPat is TuplePat [] + | NPlusKPatIn name -- n+k pattern + Literal +#ifdef DPH + | ProcessorPatIn [(InPat name)] + (InPat name) -- (|pat1,...,patK;pat|) +#endif {- Data Parallel Haskell -} + +type ProtoNamePat = InPat ProtoName +type RenamedPat = InPat Name + +data TypecheckedPat + = WildPat UniType -- wild card + + | VarPat Id -- variable (type is in the Id) + + | LazyPat TypecheckedPat -- lazy pattern + + | AsPat Id -- as pattern + TypecheckedPat + + | ConPat Id -- constructed type; + UniType -- the type of the pattern + [TypecheckedPat] + + | ConOpPat TypecheckedPat -- just a special case... + Id + TypecheckedPat + UniType + | ListPat -- syntactic list + UniType -- the type of the elements + [TypecheckedPat] + + | TuplePat [TypecheckedPat] -- tuple + -- UnitPat is TuplePat [] + + | LitPat -- Used for *non-overloaded* literal patterns: + -- Int#, Char#, Int, Char, String, etc. + Literal + UniType -- type of pattern + + | NPat -- Used for *overloaded* literal patterns + Literal -- the literal is retained so that + -- the desugarer can readily identify + -- equations with identical literal-patterns + UniType -- type of pattern, t + TypecheckedExpr -- Of type t -> Bool; detects match + + | NPlusKPat Id + Literal -- Same reason as for LitPat + -- (This could be an Integer, but then + -- it's harder to partitionEqnsByLit + -- in the desugarer.) + UniType -- Type of pattern, t + TypecheckedExpr -- "fromInteger literal"; of type t + TypecheckedExpr -- Of type t-> t -> Bool; detects match + TypecheckedExpr -- Of type t -> t -> t; subtracts k +#ifdef DPH + | ProcessorPat + [TypecheckedPat] -- Typechecked Pattern + [TypecheckedExpr] -- Of type t-> Integer; conversion + TypecheckedPat -- Data at that processor +#endif {- Data Parallel Haskell -} +\end{code} + +Note: If @typeOfPat@ doesn't bear a strong resemblance to @typeOfCoreExpr@, +then something is wrong. +\begin{code} +typeOfPat :: TypecheckedPat -> UniType +typeOfPat (WildPat ty) = ty +typeOfPat (VarPat var) = getIdUniType var +typeOfPat (LazyPat pat) = typeOfPat pat +typeOfPat (AsPat var pat) = getIdUniType var +typeOfPat (ConPat _ ty _) = ty +typeOfPat (ConOpPat _ _ _ ty) = ty +typeOfPat (ListPat ty _) = mkListTy ty +typeOfPat (TuplePat pats) = mkTupleTy (length pats) (map typeOfPat pats) +typeOfPat (LitPat lit ty) = ty +typeOfPat (NPat lit ty _) = ty +typeOfPat (NPlusKPat n k ty _ _ _) = ty +#ifdef DPH +-- Should be more efficient to find type of pid than pats +typeOfPat (ProcessorPat pats _ pat) + = mkProcessorTy (map typeOfPat pats) (typeOfPat pat) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +instance (NamedThing name) => NamedThing (InPat name) where + hasType pat = False +#ifdef DEBUG + getExportFlag = panic "NamedThing.InPat.getExportFlag" + isLocallyDefined = panic "NamedThing.InPat.isLocallyDefined" + getOrigName = panic "NamedThing.InPat.getOrigName" + getOccurrenceName = panic "NamedThing.InPat.getOccurrenceName" + getInformingModules = panic "NamedThing.InPat.getOccurrenceName" + getSrcLoc = panic "NamedThing.InPat.getSrcLoc" + getTheUnique = panic "NamedThing.InPat.getTheUnique" + getType pat = panic "NamedThing.InPat.getType" + fromPreludeCore = panic "NamedThing.InPat.fromPreludeCore" +#endif + +instance NamedThing TypecheckedPat where + hasType pat = True + getType = typeOfPat +#ifdef DEBUG + getExportFlag = panic "NamedThing.TypecheckedPat.getExportFlag" + isLocallyDefined = panic "NamedThing.TypecheckedPat.isLocallyDefined" + getOrigName = panic "NamedThing.TypecheckedPat.getOrigName" + getOccurrenceName = panic "NamedThing.TypecheckedPat.getOccurrenceName" + getInformingModules = panic "NamedThing.TypecheckedPat.getOccurrenceName" + getSrcLoc = panic "NamedThing.TypecheckedPat.getSrcLoc" + getTheUnique = panic "NamedThing.TypecheckedPat.getTheUnique" + fromPreludeCore = panic "NamedThing.TypecheckedPat.fromPreludeCore" +#endif +\end{code} + +\begin{code} +instance (Outputable name) => Outputable (InPat name) where + ppr = pprInPat + +pprInPat :: (Outputable name) => PprStyle -> InPat name -> Pretty +pprInPat sty (WildPatIn) = ppStr "_" +pprInPat sty (VarPatIn var) = ppr sty var +pprInPat sty (LitPatIn s) = ppr sty s +pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat) +pprInPat sty (AsPatIn name pat) + = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] + +pprInPat sty (ConPatIn c pats) + = if null pats then + ppr sty c + else + ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen] + + +pprInPat sty (ConOpPatIn pat1 op pat2) + = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen] + +-- ToDo: use pprOp to print op (but this involves fiddling various +-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) + +pprInPat sty (ListPatIn pats) + = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] +pprInPat sty (TuplePatIn pats) + = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] +pprInPat sty (NPlusKPatIn n k) + = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] +#ifdef DPH +pprInPat sty (ProcessorPatIn pats pat) + = ppBesides [ppStr "(|", interpp'SP sty pats,ppSemi , + ppr sty pat , ppStr "|)"] +#endif {- Data Parallel Haskell -} +\end{code} + +Problems with @Outputable@ instance for @TypecheckedPat@ when no +original names. +\begin{code} +instance Outputable TypecheckedPat where + ppr = pprTypecheckedPat +\end{code} + +\begin{code} +pprTypecheckedPat sty (WildPat ty) = ppChar '_' +pprTypecheckedPat sty (VarPat var) = ppr sty var +pprTypecheckedPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat] +pprTypecheckedPat sty (AsPat name pat) + = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen] + +pprTypecheckedPat sty (ConPat name ty []) + = ppBeside (ppr sty name) + (ifPprShowAll sty (pprConPatTy sty ty)) + +pprTypecheckedPat sty (ConPat name ty pats) + = ppBesides [ppLparen, ppr sty name, ppSP, + interppSP sty pats, ppRparen, + ifPprShowAll sty (pprConPatTy sty ty) ] + +pprTypecheckedPat sty (ConOpPat pat1 op pat2 ty) + = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen] + +pprTypecheckedPat sty (ListPat ty pats) + = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack] +pprTypecheckedPat sty (TuplePat pats) + = ppBesides [ppLparen, interpp'SP sty pats, ppRparen] + +pprTypecheckedPat sty (LitPat l ty) = ppr sty l -- ToDo: print more +pprTypecheckedPat sty (NPat l ty e) = ppr sty l -- ToDo: print more + +pprTypecheckedPat sty (NPlusKPat n k ty e1 e2 e3) + = case sty of + PprForUser -> basic_ppr + _ -> ppHang basic_ppr 4 exprs_ppr + where + basic_ppr = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen] + exprs_ppr = ppSep [ ppBeside (ppStr "{- ") (ppr sty ty), + ppr sty e1, ppr sty e2, + ppBeside (ppr sty e3) (ppStr " -}")] +#ifdef DPH +pprTypecheckedPat sty (ProcessorPat pats convs pat) + = case sty of + PprForUser -> basic_ppr + _ -> ppHang basic_ppr 4 exprs_ppr + where + basic_ppr = ppBesides [ppStr "(|", interpp'SP sty pats,ppSemi , + ppr sty pat , ppStr "|)"] + exprs_ppr = ppBesides [ppStr "{- " , + ppr sty convs, + ppStr " -}"] +#endif {- Data Parallel Haskell -} + +pprConPatTy :: PprStyle -> UniType -> Pretty +pprConPatTy sty ty + = ppBesides [ppLparen, ppr sty ty, ppRparen] +\end{code} + +%************************************************************************ +%* * +%* predicates for checking things about pattern-lists in EquationInfo * +%* * +%************************************************************************ +\subsection[Pat-list-predicates]{Look for interesting things in patterns} + +Unlike in the Wadler chapter, where patterns are either ``variables'' +or ``constructors,'' here we distinguish between: +\begin{description} +\item[unfailable:] +Patterns that cannot fail to match: variables, wildcards, and lazy +patterns. + +These are the irrefutable patterns; the two other categories +are refutable patterns. + +\item[constructor:] +A non-literal constructor pattern (see next category). + +\item[literal (including n+k patterns):] +At least the numeric ones may be overloaded. +\end{description} + +A pattern is in {\em exactly one} of the above three categories; `as' +patterns are treated specially, of course. + +\begin{code} +unfailablePats :: [TypecheckedPat] -> Bool +unfailablePats pat_list = all unfailablePat pat_list + +unfailablePat (AsPat _ pat) = unfailablePat pat +unfailablePat (WildPat _) = True +unfailablePat (VarPat _) = True +unfailablePat (LazyPat _) = True +unfailablePat other = False + +patsAreAllCons :: [TypecheckedPat] -> Bool +patsAreAllCons pat_list = all isConPat pat_list + +isConPat (AsPat _ pat) = isConPat pat +isConPat (ConPat _ _ _) = True +isConPat (ConOpPat _ _ _ _) = True +isConPat (ListPat _ _) = True +isConPat (TuplePat _) = True +#ifdef DPH +isConPat (ProcessorPat _ _ _) = True + +#endif {- Data Parallel Haskell -} +isConPat other = False + +patsAreAllLits :: [TypecheckedPat] -> Bool +patsAreAllLits pat_list = all isLitPat pat_list + +isLitPat (AsPat _ pat) = isLitPat pat +isLitPat (LitPat _ _) = True +isLitPat (NPat _ _ _) = True +isLitPat (NPlusKPat _ _ _ _ _ _)= True +isLitPat other = False + +#ifdef DPH +patsAreAllProcessor :: [TypecheckedPat] -> Bool +patsAreAllProcessor pat_list = all isProcessorPat pat_list + where + isProcessorPat (ProcessorPat _ _ _) = True + isProcessorPat _ = False +#endif +\end{code} + +\begin{code} +-- A pattern is irrefutable if a match on it cannot fail +-- (at any depth) +irrefutablePat :: TypecheckedPat -> Bool + +irrefutablePat (WildPat _) = True +irrefutablePat (VarPat _) = True +irrefutablePat (LazyPat _) = True +irrefutablePat (AsPat _ pat) = irrefutablePat pat +irrefutablePat (ConPat con tys pats) = all irrefutablePat pats && only_con con +irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con +irrefutablePat (ListPat _ _) = False +irrefutablePat (TuplePat pats) = all irrefutablePat pats +irrefutablePat other_pat = False -- Literals, NPlusK, NPat + +only_con con = maybeToBool (maybeSingleConstructorTyCon tycon) + where + (_,_,_, tycon) = getDataConSig con +\end{code} diff --git a/ghc/compiler/abstractSyn/HsPragmas.hi b/ghc/compiler/abstractSyn/HsPragmas.hi new file mode 100644 index 0000000..12bd519 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsPragmas.hi @@ -0,0 +1,41 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsPragmas where +import HsCore(UnfoldingCoreExpr) +import HsDecls(ConDecl) +import HsTypes(MonoType) +import IdInfo(DeforestInfo, Demand, UpdateInfo) +import Maybes(Labda) +import Name(Name) +import Outputable(Outputable) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import SimplEnv(UnfoldingGuidance) +data ClassOpPragmas a = NoClassOpPragmas | ClassOpPragmas (GenPragmas a) (GenPragmas a) +data ClassPragmas a = NoClassPragmas | SuperDictPragmas [GenPragmas a] +data DataPragmas a = DataPragmas [ConDecl a] [[Labda (MonoType a)]] +data GenPragmas a = NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] +data ImpStrictness a = NoImpStrictness | ImpStrictness Bool [Demand] (GenPragmas a) +data ImpUnfolding a = NoImpUnfolding | ImpMagicUnfolding _PackedString | ImpUnfolding UnfoldingGuidance (UnfoldingCoreExpr a) +data InstancePragmas a = NoInstancePragmas | SimpleInstancePragma (GenPragmas a) | ConstantInstancePragma (GenPragmas a) [(a, GenPragmas a)] | SpecialisedInstancePragma (GenPragmas a) [([Labda (MonoType a)], Int, InstancePragmas a)] +type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName +type ProtoNameClassPragmas = ClassPragmas ProtoName +type ProtoNameDataPragmas = DataPragmas ProtoName +type ProtoNameGenPragmas = GenPragmas ProtoName +type ProtoNameInstancePragmas = InstancePragmas ProtoName +type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName +type RenamedClassOpPragmas = ClassOpPragmas Name +type RenamedClassPragmas = ClassPragmas Name +type RenamedDataPragmas = DataPragmas Name +type RenamedGenPragmas = GenPragmas Name +type RenamedImpStrictness = ImpStrictness Name +type RenamedInstancePragmas = InstancePragmas Name +data TypePragmas = NoTypePragmas | AbstractTySynonym +instance Outputable a => Outputable (ClassOpPragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (ClassPragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (GenPragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (InstancePragmas a) + {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsPragmas.lhs b/ghc/compiler/abstractSyn/HsPragmas.lhs new file mode 100644 index 0000000..6e9ec4e --- /dev/null +++ b/ghc/compiler/abstractSyn/HsPragmas.lhs @@ -0,0 +1,200 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +%************************************************************************ +%* * +\section[HsPragmas]{Pragmas in Haskell interface files} +%* * +%************************************************************************ + +See also: @Sig@ (``signatures'') which is where user-supplied pragmas +for values show up; ditto @SpecialisedInstanceSig@ (for instances) and +@DataTypeSig@ (for data types and type synonyms). + +\begin{code} +#include "HsVersions.h" + +module HsPragmas where + +import HsCore ( UnfoldingCoreExpr, UfCostCentre ) +import HsDecls ( ConDecl ) +import HsTypes ( MonoType, PolyType ) +import IdInfo +import Maybes ( Maybe(..) ) +import Name ( Name ) +import Outputable -- class for printing, forcing +import Pretty -- pretty-printing utilities +import ProtoName ( ProtoName(..) ) -- .. is for pragmas only +import Util +\end{code} + +Certain pragmas expect to be pinned onto certain constructs. + +Pragma types may be parameterised, just as with any other +abstract-syntax type. + +For a @data@ declaration---makes visible the constructors for an +abstract @data@ type and indicates which specialisations exist. +\begin{code} +data DataPragmas name + = DataPragmas [ConDecl name] -- hidden data constructors + [[Maybe (MonoType name)]] -- types to which speciaised + +type ProtoNameDataPragmas = DataPragmas ProtoName +type RenamedDataPragmas = DataPragmas Name +\end{code} + +For a @type@ declaration---declare that it should be treated as +``abstract'' (flag any use of its expansion as an error): +\begin{code} +data TypePragmas + = NoTypePragmas + | AbstractTySynonym +\end{code} + +These are {\em general} things you can know about any value: +\begin{code} +data GenPragmas name + = NoGenPragmas + | GenPragmas (Maybe Int) -- arity (maybe) + (Maybe UpdateInfo) -- update info (maybe) + DeforestInfo -- deforest info + (ImpStrictness name) -- strictness, worker-wrapper + (ImpUnfolding name) -- unfolding (maybe) + [([Maybe (MonoType name)], -- Specialisations: types to which spec'd; + Int, -- # dicts to ignore + GenPragmas name)] -- Gen info about the spec'd version + +type ProtoNameGenPragmas = GenPragmas ProtoName +type RenamedGenPragmas = GenPragmas Name + +data ImpUnfolding name + = NoImpUnfolding + | ImpMagicUnfolding FAST_STRING -- magic "unfolding" + -- known to the compiler by "String" + | ImpUnfolding UnfoldingGuidance -- always, if you like, etc. + (UnfoldingCoreExpr name) + +type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName + +data ImpStrictness name + = NoImpStrictness + | ImpStrictness Bool -- True <=> bottoming Id + [Demand] -- demand info + (GenPragmas name) -- about the *worker* + +type RenamedImpStrictness = ImpStrictness Name +\end{code} + +For an ordinary imported function: it can have general pragmas (only). + +For a class's super-class dictionary selectors: +\begin{code} +data ClassPragmas name + = NoClassPragmas + | SuperDictPragmas [GenPragmas name] -- list mustn't be empty + +type ProtoNameClassPragmas = ClassPragmas ProtoName +type RenamedClassPragmas = ClassPragmas Name +\end{code} + +For a class's method selectors: +\begin{code} +data ClassOpPragmas name + = NoClassOpPragmas + | ClassOpPragmas (GenPragmas name) -- for method selector + (GenPragmas name) -- for default method + +type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName +type RenamedClassOpPragmas = ClassOpPragmas Name +\end{code} + +\begin{code} +data InstancePragmas name + = NoInstancePragmas + + | SimpleInstancePragma -- nothing but for the dfun itself... + (GenPragmas name) + + | ConstantInstancePragma + (GenPragmas name) -- for the "dfun" itself + [(name, GenPragmas name)] -- one per class op + + | SpecialisedInstancePragma + (GenPragmas name) -- for its "dfun" + [([Maybe (MonoType name)], -- specialised instance; type... + Int, -- #dicts to ignore + InstancePragmas name)] -- (no SpecialisedInstancePragma please!) + +type ProtoNameInstancePragmas = InstancePragmas ProtoName +type RenamedInstancePragmas = InstancePragmas Name +\end{code} + +Some instances for printing (just for debugging, really) +\begin{code} +instance Outputable name => Outputable (ClassPragmas name) where + ppr sty NoClassPragmas = ppNil + ppr sty (SuperDictPragmas sdsel_prags) + = ppAbove (ppStr "{-superdict pragmas-}") + (ppr sty sdsel_prags) + +instance Outputable name => Outputable (ClassOpPragmas name) where + ppr sty NoClassOpPragmas = ppNil + ppr sty (ClassOpPragmas op_prags defm_prags) + = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags]) + (ppCat [ppStr "{-defm-}", ppr sty defm_prags]) + +instance Outputable name => Outputable (InstancePragmas name) where + ppr sty NoInstancePragmas = ppNil + ppr sty (SimpleInstancePragma dfun_pragmas) + = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas] + ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs) + = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas]) + (ppAboves (map pp_pair name_pragma_pairs)) + where + pp_pair (n, prags) + = ppCat [ppr sty n, ppEquals, ppr sty prags] + + ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) + = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas]) + (ppAboves (map pp_info spec_pragma_info)) + where + pp_info (ty_maybes, num_dicts, prags) + = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack, + ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags] + pp_ty Nothing = ppStr "_N_" + pp_ty (Just t)= ppr sty t + +instance Outputable name => Outputable (GenPragmas name) where + ppr sty NoGenPragmas = ppNil + ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs) + = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def? + pp_str strictness, pp_unf unfolding, + pp_specs specs] + where + pp_arity Nothing = ppNil + pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i) + + pp_upd Nothing = ppNil + pp_upd (Just u) = ppInfo sty id u + + pp_str NoImpStrictness = ppNil + pp_str (ImpStrictness is_bot demands wrkr_prags) + = ppBesides [ppStr "IS_BOT=", ppr sty is_bot, + ppStr "STRICTNESS=", ppStr (showList demands ""), + ppStr " {", ppr sty wrkr_prags, ppStr "}"] + + pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING" + pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m) + pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core) + + pp_specs [] = ppNil + pp_specs specs + = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"] + where + pp_spec (ty_maybes, num_dicts, gprags) + = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags] + + pp_MaB Nothing = ppStr "_N_" + pp_MaB (Just x) = ppr sty x +\end{code} diff --git a/ghc/compiler/abstractSyn/HsTypes.hi b/ghc/compiler/abstractSyn/HsTypes.hi new file mode 100644 index 0000000..51cad26 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsTypes.hi @@ -0,0 +1,33 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface HsTypes where +import Name(Name) +import Outputable(Outputable) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +type ClassAssertion a = (a, a) +type Context a = [(a, a)] +data MonoType a = MonoTyVar a | MonoTyCon a [MonoType a] | FunMonoTy (MonoType a) (MonoType a) | ListMonoTy (MonoType a) | TupleMonoTy [PolyType a] | MonoTyVarTemplate a | MonoDict a (MonoType a) +data PolyType a = UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) +type ProtoNameContext = [(ProtoName, ProtoName)] +type ProtoNameMonoType = MonoType ProtoName +type ProtoNamePolyType = PolyType ProtoName +type RenamedContext = [(Name, Name)] +type RenamedMonoType = MonoType Name +type RenamedPolyType = PolyType Name +cmpList :: (a -> a -> Int#) -> [a] -> [a] -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LSS" _N_ _N_ #-} +cmpMonoType :: (a -> a -> Int#) -> MonoType a -> MonoType a -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +cmpPolyType :: (a -> a -> Int#) -> PolyType a -> PolyType a -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +eqMonoType :: MonoType ProtoName -> MonoType ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +pprContext :: Outputable a => PprStyle -> [(a, a)] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-} +pprParendMonoType :: Outputable a => PprStyle -> MonoType a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 22122 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (MonoType a) + {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (PolyType a) + {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/HsTypes.lhs b/ghc/compiler/abstractSyn/HsTypes.lhs new file mode 100644 index 0000000..8ea7821 --- /dev/null +++ b/ghc/compiler/abstractSyn/HsTypes.lhs @@ -0,0 +1,273 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[HsTypes]{Abstract syntax: user-defined types} + +\begin{code} +#include "HsVersions.h" + +module HsTypes ( + PolyType(..), MonoType(..), + ClassAssertion(..), Context(..), + + ProtoNameContext(..), + ProtoNameMonoType(..), + ProtoNamePolyType(..), + RenamedContext(..), + RenamedMonoType(..), + RenamedPolyType(..), + + cmpPolyType, cmpMonoType, cmpList, + eqMonoType, + + pprContext, pprParendMonoType + + ) where + +import ProtoName +import Name ( Name ) +import Unique ( Unique ) +import Outputable +import Pretty +import Util +\end{code} + +This is the syntax for types as seen in type signatures. + +\begin{code} +data PolyType name + = UnoverloadedTy (MonoType name) -- equiv to having a [] context + + | OverloadedTy (Context name) -- not supposed to be [] + (MonoType name) + + -- this next one is only used in unfoldings in interfaces + | ForAllTy [name] + (MonoType name) + +type Context name = [ClassAssertion name] + +type ClassAssertion name = (name, name) + +type ProtoNamePolyType = PolyType ProtoName +type RenamedPolyType = PolyType Name + +type ProtoNameContext = Context ProtoName +type RenamedContext = Context Name + +data MonoType name + = MonoTyVar name -- Type variable + | MonoTyCon name -- Type constructor + [MonoType name] + | FunMonoTy (MonoType name) -- function type + (MonoType name) + | ListMonoTy (MonoType name) -- list type + | TupleMonoTy [PolyType name] -- tuple type (length gives arity) + -- *** NOTA BENE *** The tuple type takes *Poly*Type + -- arguments, because these *do* arise in pragmatic info + -- in interfaces (mostly to do with dictionaries). It just + -- so happens that this won't happen for lists, etc., + -- (as far as I know). + -- We might want to be less hacky about this in future. (ToDo) + -- [WDP] + + -- these next two are only used in unfoldings in interfaces + | MonoTyVarTemplate name + | MonoDict name -- Class + (MonoType name) + +#ifdef DPH + | MonoTyProc [MonoType name] + (MonoType name) -- Processor + | MonoTyPod (MonoType name) -- Pod +#endif {- Data Parallel Haskell -} + +type ProtoNameMonoType = MonoType ProtoName +type RenamedMonoType = MonoType Name +\end{code} + +We do define a specialised equality for these \tr{*Type} types; used +in checking interfaces. Most any other use is likely to be {\em +wrong}, so be careful! +\begin{code} +cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_ +cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_ +cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ +cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_ + +cmpPolyType cmp (UnoverloadedTy t1) (UnoverloadedTy t2) + = cmpMonoType cmp t1 t2 +cmpPolyType cmp (OverloadedTy c1 t1) (OverloadedTy c2 t2) + = case cmpContext cmp c1 c2 of { EQ_ -> cmpMonoType cmp t1 t2; xxx -> xxx } + +cmpPolyType cmp (ForAllTy tvs1 t1) (ForAllTy tvs2 t2) + = case cmp_tvs tvs1 tvs2 of { EQ_ -> cmpMonoType cmp t1 t2; xxx -> xxx } + where + cmp_tvs [] [] = EQ_ + cmp_tvs [] _ = LT_ + cmp_tvs _ [] = GT_ + cmp_tvs (a:as) (b:bs) + = case cmp a b of { EQ_ -> cmp_tvs as bs; xxx -> xxx } + cmp_tvs _ _ = case (panic "cmp_tvs") of { v -> cmp_tvs v v } -- BUG avoidance + +cmpPolyType cmp ty1 ty2 -- tags must be different + = let tag1 = tag ty1 + tag2 = tag ty2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag (UnoverloadedTy _) = (ILIT(1) :: FAST_INT) + tag (OverloadedTy _ _) = ILIT(2) + tag (ForAllTy _ _) = ILIT(3) + +----------- +cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2) + = cmp n1 n2 + +cmpMonoType cmp (TupleMonoTy tys1) (TupleMonoTy tys2) + = cmpList (cmpPolyType cmp) tys1 tys2 +cmpMonoType cmp (ListMonoTy ty1) (ListMonoTy ty2) + = cmpMonoType cmp ty1 ty2 + +cmpMonoType cmp (MonoTyCon tc1 tys1) (MonoTyCon tc2 tys2) + = case cmp tc1 tc2 of { EQ_ -> cmpList (cmpMonoType cmp) tys1 tys2; xxx -> xxx } + +cmpMonoType cmp (FunMonoTy a1 b1) (FunMonoTy a2 b2) + = case cmpMonoType cmp a1 a2 of { EQ_ -> cmpMonoType cmp b1 b2; xxx -> xxx } + +cmpMonoType cmp (MonoTyVarTemplate n1) (MonoTyVarTemplate n2) + = cmp n1 n2 +cmpMonoType cmp (MonoDict c1 ty1) (MonoDict c2 ty2) + = case cmp c1 c2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx } + +#ifdef DPH +cmpMonoType cmp (MonoTyProc tys1 ty1) (MonoTyProc tys2 ty2) + = case cmpList (cmpMonoType cmp) tys1 tys2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx } +cmpMonoType cmp (MonoTyPod ty1) (MonoTyPod ty2) = cmpMonoType cmp ty1 ty2 +#endif {- Data Parallel Haskell -} + +cmpMonoType cmp ty1 ty2 -- tags must be different + = let tag1 = tag ty1 + tag2 = tag ty2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) + tag (TupleMonoTy tys1) = ILIT(2) + tag (ListMonoTy ty1) = ILIT(3) + tag (MonoTyCon tc1 tys1) = ILIT(4) + tag (FunMonoTy a1 b1) = ILIT(5) + tag (MonoTyVarTemplate n1) = ILIT(6) + tag (MonoDict c1 ty1) = ILIT(7) +#ifdef DPH + tag (MonoTyProc tys1 ty1) = ILIT(8) + tag (MonoTyPod ty1) = ILIT(9) +#endif {- Data Parallel Haskell -} + +------------------- +cmpContext cmp a b + = cmpList cmp_ctxt a b + where + cmp_ctxt (c1, tv1) (c2, tv2) + = case cmp c1 c2 of { EQ_ -> cmp tv1 tv2; xxx -> xxx } + +------------------- +cmpList cmp [] [] = EQ_ +cmpList cmp [] _ = LT_ +cmpList cmp _ [] = GT_ +cmpList cmp (a:as) (b:bs) + = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx } + +cmpList cmp _ _ + = case (panic "cmpList (HsTypes)") of { l -> cmpList cmp l l } -- BUG avoidance +\end{code} + +\begin{code} +eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool + +eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False } +\end{code} + +This is used in various places: +\begin{code} +pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty + +pprContext sty [] = ppNil +pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"] +pprContext sty context + = ppBesides [ppLparen, + ppInterleave ppComma (map pp_assert context), + ppRparen, ppStr " =>"] + where + pp_assert (clas, ty) + = ppCat [ppr sty clas, ppr sty ty] +\end{code} + +\begin{code} +instance (Outputable name) => Outputable (PolyType name) where + ppr sty (UnoverloadedTy ty) = ppr sty ty + ppr sty (OverloadedTy ctxt ty) + = ppCat [pprContext sty ctxt, ppr sty ty] + ppr sty (ForAllTy tvs ty) + = ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => ", ppr sty ty] + +instance (Outputable name) => Outputable (MonoType name) where + ppr = pprMonoType + +pREC_TOP = (0 :: Int) +pREC_FUN = (1 :: Int) +pREC_CON = (2 :: Int) + +-- printing works more-or-less as for UniTypes (in UniTyFuns) + +pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty + +pprMonoType sty ty = ppr_mono_ty sty pREC_TOP ty +pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty + +ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name + +ppr_mono_ty sty ctxt_prec (FunMonoTy ty1 ty2) + = let p1 = ppr_mono_ty sty pREC_FUN ty1 + p2 = ppr_mono_ty sty pREC_TOP ty2 + in + if ctxt_prec < pREC_FUN then -- no parens needed + ppSep [p1, ppBeside (ppStr "-> ") p2] + else + ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]] + +ppr_mono_ty sty ctxt_prec (TupleMonoTy tys) + = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen] + +ppr_mono_ty sty ctxt_prec (ListMonoTy ty) + = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack] + +ppr_mono_ty sty ctxt_prec (MonoTyCon tycon tys) + = let pp_tycon = ppr sty tycon in + if null tys then + pp_tycon + else if ctxt_prec < pREC_CON then -- no parens needed + ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)] + else + ppBesides [ ppLparen, pp_tycon, ppSP, + ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ] + +-- unfoldings only +ppr_mono_ty sty ctxt_prec (MonoTyVarTemplate tv) = ppr sty tv + +ppr_mono_ty sty ctxt_prec (MonoDict clas ty) + = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"] + +#ifdef DPH +ppr_mono_ty sty ctxt_prec (MonoTyProc tys ty) + = ppBesides [ppStr "(|", + ppInterleave ppComma (map (ppr_mono_ty sty pREC_TOP) tys), + ppSemi, + ppr_mono_ty sty pREC_TOP ty, + ppStr "|)"] + +ppr_mono_ty sty ctxt_prec (MonoTyPod ty) + = ppBesides [ppStr "<<", ppr_mono_ty sty pREC_TOP ty ,ppStr ">>"] + +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/abstractSyn/Name.hi b/ghc/compiler/abstractSyn/Name.hi new file mode 100644 index 0000000..f292571 --- /dev/null +++ b/ghc/compiler/abstractSyn/Name.hi @@ -0,0 +1,66 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Name where +import Class(Class) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +cmpName :: Name -> Name -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqName :: Name -> Name -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +getTagFromClassOpName :: Name -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +invisibleName :: Name -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isClassName :: Name -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 14 \ (u0 :: Name) -> case u0 of { _ALG_ _ORIG_ Name PreludeClass (u1 :: Unique) (u2 :: FullName) -> _!_ True [] []; _ORIG_ Name OtherClass (u3 :: Unique) (u4 :: FullName) (u5 :: [Name]) -> _!_ True [] []; (u6 :: Name) -> _!_ False [] [] } _N_ #-} +isClassOpName :: Name -> Name -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +isTyConName :: Name -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 15 \ (u0 :: Name) -> case u0 of { _ALG_ _ORIG_ Name WiredInTyCon (u1 :: TyCon) -> _!_ True [] []; _ORIG_ Name PreludeTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: Bool) -> _!_ True [] []; _ORIG_ Name OtherTyCon (u6 :: Unique) (u7 :: FullName) (u8 :: Int) (u9 :: Bool) (ua :: [Name]) -> _!_ True [] []; (ub :: Name) -> _!_ False [] [] } _N_ #-} +isUnboundName :: Name -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 13 \ (u0 :: Name) -> case u0 of { _ALG_ _ORIG_ Name Unbound (u1 :: _PackedString) -> _!_ True [] []; (u2 :: Name) -> _!_ False [] [] } _N_ #-} +instance Eq Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Name -> Name -> Bool), (Name -> Name -> Bool)] [_CONSTM_ Eq (==) (Name), _CONSTM_ Eq (/=) (Name)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Ord Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Name}}, (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Name), (Name -> Name -> Name), (Name -> Name -> _CMP_TAG)] [_DFUN_ Eq (Name), _CONSTM_ Ord (<) (Name), _CONSTM_ Ord (<=) (Name), _CONSTM_ Ord (>=) (Name), _CONSTM_ Ord (>) (Name), _CONSTM_ Ord max (Name), _CONSTM_ Ord min (Name), _CONSTM_ Ord _tagCmp (Name)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance NamedThing Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Name -> ExportFlag), (Name -> Bool), (Name -> (_PackedString, _PackedString)), (Name -> _PackedString), (Name -> [_PackedString]), (Name -> SrcLoc), (Name -> Unique), (Name -> Bool), (Name -> UniType), (Name -> Bool)] [_CONSTM_ NamedThing getExportFlag (Name), _CONSTM_ NamedThing isLocallyDefined (Name), _CONSTM_ NamedThing getOrigName (Name), _CONSTM_ NamedThing getOccurrenceName (Name), _CONSTM_ NamedThing getInformingModules (Name), _CONSTM_ NamedThing getSrcLoc (Name), _CONSTM_ NamedThing getTheUnique (Name), _CONSTM_ NamedThing hasType (Name), _CONSTM_ NamedThing getType (Name), _CONSTM_ NamedThing fromPreludeCore (Name)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Name" ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Name) -> _!_ False [] [] _N_, + getType = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { UniType } [ _NOREP_S_ "NamedThing.Name.getType" ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance Outputable Name + {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Name) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/abstractSyn/Name.lhs b/ghc/compiler/abstractSyn/Name.lhs new file mode 100644 index 0000000..b8be5aa --- /dev/null +++ b/ghc/compiler/abstractSyn/Name.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Name]{@Name@: to transmit name info from renamer to typechecker} + +\begin{code} +#include "HsVersions.h" + +module Name ( + -- things for the Name NON-abstract type + Name(..), + + isTyConName, isClassName, isClassOpName, + getTagFromClassOpName, isUnboundName, + invisibleName, + eqName, cmpName, + + -- to make the interface self-sufficient + Id, FullName, ShortName, TyCon, Unique +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +import AbsUniType ( cmpTyCon, TyCon, Class, ClassOp, Arity(..) + IF_ATTACK_PRAGMAS(COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Id ( cmpId, Id ) +import NameTypes -- all of them +import Outputable +import Pretty +import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) +import Unique ( eqUnique, cmpUnique, pprUnique, Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Name-datatype]{The @Name@ datatype} +%* * +%************************************************************************ + +\begin{code} +data Name + = Short Unique -- Local ids and type variables + ShortName + + -- Nano-prelude things; truly wired in. + -- Includes all type constructors and their associated data constructors + | WiredInTyCon TyCon + | WiredInVal Id + + -- Prelude things not actually wired into the compiler, but important + -- enough to get their own special lookup key (a magic Unique). + | PreludeVal Unique{-IdKey-} FullName + | PreludeTyCon Unique{-TyConKey-} FullName Arity Bool -- as for OtherTyCon + | PreludeClass Unique{-ClassKey-} FullName + + | OtherTyCon Unique -- TyCons other than Prelude ones; need to + FullName -- separate these because we want to pin on + Arity -- their arity. + Bool -- True <=> `data', False <=> `type' + [Name] -- List of user-visible data constructors; + -- NB: for `data' types only. + -- Used in checking import/export lists. + + | OtherClass Unique + FullName + [Name] -- List of class methods; used for checking + -- import/export lists. + + | OtherTopId Unique -- Top level id + FullName + + | ClassOpName Unique + Name -- Name associated w/ the defined class + -- (can get unique and export info, etc., from this) + FAST_STRING -- The class operation + Int -- Unique tag within the class + + -- Miscellaneous + | Unbound FAST_STRING -- Placeholder for a name which isn't in scope + -- Used only so that the renamer can carry on after + -- finding an unbound identifier. + -- The string is grabbed from the unbound name, for + -- debugging information only. +\end{code} + +These @is..@ functions are used in the renamer to check that (eg) a tycon +is seen in a context which demands one. + +\begin{code} +isTyConName, isClassName, isUnboundName :: Name -> Bool + +isTyConName (WiredInTyCon _) = True +isTyConName (PreludeTyCon _ _ _ _) = True +isTyConName (OtherTyCon _ _ _ _ _) = True +isTyConName other = False + +isClassName (PreludeClass _ _) = True +isClassName (OtherClass _ _ _) = True +isClassName other = False + +isUnboundName (Unbound _) = True +isUnboundName other = False +\end{code} + +@isClassOpName@ is a little cleverer: it checks to see whether the +class op comes from the correct class. + +\begin{code} +isClassOpName :: Name -- The name of the class expected for this op + -> Name -- The name of the thing which should be a class op + -> Bool + +isClassOpName (PreludeClass key1 _) (ClassOpName _ (PreludeClass key2 _) _ _) + = key1 == key2 +isClassOpName (OtherClass uniq1 _ _) (ClassOpName _ (OtherClass uniq2 _ _) _ _) + = eqUnique uniq1 uniq2 +isClassOpName other_class other_op = False +\end{code} + +A Name is ``invisible'' if the user has no business seeing it; e.g., a +data-constructor for an abstract data type (but whose constructors are +known because of a pragma). +\begin{code} +invisibleName :: Name -> Bool + +invisibleName (PreludeVal _ n) = invisibleFullName n +invisibleName (PreludeTyCon _ n _ _) = invisibleFullName n +invisibleName (PreludeClass _ n) = invisibleFullName n +invisibleName (OtherTyCon _ n _ _ _) = invisibleFullName n +invisibleName (OtherClass _ n _) = invisibleFullName n +invisibleName (OtherTopId _ n) = invisibleFullName n +invisibleName _ = False +\end{code} + +\begin{code} +getTagFromClassOpName :: Name -> Int + +getTagFromClassOpName (ClassOpName _ _ _ tag) = tag +\end{code} + + +%************************************************************************ +%* * +\subsection[Name-instances]{Instance declarations} +%* * +%************************************************************************ + +\begin{code} +cmpName n1 n2 = cmp n1 n2 + where + cmp (Short u1 _) (Short u2 _) = cmpUnique u1 u2 + + cmp (WiredInTyCon tc1) (WiredInTyCon tc2) = cmpTyCon tc1 tc2 + cmp (WiredInVal id1) (WiredInVal id2) = cmpId id1 id2 + + cmp (PreludeVal k1 _) (PreludeVal k2 _) = cmpUnique k1 k2 + cmp (PreludeTyCon k1 _ _ _) (PreludeTyCon k2 _ _ _) = cmpUnique k1 k2 + cmp (PreludeClass k1 _) (PreludeClass k2 _) = cmpUnique k1 k2 + + cmp (OtherTyCon u1 _ _ _ _) (OtherTyCon u2 _ _ _ _) = cmpUnique u1 u2 + cmp (OtherClass u1 _ _) (OtherClass u2 _ _) = cmpUnique u1 u2 + cmp (OtherTopId u1 _) (OtherTopId u2 _) = cmpUnique u1 u2 + + cmp (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmpUnique u1 u2 +#if 0 + -- panic won't unify w/ CMP_TAG (Int#) + cmp (Unbound a) (Unbound b) = panic "Eq.Name.Unbound" +#endif + + cmp other_1 other_2 -- the tags *must* be different + = let tag1 = tag_Name n1 + tag2 = tag_Name n2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + + tag_Name (Short _ _) = (ILIT(1) :: FAST_INT) + tag_Name (WiredInTyCon _) = ILIT(2) + tag_Name (WiredInVal _) = ILIT(3) + tag_Name (PreludeVal _ _) = ILIT(4) + tag_Name (PreludeTyCon _ _ _ _) = ILIT(5) + tag_Name (PreludeClass _ _) = ILIT(6) + tag_Name (OtherTyCon _ _ _ _ _) = ILIT(7) + tag_Name (OtherClass _ _ _) = ILIT(8) + tag_Name (OtherTopId _ _) = ILIT(9) + tag_Name (ClassOpName _ _ _ _) = ILIT(10) + tag_Name (Unbound _) = ILIT(11) +\end{code} + +\begin{code} +eqName a b = case cmpName a b of { EQ_ -> True; _ -> False } +gtName a b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True } + +instance Eq Name where + a == b = case cmpName a b of { EQ_ -> True; _ -> False } + a /= b = case cmpName a b of { EQ_ -> False; _ -> True } + +instance Ord Name where + a <= b = case cmpName a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmpName a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmpName a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpName a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +\begin{code} +instance NamedThing Name where + getExportFlag (Short _ _) = NotExported + getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these + getExportFlag (WiredInVal _) = NotExported + getExportFlag (ClassOpName _ c _ _) = getExportFlag c + getExportFlag other = getExportFlag (get_nm "getExportFlag" other) + + isLocallyDefined (Short _ _) = True + isLocallyDefined (WiredInTyCon _) = False + isLocallyDefined (WiredInVal _) = False + isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c + isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other) + + getOrigName (Short _ sn) = getOrigName sn + getOrigName (WiredInTyCon tc) = getOrigName tc + getOrigName (WiredInVal id) = getOrigName id + getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op) + getOrigName other = getOrigName (get_nm "getOrigName" other) + + getOccurrenceName (Short _ sn) = getOccurrenceName sn + getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc + getOccurrenceName (WiredInVal id) = getOccurrenceName id + getOccurrenceName (ClassOpName _ _ op _) = op + getOccurrenceName (Unbound s) = s _APPEND_ SLIT("") + getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other) + + getInformingModules thing = panic "getInformingModule:Name" + + getSrcLoc (Short _ sn) = getSrcLoc sn + getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc + getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc + getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c + getSrcLoc (Unbound _) = mkUnknownSrcLoc + getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other) + + getTheUnique (Short uniq _) = uniq + getTheUnique (OtherTopId uniq _) = uniq + getTheUnique other + = pprPanic "NamedThing.Name.getTheUnique: not a Short or OtherTopId:" (ppr PprShowAll other) + + fromPreludeCore (WiredInTyCon _) = True + fromPreludeCore (WiredInVal _) = True + fromPreludeCore (PreludeVal _ n) = fromPreludeCore n + fromPreludeCore (PreludeTyCon _ n _ _) = fromPreludeCore n + fromPreludeCore (PreludeClass _ n) = fromPreludeCore n + fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c + fromPreludeCore other = False + + hasType n = False + getType n = panic "NamedThing.Name.getType" +\end{code} + +A useful utility; most emphatically not for export!: +\begin{code} +get_nm :: String -> Name -> FullName + +get_nm msg (PreludeVal _ n) = n +get_nm msg (PreludeTyCon _ n _ _) = n +get_nm msg (OtherTyCon _ n _ _ _) = n +get_nm msg (PreludeClass _ n) = n +get_nm msg (OtherClass _ n _) = n +get_nm msg (OtherTopId _ n) = n +#ifdef DEBUG +get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other) +-- If match failure, probably on a ClassOpName or Unbound :-( +#endif +\end{code} + +\begin{code} +instance Outputable Name where +#ifdef DEBUG + ppr PprDebug (Short u s) = pp_debug u s + ppr PprDebug (PreludeVal u i) = pp_debug u i + ppr PprDebug (PreludeTyCon u t _ _) = pp_debug u t + ppr PprDebug (PreludeClass u c) = pp_debug u c + + ppr PprDebug (OtherTyCon u n _ _ _) = pp_debug u n + ppr PprDebug (OtherClass u n _) = pp_debug u n + ppr PprDebug (OtherTopId u n) = pp_debug u n +#endif + ppr sty (Short u s) = ppr sty s + + ppr sty (WiredInTyCon tc) = ppr sty tc + ppr sty (WiredInVal id) = ppr sty id + ppr sty (PreludeVal _ i) = ppr sty i + ppr sty (PreludeTyCon _ t _ _) = ppr sty t + ppr sty (PreludeClass _ c) = ppr sty c + + ppr sty (OtherTyCon u n a b c) = ppr sty n + ppr sty (OtherClass u n c) = ppr sty n + ppr sty (OtherTopId u n) = ppr sty n + + ppr sty (ClassOpName u c s i) + = case sty of + PprForUser -> ppPStr s + PprInterface _ -> ppPStr s + other -> ppBesides [ppPStr s, ppChar '{', + ppSep [pprUnique u, + ppStr "op", ppInt i, + ppStr "cls", ppr sty c], + ppChar '}'] + + ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s) + +pp_debug uniq thing + = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ] +\end{code} diff --git a/ghc/compiler/basicTypes/BasicLit.hi b/ghc/compiler/basicTypes/BasicLit.hi new file mode 100644 index 0000000..4b9fdbb --- /dev/null +++ b/ghc/compiler/basicTypes/BasicLit.hi @@ -0,0 +1,45 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface BasicLit where +import Class(Class) +import Outputable(Outputable) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +isLitLitLit :: BasicLit -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit MachLitLit (u1 :: _PackedString) (u2 :: PrimKind) -> _!_ True [] []; (u3 :: BasicLit) -> _!_ False [] [] } _N_ #-} +isNoRepLit :: BasicLit -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 14 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit NoRepStr (u1 :: _PackedString) -> _!_ True [] []; _ORIG_ BasicLit NoRepInteger (u2 :: Integer) -> _!_ True [] []; _ORIG_ BasicLit NoRepRational (u3 :: Ratio Integer) -> _!_ True [] []; (u4 :: BasicLit) -> _!_ False [] [] } _N_ #-} +kindOfBasicLit :: BasicLit -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkMachInt :: Integer -> BasicLit + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkMachWord :: Integer -> BasicLit + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +showBasicLit :: PprStyle -> BasicLit -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +typeOfBasicLit :: BasicLit -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance Eq BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_ + ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/BasicLit.lhs b/ghc/compiler/basicTypes/BasicLit.lhs new file mode 100644 index 0000000..d3dbb89 --- /dev/null +++ b/ghc/compiler/basicTypes/BasicLit.lhs @@ -0,0 +1,197 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[BasicLit]{@BasicLit@: Machine literals (unboxed, of course)} + +\begin{code} +#include "HsVersions.h" + +module BasicLit ( + BasicLit(..), + mkMachInt, mkMachWord, + typeOfBasicLit, kindOfBasicLit, + showBasicLit, + isNoRepLit, isLitLitLit, + + -- and to make the interface self-sufficient.... + UniType, PrimKind + ) where + +import AbsPrel ( addrPrimTy, intPrimTy, floatPrimTy, doublePrimTy, + charPrimTy, wordPrimTy, + integerTy, rationalTy, stringTy, UniType, + TauType(..) + IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( TyCon IF_ATTACK_PRAGMAS(COMMA cmpTyCon) ) +import PrimKind ( getKindInfo ) -- ToDo: *** HACK import **** +import CLabelInfo ( stringToC, charToC, charToEasyHaskell ) +import Outputable -- class for printing, forcing +import Pretty -- pretty-printing stuff +import PrimKind ( PrimKind(..) ) +import Util +\end{code} + +So-called @BasicLits@ are {\em either}: +\begin{itemize} +\item +An unboxed (``machine'') literal (type: @IntPrim@, @FloatPrim@, etc.), +which is presumed to be surrounded by appropriate constructors +(@mKINT@, etc.), so that the overall thing makes sense. +\item +An Integer, Rational, or String literal whose representation we are +{\em uncommitted} about; i.e., the surrounding with constructors, +function applications, etc., etc., has not yet been done. +\end{itemize} + +\begin{code} +data BasicLit + = MachChar Char + | MachStr FAST_STRING + | MachAddr Integer -- whatever this machine thinks is a "pointer" + | MachInt Integer -- for the numeric types, these are + Bool -- True <=> signed (Int#); False <=> unsigned (Word#) + | MachFloat Rational + | MachDouble Rational + | MachLitLit FAST_STRING + PrimKind + + | NoRepStr FAST_STRING -- the uncommitted ones + | NoRepInteger Integer + | NoRepRational Rational + + deriving (Eq, Ord) + -- The Ord is needed for the FiniteMap used in the lookForConstructor + -- in SimplEnv. If you declared that lookForConstructor *ignores* + -- constructor-applications with CoLitAtom args, then you could get + -- rid of this Ord. + +mkMachInt, mkMachWord :: Integer -> BasicLit + +mkMachInt x = MachInt x True{-signed-} +mkMachWord x = MachInt x False{-unsigned-} +\end{code} + +\begin{code} +isNoRepLit (NoRepStr _) = True -- these are not primitive typed! +isNoRepLit (NoRepInteger _) = True +isNoRepLit (NoRepRational _) = True +isNoRepLit _ = False + +isLitLitLit (MachLitLit _ _) = True +isLitLitLit _ = False +\end{code} + +\begin{code} +typeOfBasicLit :: BasicLit -> UniType + +typeOfBasicLit (MachChar _) = charPrimTy +typeOfBasicLit (MachStr _) = addrPrimTy +typeOfBasicLit (MachAddr _) = addrPrimTy +typeOfBasicLit (MachInt _ signed) = if signed then intPrimTy else wordPrimTy +typeOfBasicLit (MachFloat _) = floatPrimTy +typeOfBasicLit (MachDouble _) = doublePrimTy +typeOfBasicLit (MachLitLit _ k) = case (getKindInfo k) of { (_,t,_) -> t } +typeOfBasicLit (NoRepInteger _) = integerTy +typeOfBasicLit (NoRepRational _)= rationalTy +typeOfBasicLit (NoRepStr _) = stringTy +\end{code} + +\begin{code} +kindOfBasicLit :: BasicLit -> PrimKind + +kindOfBasicLit (MachChar _) = CharKind +kindOfBasicLit (MachStr _) = AddrKind -- specifically: "char *" +kindOfBasicLit (MachAddr _) = AddrKind +kindOfBasicLit (MachInt _ signed) = if signed then IntKind else WordKind +kindOfBasicLit (MachFloat _) = FloatKind +kindOfBasicLit (MachDouble _) = DoubleKind +kindOfBasicLit (MachLitLit _ k) = k +kindOfBasicLit (NoRepInteger _) = panic "kindOfBasicLit:NoRepInteger" +kindOfBasicLit (NoRepRational _)= panic "kindOfBasicLit:NoRepRational" +kindOfBasicLit (NoRepStr _) = panic "kindOfBasicLit:NoRepString" +\end{code} + +The boring old output stuff: +\begin{code} +ppCast :: PprStyle -> FAST_STRING -> Pretty +ppCast (PprForC _) cast = ppPStr cast +ppCast _ _ = ppNil + +instance Outputable BasicLit where + ppr sty (MachChar ch) + = let + char_encoding + = case sty of + PprForC _ -> charToC ch + PprForAsm _ _ _ -> charToC ch + PprUnfolding _ -> charToEasyHaskell ch + _ -> [ch] + in + ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']) + (if_ubxd sty) + + ppr sty (MachStr s) + = ppBeside (if codeStyle sty + then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"'] + else ppStr (show (_UNPK_ s))) + (if_ubxd sty) + + ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty] + ppr sty (MachInt i signed) + | codeStyle sty + && ((signed && (i >= toInteger minInt && i <= toInteger maxInt)) + || (not signed && (i >= toInteger 0 && i <= toInteger maxInt))) + -- ToDo: Think about these ranges! + = ppBesides [ppInteger i, if_ubxd sty] + + | not (codeStyle sty) -- we'd prefer the code to the error message + = ppBesides [ppInteger i, if_ubxd sty] + + | otherwise + = error ("ERROR: Int " ++ show i ++ " out of range [" ++ + show range_min ++ " .. " ++ show maxInt ++ "]\n") + where + range_min = if signed then minInt else 0 + + ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty] + ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty] + +#ifdef DPH + -- I know that this thing shouldnt pop out of the compiler, but the + -- native code generator tries to generate code to initilialise a closure + -- with this value... (in glaExts/PreludeGlaInOut.lhs) + ppr sty MachVoid = ppStr "0 ! {- void# -}" +#endif {- Data Parallel Haskell -} + + ppr sty (NoRepInteger i) + | codeStyle sty = ppInteger i + | ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i] + | otherwise = ppBesides [ppInteger i, ppChar 'I'] + + ppr sty (NoRepRational r) + | ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)] + | codeStyle sty = panic "ppr.ForC.NoRepRational" + | otherwise = ppBesides [ppRational r, ppChar 'R'] + + ppr sty (NoRepStr s) + | codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))] + | ufStyle sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))] + | otherwise = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S'] + + ppr sty (MachLitLit s k) + | codeStyle sty = ppPStr s + | ufStyle sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k] + | otherwise = ppBesides [ppStr "``", ppPStr s, ppStr "''"] + +ufStyle (PprUnfolding _) = True +ufStyle _ = False + +if_ubxd sty = if codeStyle sty then ppNil else ppChar '#' + +showBasicLit :: PprStyle -> BasicLit -> String + +showBasicLit sty lit = ppShow 80 (ppr sty lit) +\end{code} diff --git a/ghc/compiler/basicTypes/CLabelInfo.hi b/ghc/compiler/basicTypes/CLabelInfo.hi new file mode 100644 index 0000000..748ab69 --- /dev/null +++ b/ghc/compiler/basicTypes/CLabelInfo.hi @@ -0,0 +1,99 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CLabelInfo where +import CharSeq(CSeq) +import Class(Class) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import PrimKind(PrimKind) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data CLabel +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +cSEP :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charToC :: Char -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +charToEasyHaskell :: Char -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +externallyVisibleCLabel :: CLabel -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +identToC :: _PackedString -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +isAsmTemp :: CLabel -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isReadOnly :: CLabel -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkAltLabel :: Unique -> Int -> CLabel + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkAsmTempLabel :: Unique -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkBlackHoleInfoTableLabel :: CLabel + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkClosureLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkConEntryLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkConUpdCodePtrVecLabel :: TyCon -> Int -> CLabel + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkDefaultLabel :: Unique -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkErrorStdEntryLabel :: CLabel + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkFastEntryLabel :: Id -> Int -> CLabel + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkInfoTableLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkInfoTableVecTblLabel :: TyCon -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkPhantomInfoTableLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkRednCountsLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkReturnPtLabel :: Unique -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStaticConEntryLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStaticInfoTableLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStdEntryLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStdUpdCodePtrVecLabel :: TyCon -> Int -> CLabel + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkStdUpdVecTblLabel :: TyCon -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkVapEntryLabel :: Id -> Bool -> CLabel + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkVapInfoTableLabel :: Id -> Bool -> CLabel + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkVecTblLabel :: Unique -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +modnameToC :: _PackedString -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +needsCDecl :: CLabel -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pprCLabel :: PprStyle -> CLabel -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +stringToC :: [Char] -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance Eq CLabel + {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool)] [_CONSTM_ Eq (==) (CLabel), _CONSTM_ Eq (/=) (CLabel)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord CLabel + {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq CLabel}}, (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> _CMP_TAG)] [_DFUN_ Eq (CLabel), _CONSTM_ Ord (<) (CLabel), _CONSTM_ Ord (<=) (CLabel), _CONSTM_ Ord (>=) (CLabel), _CONSTM_ Ord (>) (CLabel), _CONSTM_ Ord max (CLabel), _CONSTM_ Ord min (CLabel), _CONSTM_ Ord _tagCmp (CLabel)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/CLabelInfo.lhs b/ghc/compiler/basicTypes/CLabelInfo.lhs new file mode 100644 index 0000000..0e490e2 --- /dev/null +++ b/ghc/compiler/basicTypes/CLabelInfo.lhs @@ -0,0 +1,650 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CLabelInfo]{@CLabelInfo@: Information to make C Labels} + +\begin{code} +#include "HsVersions.h" + +module CLabelInfo ( + CLabel, -- abstract type + + mkClosureLabel, + mkInfoTableLabel, + mkStdEntryLabel, + mkFastEntryLabel, + mkConEntryLabel, + mkStaticConEntryLabel, + mkRednCountsLabel, + mkPhantomInfoTableLabel, + mkStaticInfoTableLabel, + mkVapEntryLabel, + mkVapInfoTableLabel, + +--UNUSED: mkConUpdCodePtrUnvecLabel, + mkConUpdCodePtrVecLabel, + mkStdUpdCodePtrVecLabel, + + mkInfoTableVecTblLabel, + mkStdUpdVecTblLabel, + + mkReturnPtLabel, + mkVecTblLabel, + mkAltLabel, + mkDefaultLabel, + + mkAsmTempLabel, + + mkErrorStdEntryLabel, + mkBlackHoleInfoTableLabel, +--UNUSED: mkSelectorInfoTableLabel, +--UNUSED: mkSelectorEntryLabel, + +#ifdef DPH + mkLocalLabel, isLocalLabel, isNestableBlockLabel, + isGlobalDataLabel, isDataLabel, + needsApalDecl, isVectorTableLabel, isSlowFastLabelPair, +#endif {- Data Parallel Haskell -} + + needsCDecl, isReadOnly, isAsmTemp, externallyVisibleCLabel, + + cSEP, identToC, modnameToC, stringToC, charToC, charToEasyHaskell, + pprCLabel, + +#ifdef GRAN + isSlowEntryCCodeBlock, +#endif + + -- and to make the interface self-sufficient... + Id, TyCon, Unique + ) where + +import AbsUniType ( showTyCon, cmpTyCon, isBigTupleTyCon, + TyCon, Unique + ) +import Id ( externallyVisibleId, cmpId_withSpecDataCon, + DataCon(..), Id, fIRST_TAG, ConTag(..) +#ifdef DPH + ,isInventedTopLevId +#endif {- Data Parallel Haskell -} + ) +import Outputable +import Pretty ( ppNil, ppChar, ppStr, ppPStr, ppDouble, ppInt, + ppInteger, ppBeside, ppIntersperse, prettyToUn + ) +#ifdef USE_ATTACK_PRAGMAS +import CharSeq +#endif +import Unpretty -- NOTE!! ******************** +import Unique ( cmpUnique, showUnique, pprUnique, Unique ) +import Util + +#ifdef DPH +import AbsCSyn ( MagicId ) +import PprAbsC ( pprMagicId ) +#endif {- Data Parallel Haskell -} + +-- Sigh... Shouldn't this file (CLabelInfo) live in codeGen? +import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) + +\end{code} + +things we want to find out: + +* should the labelled things be declared "static" (visible only in this file)? + +* should it be declared "const" (read-only text space)? + +* does it need declarations at all? (v common Prelude things are pre-declared) + +\begin{code} +data CLabel + = IdLabel -- A family of labels related to the + CLabelId -- definition of a particular Id + IdLabelInfo -- Includes DataCon + + | TyConLabel -- A family of labels related to the + TyCon -- definition of a data type + TyConLabelInfo + + | CaseLabel -- A family of labels related to a particular case expression + Unique -- Unique says which case expression + CaseLabelInfo + + | AsmTempLabel Unique + + | RtsLabel RtsLabelInfo + +#ifdef DPH + | ALocalLabel Unique -- Label within a code block. + String +#endif {- Data Parallel Haskell -} + deriving (Eq, Ord) +\end{code} + +The CLabelId is simply so we can declare alternative Eq and Ord +instances which use cmpId_SpecDataCon (instead of cmpId). This avoids +comparing the Uniques of two specialised data constructors (which have +the same as the uniques their respective unspecialised data +constructors). Instead, the specialising types and the uniques of the +unspecialised constructors are compared. + +\begin{code} +data CLabelId = CLabelId Id + +instance Eq CLabelId where + CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False } + CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True } + +instance Ord CLabelId where + CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b + of { LT_ -> True; EQ_ -> True; GT__ -> False } + CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b + of { LT_ -> True; EQ_ -> False; GT__ -> False } + CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b + of { LT_ -> False; EQ_ -> True; GT__ -> True } + CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b + of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b + of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +\begin{code} +data IdLabelInfo + = Closure -- Label for (static???) closure + + | InfoTbl -- Info table for a closure; always read-only + + | EntryStd -- Thunk, or "slow", code entry point (requires arg satis check) + | EntryFast Int -- entry pt when no arg satisfaction chk needed; + -- Int is the arity of the function (to be + -- encoded into the name) + + | ConEntry -- the only kind of entry pt for constructors + | StaticConEntry -- static constructor entry point + + | StaticInfoTbl -- corresponding info table + + | PhantomInfoTbl -- for phantom constructors that only exist in regs + + | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version + | VapEntry Bool + + -- Ticky-ticky counting + | RednCounts -- Label of place to keep reduction-count info for this Id + deriving (Eq, Ord) + + +data TyConLabelInfo + = UnvecConUpdCode -- Update code for the data type if it's unvectored + + | VecConUpdCode ConTag -- One for each constructor which returns in + -- regs; this code actually performs an update + + | StdUpdCode ConTag -- Update code for all constructors which return + -- in heap. There are a small number of variants, + -- so that the update code returns (vectored/n or + -- unvectored) in the right way. + -- ToDo: maybe replace TyCon/Int with return conv. + + | InfoTblVecTbl -- For tables of info tables + + | StdUpdVecTbl -- Labels the update code, or table of update codes, + -- for a particular type. + deriving (Eq, Ord) + +data CaseLabelInfo + = CaseReturnPt + | CaseVecTbl + | CaseAlt ConTag + | CaseDefault + deriving (Eq, Ord) + +data RtsLabelInfo + = RtsShouldNeverHappenCode + + | RtsBlackHoleInfoTbl + + | RtsSelectorInfoTbl -- Selectors + Bool -- True <=> the update-reqd version; + -- False <=> the no-update-reqd version + Int -- 0-indexed Offset from the "goods" + + | RtsSelectorEntry -- Ditto entry code + Bool + Int + deriving (Eq, Ord) +\end{code} + +\begin{code} +mkClosureLabel id = IdLabel (CLabelId id) Closure +mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl +mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd +mkFastEntryLabel id arity = --false:ASSERT(arity > 0) + IdLabel (CLabelId id) (EntryFast arity) +mkConEntryLabel id = IdLabel (CLabelId id) ConEntry +mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry +mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts +mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl +mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl +mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag) +mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag) + +--UNUSED:mkConUpdCodePtrUnvecLabel tycon = TyConLabel tycon UnvecConUpdCode +mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag) +mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag) + +mkInfoTableVecTblLabel tycon = TyConLabel tycon InfoTblVecTbl +mkStdUpdVecTblLabel tycon = TyConLabel tycon StdUpdVecTbl + +mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt +mkVecTblLabel uniq = CaseLabel uniq CaseVecTbl +mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) +mkDefaultLabel uniq = CaseLabel uniq CaseDefault + +mkAsmTempLabel = AsmTempLabel + + -- Some fixed runtime system labels + +mkErrorStdEntryLabel = RtsLabel RtsShouldNeverHappenCode +mkBlackHoleInfoTableLabel = RtsLabel RtsBlackHoleInfoTbl +--UNUSED:mkSelectorInfoTableLabel upd_reqd offset = RtsLabel (RtsSelectorInfoTbl upd_reqd offset) +--UNUSED: mkSelectorEntryLabel upd_reqd offset = RtsLabel (RtsSelectorEntry upd_reqd offset) + +#ifdef DPH +mkLocalLabel = ALocalLabel +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +needsCDecl :: CLabel -> Bool -- False <=> it's pre-declared; don't bother +isReadOnly :: CLabel -> Bool -- lives in C "text space" +isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation +externallyVisibleCLabel :: CLabel -> Bool -- not C "static" +\end{code} + +@needsCDecl@ is @True@ unless the thing is a deeply-@PreludeCore@-ish +object. {\em Also:} No need to spit out labels for things generated +by the flattener (in @AbsCFuns@)---it is careful to ensure references +to them are always backwards. These are return-point and vector-table +labels. + +Declarations for (non-prelude) @Id@-based things are needed because of +mutual recursion. +\begin{code} +needsCDecl (IdLabel _ _) = True -- OLD: not (fromPreludeCore id) +needsCDecl (CaseLabel _ _) = False + +needsCDecl (TyConLabel _ (StdUpdCode _)) = False +needsCDecl (TyConLabel _ InfoTblVecTbl) = False +needsCDecl (TyConLabel _ other) = True + +needsCDecl (AsmTempLabel _) = False +needsCDecl (RtsLabel _) = False + +#ifdef DPH +needsCDecl (ALocalLabel _ _) = panic "needsCDecl: Shouldn't call" +#endif {- Data Parallel Haskell -} + +needsCDecl other = True +\end{code} + +Whether the labelled thing can be put in C "text space": +\begin{code} +isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes +isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other +isReadOnly (IdLabel _ PhantomInfoTbl) = True +isReadOnly (IdLabel _ (VapInfoTbl _)) = True +isReadOnly (IdLabel _ other) = False -- others: pessimistically, no + +isReadOnly (TyConLabel _ _) = True +isReadOnly (CaseLabel _ _) = True +isReadOnly (AsmTempLabel _) = True +isReadOnly (RtsLabel _) = True + +#ifdef DPH +isReadOnly (ALocalLabel _ _) = panic "isReadOnly: Shouldn't call" +#endif {- Data Parallel Haskell -} +\end{code} + +Whether the label is an assembler temporary: +\begin{code} +isAsmTemp (AsmTempLabel _) = True +isAsmTemp _ = False +\end{code} + +C ``static'' or not... +\begin{code} +externallyVisibleCLabel (TyConLabel tc _) = not (isBigTupleTyCon tc) + -- i.e. not generated for + -- purely-local use... +externallyVisibleCLabel (CaseLabel _ _) = False +externallyVisibleCLabel (AsmTempLabel _) = False +externallyVisibleCLabel (RtsLabel _) = True + +#ifndef DPH + +externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id + +#else +-- DPH pays a big price for exported identifiers. For example with +-- a statically allocated closure, if it is local to a file it will +-- only take up 1 word of storage; exported closures have to go +-- in a data section of their own, which gets padded out to a plane size--- +-- on the DAP510 this is 32 words, DAP610 128 words, DAP710 512 words :-( +-- NOTE:16/07/93 Used isInvented (these worker things are globally visible). +-- Local labels (i.e ones within a code block) are not visible outside +-- a file. + +externallyVisibleCLabel (IdLabel (CLabelId id) _) = isInventedTopLevId id || isExported id +externallyVisibleCLabel (ALocalLabel _ _) = False +#endif {- Data Parallel Haskell -} +\end{code} + +@isLocalLabel@ determines if a label is local to a block---a different +machine code jump is generated. + +Note(hack after 0.16): Blocks with direct entry points can appear + within blocks labelled with a direct entry + point --- something todo with let-no-escape. + Fast entry blocks arent nestable, however we + special case fall through. +\begin{code} +#ifdef DPH +isLocalLabel::CLabel -> Bool +isLocalLabel (ALocalLabel _ _) = True +isLocalLabel _ = False + +isNestableBlockLabel (ALocalLabel _ _) = True +isNestableBlockLabel (IdLabel _ EntryStd) = True +isNestableBlockLabel (IdLabel _ ConEntry) = True +isNestableBlockLabel (IdLabel _ StaticConEntry) = True +isNestableBlockLabel _ = False + +isSlowFastLabelPair :: CLabel -> CLabel -> Bool +isSlowFastLabelPair (IdLabel clid EntryStd) (IdLabel clid' (EntryFast _)) = clid == clid' +isSlowFastLabelPair _ _ = False +#endif {- Data Parallel Haskell -} +\end{code} + +We need to determine if a label represents a code entity, an ordinary +data entity, or a special global data entity (placed at an absolute +address by the runtime system that ensures fast loading of variable +contents---global ``registers'' such as SuA are placed here as well) +(different instructions are used in the DAP machine code). +\begin{code} +#ifdef DPH +isGlobalDataLabel _ = False + +isDataLabel :: CLabel -> Bool +isDataLabel (IdLabel _ Closure) = True +isDataLabel _ = False + +isVectorTableLabel :: CLabel -> Bool +isVectorTableLabel (VecTblCLabel _) = True +isVectorTableLabel _ = False +#endif {- Data Parallel Haskell -} +\end{code} + +Sort of like the needsCDecl, we need to stop the assembler from complaining +about various data sections :-) +\begin{code} +#ifdef DPH +needsApalDecl :: CLabel -> Bool +needsApalDecl (IdLabel (CLabelId id) Closure) = not (isLocallyDefined id) +needsApalDecl _ = False +#endif {- Data Parallel Haskell -} +\end{code} + +These GRAN functions are needed for spitting out GRAN_FETCH() at the +right places. It is used to detect when the abstractC statement of an +CCodeBlock actually contains the code for a slow entry point. -- HWL + +\begin{code} +#ifdef GRAN + +isSlowEntryCCodeBlock :: CLabel -> Bool +isSlowEntryCCodeBlock _ = False +-- Worth keeping? ToDo (WDP) + +#endif {-GRAN-} +\end{code} + +We need at least @Eq@ for @CLabels@, because we want to avoid +duplicate declarations in generating C (see @labelSeenTE@ in +@PprAbsC@). + +\begin{code} +pprCLabel :: PprStyle -> CLabel -> Unpretty + +pprCLabel (PprForAsm _ _ fmtAsmLbl) (AsmTempLabel u) + = uppStr (fmtAsmLbl (_UNPK_ (showUnique u))) + +pprCLabel (PprForAsm sw_chker prepend_cSEP _) lbl + = if prepend_cSEP + then uppBeside pp_cSEP prLbl + else prLbl + where + prLbl = pprCLabel (PprForC sw_chker) lbl + +pprCLabel sty (TyConLabel tc UnvecConUpdCode) + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), + pp_cSEP, uppPStr SLIT("upd")] + +pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP, + uppInt tag, pp_cSEP, uppPStr SLIT("upd")] + +pprCLabel sty (TyConLabel tc (StdUpdCode tag)) + = case (ctrlReturnConvAlg tc) of + UnvectoredReturn _ -> uppPStr SLIT("IndUpdRetDir") + VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG)) + +pprCLabel sty (TyConLabel tc InfoTblVecTbl) + = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")] + +pprCLabel sty (TyConLabel tc StdUpdVecTbl) + = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc), + pp_cSEP, uppPStr SLIT("upd")] + +pprCLabel sty (CaseLabel u CaseReturnPt) + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_u u] +pprCLabel sty (CaseLabel u CaseVecTbl) + = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_u u] +pprCLabel sty (CaseLabel u (CaseAlt tag)) + = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u, pp_cSEP, uppInt tag] +pprCLabel sty (CaseLabel u CaseDefault) + = uppBesides [uppPStr SLIT("djn"), pp_cSEP, ppr_u u] + +pprCLabel sty (RtsLabel RtsShouldNeverHappenCode) = uppPStr SLIT("StdErrorCode") + +pprCLabel sty (RtsLabel RtsBlackHoleInfoTbl) = uppPStr SLIT("BH_UPD_info") + +pprCLabel sty (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) + = uppBesides [uppPStr SLIT("__sel_info_"), uppStr (show offset), + uppStr (if upd_reqd then "upd" else "noupd"), + uppPStr SLIT("__")] + +pprCLabel sty (RtsLabel (RtsSelectorEntry upd_reqd offset)) + = uppBesides [uppPStr SLIT("__sel_entry_"), uppStr (show offset), + uppStr (if upd_reqd then "upd" else "noupd"), + uppPStr SLIT("__")] + +pprCLabel sty (IdLabel (CLabelId id) flavor) + = uppBeside (prettyToUn (ppr sty id)) (ppFlavor flavor) + +#ifdef DPH +pprCLabel sty (ALocalLabel u str) = uppBeside (uppStr str) (ppr_u u) +#endif {- Data Parallel Haskell -} + +ppr_u u = prettyToUn (pprUnique u) + +ppFlavor :: IdLabelInfo -> Unpretty +#ifndef DPH +ppFlavor x = uppBeside pp_cSEP + (case x of + Closure -> uppPStr SLIT("closure") + InfoTbl -> uppPStr SLIT("info") + EntryStd -> uppPStr SLIT("entry") + EntryFast arity -> --false:ASSERT (arity > 0) + uppBeside (uppPStr SLIT("fast")) (uppInt arity) + ConEntry -> uppPStr SLIT("entry") + StaticConEntry -> uppPStr SLIT("static_entry") + StaticInfoTbl -> uppPStr SLIT("static_info") + PhantomInfoTbl -> uppPStr SLIT("inregs_info") + VapInfoTbl True -> uppPStr SLIT("vap_info") + VapInfoTbl False -> uppPStr SLIT("vap_noupd_info") + VapEntry True -> uppPStr SLIT("vap_entry") + VapEntry False -> uppPStr SLIT("vap_noupd_entry") + RednCounts -> uppPStr SLIT("ct") + ) +#else +ppFlavor x = uppStr (case x of + Closure -> "_clos" + InfoTbl -> "_info" + EntryStd -> "_entry" + EntryFast arity -> "_fast" ++ show arity + ConEntry -> "_entry" + StaticConEntry -> "_statentr" + StaticInfoTbl -> "_statinfo" + PhantomInfoTbl -> "_irinfo" + -- ToDo: add more + ) +#endif {- Data Parallel Haskell -} + +\end{code} + +ToDo: +use Z as escape char +\begin{verbatim} +_ main separator + +orig becomes +**** ******* +_ Zu +' Zq (etc for ops ??) + Z[hex-digit][hex-digit] +Prelude ZP + ZC + ZT +\end{verbatim} + +\begin{code} +cSEP = SLIT("_") -- official C separator +pp_cSEP = uppChar '_' + +identToC :: FAST_STRING -> Pretty +modnameToC :: FAST_STRING -> FAST_STRING +stringToC :: String -> String +charToC, charToEasyHaskell :: Char -> String + +-- stringToC: the hassle is what to do w/ strings like "ESC 0"... + +stringToC "" = "" +stringToC [c] = charToC c +stringToC (c:cs) + -- if we have something "octifiable" in "c", we'd better "octify" + -- the rest of the string, too. + = if (c < ' ' || c > '~') + then (charToC c) ++ (concat (map char_to_C cs)) + else (charToC c) ++ (stringToC cs) + where + char_to_C c | c == '\n' = "\\n" -- use C escapes when we can + | c == '\a' = "\\a" + | c == '\b' = "\\b" -- ToDo: chk some of these... + | c == '\r' = "\\r" + | c == '\t' = "\\t" + | c == '\f' = "\\f" + | c == '\v' = "\\v" + | otherwise = '\\' : (octify (ord c)) + +-- OLD?: stringToC str = concat (map charToC str) + +charToC c = if (c >= ' ' && c <= '~') -- non-portable... + then case c of + '\'' -> "\\'" + '\\' -> "\\\\" + '"' -> "\\\"" + '\n' -> "\\n" + '\a' -> "\\a" + '\b' -> "\\b" + '\r' -> "\\r" + '\t' -> "\\t" + '\f' -> "\\f" + '\v' -> "\\v" + _ -> [c] + else '\\' : (octify (ord c)) + +-- really: charToSimpleHaskell + +charToEasyHaskell c + = if (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + then [c] + else case c of + _ -> '\\' : 'o' : (octify (ord c)) + +octify :: Int -> String +octify n + = if n < 8 then + [chr (n + ord '0')] + else + octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')] + +identToC ps + = let + str = _UNPK_ ps + in + ppBeside + (case str of + 's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"... + ppChar 'Z' + _ -> ppNil) + + (if (all isAlphanum str) -- we gamble that this test will succeed... + then ppPStr ps + else ppIntersperse ppNil (map char_to_c str)) + where + char_to_c 'Z' = ppPStr SLIT("ZZ") + char_to_c '&' = ppPStr SLIT("Za") + char_to_c '|' = ppPStr SLIT("Zb") + char_to_c ':' = ppPStr SLIT("Zc") + char_to_c '/' = ppPStr SLIT("Zd") + char_to_c '=' = ppPStr SLIT("Ze") + char_to_c '>' = ppPStr SLIT("Zg") + char_to_c '#' = ppPStr SLIT("Zh") + char_to_c '<' = ppPStr SLIT("Zl") + char_to_c '-' = ppPStr SLIT("Zm") + char_to_c '!' = ppPStr SLIT("Zn") + char_to_c '.' = ppPStr SLIT("Zo") + char_to_c '+' = ppPStr SLIT("Zp") + char_to_c '\'' = ppPStr SLIT("Zq") + char_to_c '*' = ppPStr SLIT("Zt") + char_to_c '_' = ppPStr SLIT("Zu") + + char_to_c c = if isAlphanum c + then ppChar c + else ppBeside (ppChar 'Z') (ppInt (ord c)) +\end{code} + +For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote +chars) in the name. Rare. +\begin{code} +modnameToC ps + = let + str = _UNPK_ ps + in + if not (any quote_here str) then + ps + else + _PK_ (concat (map char_to_c str)) + where + quote_here '\'' = True + quote_here _ = False + + char_to_c c + = if isAlphanum c then [c] else 'Z' : (show (ord c)) +\end{code} diff --git a/ghc/compiler/basicTypes/Id.hi b/ghc/compiler/basicTypes/Id.hi new file mode 100644 index 0000000..caf5365 --- /dev/null +++ b/ghc/compiler/basicTypes/Id.hi @@ -0,0 +1,266 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Id where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo) +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreAtom, CoreExpr) +import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, bottomIsGuaranteed, getInfo_UF, nullSpecEnv) +import Inst(Inst, InstOrigin, OverloadedLit) +import InstEnv(InstTemplate, InstTy) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TyCon(Arity(..), TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TypeEnv(..)) +import UniTyFuns(getMentionedTyConsAndClassesFromUniType) +import UniType(TauType(..), ThetaType(..), UniType) +import UniqFM(UniqFM) +import Unique(Unique, UniqueSupply) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +type ConTag = Int +type DataCon = Id +type DictFun = Id +type DictVar = Id +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-} +data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data IdDetails {-# GHC_PRAGMA LocalId ShortName Bool | SysLocalId ShortName Bool | SpecPragmaId ShortName (Labda SpecInfo) Bool | ImportedId FullName | PreludeId FullName | TopLevId FullName | DataConId FullName Int [TyVarTemplate] [(Class, UniType)] [UniType] TyCon | TupleConId Int | SuperDictSelId Class Class | ClassOpId Class ClassOp | DefaultMethodId Class ClassOp Bool | DictFunId Class UniType Bool | ConstMethodId Class UniType ClassOp Bool | InstId Inst | SpecId Id [Labda UniType] Bool | WorkerId Id #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +type Arity = Int +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TypeEnv = UniqFM UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdArity :: Id -> Int -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdDemandInfo :: Id -> DemandInfo -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdFBTypeInfo :: Id -> FBTypeInfo -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdSpecialisation :: Id -> SpecEnv -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdStrictness :: Id -> StrictnessInfo -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdUnfolding :: Id -> UnfoldingDetails -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addIdUpdateInfo :: Id -> UpdateInfo -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +applySubstToId :: Subst -> Id -> (Subst, Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LSU(LLU(S)LLLLLLL)S)" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +applyTypeEnvToId :: UniqFM UniType -> Id -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +bottomIsGuaranteed :: StrictnessInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo BottomGuaranteed -> _!_ True [] []; (u1 :: StrictnessInfo) -> _!_ False [] [] } _N_ #-} +cmpId :: Id -> Id -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cmpId_withSpecDataCon :: Id -> Id -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAL)U(U(P)AAL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +eqId :: Id -> Id -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +externallyVisibleId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fIRST_TAG :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-} +getDataConArity :: Id -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLU(SLLLLLLLLL)L)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getDataConSig :: Id -> ([TyVarTemplate], [(Class, UniType)], [UniType], TyCon) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getDataConTag :: Id -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getDataConTyCon :: Id -> TyCon + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getIdArgUsageInfo :: Id -> ArgUsageInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAASAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArgUsageInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> uc; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdArity :: Id -> ArityInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(SAAAAAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArityInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u5; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdDemandInfo :: Id -> DemandInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(ASAAAAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DemandInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdFBTypeInfo :: Id -> FBTypeInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAAASA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: FBTypeInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> ud; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdInfo :: Id -> IdInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(LLLLLLLLLL)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: IdInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u3; _NO_DEFLT_ } _N_ #-} +getIdKind :: Id -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns kindFromType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns kindFromType [ u5 ] _N_ #-} +getIdSpecialisation :: Id -> SpecEnv + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAU(L)AAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u7; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdStrictness :: Id -> StrictnessInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAASAAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StrictnessInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u8; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdUnfolding :: Id -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAASAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UnfoldingDetails) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u9; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getIdUniType :: Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_ #-} +getIdUpdateInfo :: Id -> UpdateInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAASAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UpdateInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> ua; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getInfo_UF :: IdInfo -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UnfoldingDetails) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u5; _NO_DEFLT_ } _N_ #-} +getInstNamePieces :: Bool -> Inst -> [_PackedString] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +getInstantiatedDataConSig :: Id -> [UniType] -> ([UniType], [UniType], UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _N_ _N_ #-} +getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns getMentionedTyConsAndClassesFromUniType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns getMentionedTyConsAndClassesFromUniType [ u5 ] _N_ #-} +getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +idWantsToBeINLINEd :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAASAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: UnfoldingDetails) -> case u0 of { _ALG_ _ORIG_ SimplEnv IWantToBeINLINEd (u1 :: UnfoldingGuidance) -> _!_ True [] []; (u2 :: UnfoldingDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isBottomingId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAASAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ (u1 :: StrictnessInfo) -> _APP_ _ORIG_ IdInfo bottomIsGuaranteed [ u1 ] } _N_} _N_ _N_ #-} +isClassOpId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id ClassOpId (u1 :: Class) (u2 :: ClassOp) -> _!_ True [] []; (u3 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isConstMethodId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id ConstMethodId (u1 :: Class) (u2 :: UniType) (u3 :: ClassOp) (u4 :: Bool) -> _!_ True [] []; (u5 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isDataCon :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isDefaultMethodId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id DefaultMethodId (u1 :: Class) (u2 :: ClassOp) (u3 :: Bool) -> _!_ True [] []; (u4 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isDictFunId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id DictFunId (u1 :: Class) (u2 :: UniType) (u3 :: Bool) -> _!_ True [] []; (u4 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isImportedId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id ImportedId (u1 :: FullName) -> _!_ True [] []; (u2 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isInstId_maybe :: Id -> Labda Inst + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 19 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id InstId (u1 :: Inst) -> _!_ _ORIG_ Maybes Ni [Inst] [u1]; (u2 :: IdDetails) -> _!_ _ORIG_ Maybes Hamna [Inst] [] } _N_} _N_ _N_ #-} +isNullaryDataCon :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isSpecId_maybe :: Id -> Labda (Id, [Labda UniType]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isSpecPragmaId_maybe :: Id -> Labda (Labda SpecInfo) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 19 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id SpecPragmaId (u1 :: ShortName) (u2 :: Labda SpecInfo) (u3 :: Bool) -> _!_ _ORIG_ Maybes Ni [(Labda SpecInfo)] [u2]; (u4 :: IdDetails) -> _!_ _ORIG_ Maybes Hamna [(Labda SpecInfo)] [] } _N_} _N_ _N_ #-} +isSuperDictSelId_maybe :: Id -> Labda (Class, Class) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isSysLocalId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id SysLocalId (u1 :: ShortName) (u2 :: Bool) -> _!_ True [] []; (u3 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isTopLevId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id TopLevId (u1 :: FullName) -> _!_ True [] []; (u2 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isTupleCon :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isWorkerId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id WorkerId (u1 :: Id) -> _!_ True [] []; (u2 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-} +isWrapperId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAASAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ (u1 :: StrictnessInfo) -> _APP_ _ORIG_ IdInfo workerExists [ u1 ] } _N_} _N_ _N_ #-} +localiseId :: Id -> Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkClassOpId :: Unique -> Class -> ClassOp -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkConstMethodId :: Unique -> Class -> ClassOp -> UniType -> UniType -> Bool -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +mkDataCon :: Unique -> FullName -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id + {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +mkDefaultMethodId :: Unique -> Class -> ClassOp -> Bool -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-} +mkDictFunId :: Unique -> Class -> UniType -> UniType -> Bool -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-} +mkId :: Name -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +mkIdWithNewUniq :: Id -> Unique -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLL)L" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkImported :: Unique -> FullName -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +mkInstId :: Inst -> Id + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkPreludeId :: Unique -> FullName -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +mkSameSpecCon :: [Labda UniType] -> Id -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkSpecId :: Unique -> Id -> [Labda UniType] -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkSpecPragmaId :: _PackedString -> Unique -> UniType -> Labda SpecInfo -> SrcLoc -> Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkSuperDictSelId :: Unique -> Class -> Class -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkSysLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +mkTemplateLocals :: [UniType] -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkTupleCon :: Int -> Id + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkUserLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +mkWorkerId :: Unique -> Id -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +myWrapperMaybe :: Id -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 19 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id WorkerId (u1 :: Id) -> _!_ _ORIG_ Maybes Ni [Id] [u1]; (u2 :: IdDetails) -> _!_ _ORIG_ Maybes Hamna [Id] [] } _N_} _N_ _N_ #-} +nullSpecEnv :: SpecEnv + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pprIdInUnfolding :: UniqFM Id -> Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SU(U(P)LLL)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +replaceIdInfo :: Id -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLAL)L" {_A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: UniType) (u2 :: IdDetails) (u3 :: IdInfo) -> _!_ _ORIG_ Id Id [] [u0, u1, u3, u2] _N_} _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: Id) (u1 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ Id Id (u2 :: Unique) (u3 :: UniType) (u4 :: IdInfo) (u5 :: IdDetails) -> _!_ _ORIG_ Id Id [] [u2, u3, u1, u5]; _NO_DEFLT_ } _N_ #-} +showId :: PprStyle -> Id -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +toplevelishId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +unfoldingUnfriendlyId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +unlocaliseId :: _PackedString -> Id -> Labda Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +updateIdType :: Id -> UniType -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LALL)L" {_A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: IdInfo) (u2 :: IdDetails) (u3 :: UniType) -> _!_ _ORIG_ Id Id [] [u0, u3, u1, u2] _N_} _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: Id) (u1 :: UniType) -> case u0 of { _ALG_ _ORIG_ Id Id (u2 :: Unique) (u3 :: UniType) (u4 :: IdInfo) (u5 :: IdDetails) -> _!_ _ORIG_ Id Id [] [u2, u1, u4, u5]; _NO_DEFLT_ } _N_ #-} +whatsMentionedInId :: UniqFM Id -> Id -> (Bag Id, Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs new file mode 100644 index 0000000..a9b3b7e --- /dev/null +++ b/ghc/compiler/basicTypes/Id.lhs @@ -0,0 +1,2264 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Id]{@Ids@: Value and constructor identifiers} + +\begin{code} +#include "HsVersions.h" + +module Id ( + Id, -- abstract + IdInfo, -- re-exporting + ConTag(..), DictVar(..), DictFun(..), DataCon(..), + + -- CONSTRUCTION + mkSysLocal, mkUserLocal, + mkSpecPragmaId, + mkSpecId, mkSameSpecCon, + mkTemplateLocals, + mkImported, mkPreludeId, + mkDataCon, mkTupleCon, + mkIdWithNewUniq, + mkClassOpId, mkSuperDictSelId, mkDefaultMethodId, + mkConstMethodId, mkInstId, +#ifdef DPH + mkProcessorCon, + mkPodId, +#endif {- Data Parallel Haskell -} + + updateIdType, + mkId, mkDictFunId, + mkWorkerId, + localiseId, + + -- DESTRUCTION + getIdUniType, + getInstNamePieces, getIdInfo, replaceIdInfo, + getIdKind, + getMentionedTyConsAndClassesFromId, + getDataConTag, + getDataConSig, getInstantiatedDataConSig, + getDataConTyCon, -- UNUSED: getDataConFamily, +#ifdef USE_SEMANTIQUE_STRANAL + getDataConDeps, +#endif + + -- PREDICATES + isDataCon, isTupleCon, isNullaryDataCon, + isSpecId_maybe, isSpecPragmaId_maybe, + toplevelishId, externallyVisibleId, + isTopLevId, isWorkerId, isWrapperId, + isImportedId, isSysLocalId, + isBottomingId, + isClassOpId, isConstMethodId, isDefaultMethodId, + isDictFunId, isInstId_maybe, isSuperDictSelId_maybe, +#ifdef DPH + isInventedTopLevId, + isProcessorCon, +#endif {- Data Parallel Haskell -} + eqId, cmpId, + cmpId_withSpecDataCon, + myWrapperMaybe, + whatsMentionedInId, + unfoldingUnfriendlyId, -- ToDo: rm, eventually + idWantsToBeINLINEd, +-- dataConMentionsNonPreludeTyCon, + + -- SUBSTITUTION + applySubstToId, applyTypeEnvToId, +-- not exported: apply_to_Id, -- please don't use this, generally + + -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) + getIdArity, getDataConArity, addIdArity, + getIdDemandInfo, addIdDemandInfo, + getIdSpecialisation, addIdSpecialisation, + getIdStrictness, addIdStrictness, + getIdUnfolding, addIdUnfolding, -- UNUSED? clearIdUnfolding, + getIdUpdateInfo, addIdUpdateInfo, + getIdArgUsageInfo, addIdArgUsageInfo, + getIdFBTypeInfo, addIdFBTypeInfo, + -- don't export the types, lest OptIdInfo be dragged in! + + -- MISCELLANEOUS + unlocaliseId, + fIRST_TAG, + showId, + pprIdInUnfolding, + + -- and to make the interface self-sufficient... + Class, ClassOp, GlobalSwitch, Inst, Maybe, Name, + FullName, PprStyle, PrettyRep, + PrimKind, SrcLoc, Pretty(..), Subst, UnfoldingDetails, + TyCon, TyVar, TyVarTemplate, TauType(..), UniType, Unique, + UniqueSupply, Arity(..), ThetaType(..), + TypeEnv(..), UniqFM, InstTemplate, Bag, + SpecEnv, nullSpecEnv, SpecInfo, + + -- and to make sure pragmas work... + IdDetails -- from this module, abstract + IF_ATTACK_PRAGMAS(COMMA getMentionedTyConsAndClassesFromUniType) + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + IF_ATTACK_PRAGMAS(COMMA getInfo_UF) + +#ifndef __GLASGOW_HASKELL__ + , TAG_ +#endif + ) where + +IMPORT_Trace -- ToDo: rm (debugging only) + +import AbsPrel ( PrimOp, PrimKind, mkFunTy, nilDataCon, pRELUDE_BUILTIN + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +#ifdef DPH + , mkPodNTy, mkPodizedPodNTy +#endif {- Data Parallel Haskell -} + ) + +import AbsUniType +import Bag +import CLabelInfo ( identToC, cSEP ) +import CmdLineOpts ( GlobalSwitch(..) ) +import IdEnv -- ( nullIdEnv, IdEnv ) +import IdInfo -- piles of it +import Inst -- lots of things +import Maybes ( maybeToBool, Maybe(..) ) +import Name ( Name(..) ) +import NameTypes +import Outputable +import Pretty -- for pretty-printing +import SrcLoc +import Subst ( applySubstToTy ) -- PRETTY GRIMY TO LOOK IN HERE +import PlainCore +import PrelFuns ( pcGenerateDataSpecs ) -- PRETTY GRIMY TO LOOK IN HERE +import UniqFM +import UniqSet +import Unique +import Util +#ifdef DPH +IMPORT_Trace +import PodizeCore ( podizeTemplateExpr ) +import PodInfoTree ( infoTypeNumToMask ) +#endif {- Data Parallel Haskell -} +\end{code} + +Here are the @Id@ and @IdDetails@ datatypes; also see the notes that +follow. + +Every @Id@ has a @Unique@, to uniquify it and for fast comparison, a +@UniType@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Ids@ is +in its @IdDetails@. + +ToDo: possibly cache other stuff in the single-constructor @Id@ type. + +\begin{code} +data Id = Id Unique -- key for fast comparison + UniType -- Id's type; used all the time; + IdInfo -- non-essential info about this Id; + IdDetails -- stuff about individual kinds of Ids. + +data IdDetails + + ---------------- Local values + + = LocalId ShortName -- mentioned by the user + Bool -- True <=> no free type vars + + | SysLocalId ShortName -- made up by the compiler + Bool -- as for LocalId + + | SpecPragmaId ShortName -- introduced by the compiler + (Maybe SpecInfo)-- for explicit specid in pragma + Bool -- as for LocalId + + ---------------- Global values + + | ImportedId FullName -- Id imported from an interface + + | PreludeId FullName -- things < Prelude that compiler "knows" about + + | TopLevId FullName -- Top-level in the orig source pgm + -- (not moved there by transformations). + + -- a TopLevId's type may contain free type variables, if + -- the monomorphism restriction applies. + + ---------------- Data constructors + + | DataConId FullName + ConTag + -- cached pieces of the type: + [TyVarTemplate] [(Class,UniType)] [UniType] TyCon + -- the type is: + -- forall tyvars . theta_ty => + -- unitype_1 -> ... -> unitype_n -> tycon tyvars + -- + -- "type ThetaType = [(Class, UniType)]" + + -- The [TyVarTemplate] is in the same order as the args of the + -- TyCon for the constructor + + | TupleConId Int -- Its arity + +#ifdef DPH + | ProcessorCon Int -- Its arity +#endif {- Data Parallel Haskell -} + + ---------------- Things to do with overloading + + | SuperDictSelId -- Selector for superclass dictionary + Class -- The class (input dict) + Class -- The superclass (result dict) + + | ClassOpId Class -- An overloaded class operation, with + -- a fully polymorphic type. Its code + -- just selects a method from the + -- dictionary. The class. + ClassOp -- The operation + + -- NB: The IdInfo for a ClassOpId has all the info about its + -- related "constant method Ids", which are just + -- specialisations of this general one. + + | DefaultMethodId -- Default method for a particular class op + Class -- same class, info as ClassOpId + ClassOp -- (surprise, surprise) + Bool -- True <=> I *know* this default method Id + -- is a generated one that just says + -- `error "No default method for "'. +\end{code} + +DictFunIds are generated from instance decls. +\begin{verbatim} + class Foo a where + op :: a -> a -> Bool + + instance Foo a => Foo [a] where + op = ... +\end{verbatim} +generates the dict fun id decl +\begin{verbatim} + dfun.Foo.[*] = \d -> ... +\end{verbatim} +The dfun id is uniquely named by the (class, type) pair. Notice, it +isn't a (class,tycon) pair any more, because we may get manually or +automatically generated specialisations of the instance decl: +\begin{verbatim} + instance Foo [Int] where + op = ... +\end{verbatim} +generates +\begin{verbatim} + dfun.Foo.[Int] = ... +\end{verbatim} +The type variables in the name are irrelevant; we print them as stars. + +\begin{code} + | DictFunId Class -- A DictFun is uniquely identified + UniType -- by its class and type; this type has free type vars, + -- whose identity is irrelevant. Eg Class = Eq + -- Type = Tree a + -- The "a" is irrelevant. As it is too painful to + -- actually do comparisons that way, we kindly supply + -- a Unique for that purpose. + Bool -- True <=> from an instance decl in this mod +\end{code} + +Constant method ids are generated from instance decls where +there is no context; that is, no dictionaries are needed to +construct the method. Example +\begin{verbatim} + instance Foo Int where + op = ... +\end{verbatim} +Then we get a constant method +\begin{verbatim} + Foo.op.Int = ... +\end{verbatim} + +It is possible, albeit unusual, to have a constant method +for an instance decl which has type vars: +\begin{verbatim} + instance Foo [a] where + op [] ys = True + op (x:xs) ys = False +\end{verbatim} +We get the constant method +\begin{verbatim} + Foo.op.[*] = ... +\end{verbatim} +So a constant method is identified by a class/op/type triple. +The type variables in the type are irrelevant. + +\begin{code} + | ConstMethodId -- A method which depends only on the type of the + -- instance, and not on any further dictionaries etc. + Class -- Uniquely identified by: + UniType -- (class, type, classop) triple + ClassOp + Bool -- True <=> from an instance decl in this mod + + | InstId Inst -- An instance of a dictionary, class operation, + -- or overloaded value + + | SpecId -- A specialisation of another Id + Id -- Id of which this is a specialisation + [Maybe UniType] -- Types at which it is specialised; + -- A "Nothing" says this type ain't relevant. + Bool -- True <=> no free type vars; it's not enough + -- to know about the unspec version, because + -- we may specialise to a type w/ free tyvars + -- (i.e., in one of the "Maybe UniType" dudes). + + | WorkerId -- A "worker" for some other Id + Id -- Id for which this is a worker + +#ifdef DPH + | PodId Int -- The dimension of the PODs context + Int -- Which specialisation of InfoType is + -- bind. ToDo(hilly): Int is a little messy + -- and has a restricted range---change. + Id -- One of the aboves Ids. +#endif {- Data Parallel Haskell -} + +type ConTag = Int +type DictVar = Id +type DictFun = Id +type DataCon = Id +\end{code} + +For Ids whose names must be known/deducible in other modules, we have +to conjure up their worker's names (and their worker's worker's +names... etc) in a known systematic way. + +%************************************************************************ +%* * +\subsection[Id-documentation]{Documentation} +%* * +%************************************************************************ + +[A BIT DATED [WDP]] + +The @Id@ datatype describes {\em values}. The basic things we want to +know: (1)~a value's {\em type} (@getIdUniType@ is a very common +operation in the compiler); and (2)~what ``flavour'' of value it might +be---for example, it can be terribly useful to know that a value is a +class method. + +\begin{description} +%---------------------------------------------------------------------- +\item[@DataConId@:] For the data constructors declared by a @data@ +declaration. Their type is kept in {\em two} forms---as a regular +@UniType@ (in the usual place), and also in its constituent pieces (in +the ``details''). We are frequently interested in those pieces. + +%---------------------------------------------------------------------- +\item[@TupleConId@:] This is just a special shorthand for @DataCons@ for +the infinite family of tuples. + +%---------------------------------------------------------------------- +\item[@ImportedId@:] These are values defined outside this module. +{\em Everything} we want to know about them must be stored here (or in +their @IdInfo@). + +%---------------------------------------------------------------------- +\item[@PreludeId@:] ToDo + +%---------------------------------------------------------------------- +\item[@TopLevId@:] These are values defined at the top-level in this +module; i.e., those which {\em might} be exported (hence, a +@FullName@). It does {\em not} include those which are moved to the +top-level through program transformations. + +We also guarantee that @TopLevIds@ will {\em stay} at top-level. +Theoretically, they could be floated inwards, but there's no known +advantage in doing so. This way, we can keep them with the same +@Unique@ throughout (no cloning), and, in general, we don't have to be +so paranoid about them. + +In particular, we had the following problem generating an interface: +We have to ``stitch together'' info (1)~from the typechecker-produced +global-values list (GVE) and (2)~from the STG code [which @Ids@ have +what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change} +between (1) and (2), you're sunk! + +%---------------------------------------------------------------------- +\item[@ClassOpId@:] A selector from a dictionary; it may select either +a method or a dictionary for one of the class's superclasses. + +%---------------------------------------------------------------------- +\item[@DictFunId@:] + +@mkDictFunId [a,b..] theta C T@ is the function derived from the +instance declaration + + instance theta => C (T a b ..) where + ... + +It builds function @Id@ which maps dictionaries for theta, +to a dictionary for C (T a b ..). + +*Note* that with the ``Mark Jones optimisation'', the theta may +include dictionaries for the immediate superclasses of C at the type +(T a b ..). + +%---------------------------------------------------------------------- +\item[@InstId@:] + +%---------------------------------------------------------------------- +\item[@SpecId@:] + +%---------------------------------------------------------------------- +\item[@WorkerId@:] + +%---------------------------------------------------------------------- +\item[@LocalId@:] A purely-local value, e.g., a function argument, +something defined in a @where@ clauses, ... --- but which appears in +the original program text. + +%---------------------------------------------------------------------- +\item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in +the original program text; these are introduced by the compiler in +doing its thing. + +%---------------------------------------------------------------------- +\item[@SpecPragmaId@:] Introduced by the compiler to record +Specialisation pragmas. It is dead code which MUST NOT be removed +before specialisation. +\end{description} + +Further remarks: +\begin{enumerate} +%---------------------------------------------------------------------- +\item + +@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@, +@ClassOpIds@, @DictFunIds@, and @DefaultMethodIds@ have the following +properties: +\begin{itemize} +\item +They have no free type variables, so if you are making a +type-variable substitution you don't need to look inside them. +\item +They are constants, so they are not free variables. (When the STG +machine makes a closure, it puts all the free variables in the +closure; the above are not required.) +\end{itemize} +Note that @InstIds@, @Locals@ and @SysLocals@ {\em may} have the above +properties, but they may not. +\end{enumerate} + + +%************************************************************************ +%* * +\subsection[Id-general-funs]{General @Id@-related functions} +%* * +%************************************************************************ + +\begin{code} +isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _)) = True +isDataCon (Id _ _ _ (TupleConId _)) = True +isDataCon (Id _ _ _ (SpecId unspec _ _)) = isDataCon unspec +#ifdef DPH +isDataCon (ProcessorCon _ _) = True +isDataCon (PodId _ _ id ) = isDataCon id +#endif {- Data Parallel Haskell -} +isDataCon other = False + +isTupleCon (Id _ _ _ (TupleConId _)) = True +isTupleCon (Id _ _ _ (SpecId unspec _ _)) = isTupleCon unspec +#ifdef DPH +isTupleCon (PodId _ _ id) = isTupleCon id +#endif {- Data Parallel Haskell -} +isTupleCon other = False + +isNullaryDataCon data_con + = isDataCon data_con + && (case arityMaybe (getIdArity data_con) of + Just a -> a == 0 + _ -> panic "isNullaryDataCon") + +isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _)) + = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) + Just (unspec, ty_maybes) +isSpecId_maybe other_id + = Nothing + +isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId _ specinfo _)) + = Just specinfo +isSpecPragmaId_maybe other_id + = Nothing + +#ifdef DPH +isProcessorCon (ProcessorCon _ _) = True +isProcessorCon (PodId _ _ id) = isProcessorCon id +isProcessorCon other = False +#endif {- Data Parallel Haskell -} +\end{code} + +@toplevelishId@ tells whether an @Id@ {\em may} be defined in a +nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be +defined at top level (returns @True@). This is used to decide whether +the @Id@ is a candidate free variable. NB: you are only {\em sure} +about something if it returns @True@! + +\begin{code} +toplevelishId :: Id -> Bool +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 (ClassOpId _ _) = 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 +#ifdef DPH + chk (ProcessorCon _ _) = True + chk (PodId _ _ id) = toplevelishId id +#endif {- Data Parallel Haskell -} + +idHasNoFreeTyVars (Id _ _ info details) + = chk details + where + chk (DataConId _ _ _ _ _ _) = True + chk (TupleConId _) = True + chk (ImportedId _) = True + chk (PreludeId _) = True + chk (TopLevId _) = True + chk (SuperDictSelId _ _) = True + chk (ClassOpId _ _) = True + chk (DefaultMethodId _ _ _) = True + chk (DictFunId _ _ _) = True + chk (ConstMethodId _ _ _ _) = True + chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr + chk (InstId _) = False -- these are local + chk (SpecId _ _ no_free_tvs) = no_free_tvs + chk (LocalId _ no_free_tvs) = no_free_tvs + chk (SysLocalId _ no_free_tvs) = no_free_tvs + chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs +#ifdef DPH + chk (ProcessorCon _ _) = True + chk (PodId _ _ id) = idHasNoFreeTyVars id +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +isTopLevId (Id _ _ _ (TopLevId _)) = True +#ifdef DPH +isTopLevId (PodId _ _ id) = isTopLevId id +#endif {- Data Parallel Haskell -} +isTopLevId other = False + +-- an "invented" one is a top-level Id, must be globally visible, etc., +-- but it's slightly different in that it was "conjured up". +-- This handles workers fine, but may need refinement for other +-- conjured-up things (e.g., specializations) +-- NB: Only used in DPH now (93/08/20) + +#ifdef DPH +ToDo: DPH +isInventedTopLevId (TopLevId _ n _ _) = isInventedFullName n +isInventedTopLevId (SpecId _ _ _) = True +isInventedTopLevId (WorkerId _) = True +isInventedTopLevId (PodId _ _ id) = isInventedTopLevId id +isInventedTopLevId other = False +#endif {- Data Parallel Haskell -} + +isImportedId (Id _ _ _ (ImportedId _)) = True +#ifdef DPH +isImportedId (PodId _ _ id) = isImportedId id +#endif {- Data Parallel Haskell -} +isImportedId other = False + +isBottomingId (Id _ _ info _) = bottomIsGuaranteed (getInfo info) +#ifdef DPH +isBottomingId (PodId _ _ id) = isBottomingId id +#endif {- Data Parallel Haskell -} +--isBottomingId other = False + +isSysLocalId (Id _ _ _ (SysLocalId _ _)) = True +#ifdef DPH +isSysLocalId (PodId _ _ id) = isSysLocalId id +#endif {- Data Parallel Haskell -} +isSysLocalId other = False + +isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _ _)) = True +#ifdef DPH +isSpecPragmaId (PodId _ _ id) = isSpecPragmaId id +#endif {- Data Parallel Haskell -} +isSpecPragmaId other = False + +isClassOpId (Id _ _ _ (ClassOpId _ _)) = True +isClassOpId _ = False + +isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _)) = True +#ifdef DPH +isDefaultMethodId (PodId _ _ id) = isDefaultMethodId id +#endif {- Data Parallel Haskell -} +isDefaultMethodId other = False + +isDictFunId (Id _ _ _ (DictFunId _ _ _)) = True +#ifdef DPH +isDictFunId (PodId _ _ id) = isDictFunId id +#endif {- Data Parallel Haskell -} +isDictFunId other = False + +isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _)) = True +#ifdef DPH +isConstMethodId (PodId _ _ id) = isConstMethodId id +#endif {- Data Parallel Haskell -} +isConstMethodId other = False + +isInstId_maybe (Id _ _ _ (InstId inst)) = Just inst +#ifdef DPH +isInstId_maybe (PodId _ _ id) = isInstId_maybe id +#endif {- Data Parallel Haskell -} +isInstId_maybe other_id = Nothing + +isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc)) = Just (c, sc) +#ifdef DPH +isSuperDictSelId_maybe (PodId _ _ id) = isSuperDictSelId_maybe id +#endif {- Data Parallel Haskell -} +isSuperDictSelId_maybe other_id = Nothing + +isWorkerId (Id _ _ _ (WorkerId _)) = True +#ifdef DPH +isWorkerId (PodId _ _ id) = isWorkerId id +#endif {- Data Parallel Haskell -} +isWorkerId other = False + +isWrapperId id = workerExists (getIdStrictness id) +\end{code} + +\begin{code} +pprIdInUnfolding :: IdSet -> Id -> Pretty + +pprIdInUnfolding in_scopes v + = let + v_ty = getIdUniType v + in + -- local vars first: + if v `elementOfUniqSet` in_scopes then + pprUnique (getTheUnique v) + + -- ubiquitous Ids with special syntax: + else if v == nilDataCon then + ppPStr SLIT("_NIL_") + else if isTupleCon v then + ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v)) + + -- ones to think about: + else + let + (Id _ _ _ v_details) = v + in + case v_details of + -- these ones must have been exported by their original module + ImportedId _ -> pp_full_name + PreludeId _ -> pp_full_name + + -- these ones' exportedness checked later... + TopLevId _ -> pp_full_name + DataConId _ _ _ _ _ _ -> pp_full_name + + -- class-ish things: class already recorded as "mentioned" + SuperDictSelId c sc + -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc] + ClassOpId c o + -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o] + DefaultMethodId c o _ + -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o] + + -- instance-ish things: should we try to figure out + -- *exactly* which extra instances have to be exported? (ToDo) + DictFunId c t _ + -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t] + ConstMethodId c t o _ + -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t] + + -- specialisations and workers + SpecId unspec ty_maybes _ + -> let + pp = pprIdInUnfolding in_scopes unspec + in + ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack, + ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes), + ppRbrack] + + WorkerId unwrkr + -> let + pp = pprIdInUnfolding in_scopes unwrkr + in + ppBeside (ppPStr SLIT("_WRKR_ ")) pp + + -- anything else? we're nae interested + other_id -> panic "pprIdInUnfolding:mystery Id" + where + ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding") + + pp_full_name + = let + (m_str, n_str) = getOrigName v + + pp_n = + if isAvarop n_str || isAconop n_str then + ppBesides [ppLparen, ppPStr n_str, ppRparen] + else + ppPStr n_str + in + if fromPreludeCore v then + pp_n + else + ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n] + + pp_class :: Class -> Pretty + pp_class_op :: ClassOp -> Pretty + pp_type :: UniType -> Pretty + pp_ty_maybe :: Maybe UniType -> Pretty + + pp_class clas = ppr ppr_Unfolding clas + pp_class_op op = ppr ppr_Unfolding op + + pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen] + + pp_ty_maybe Nothing = ppPStr SLIT("_N_") + pp_ty_maybe (Just t) = pp_type t +\end{code} + +@whatsMentionedInId@ ferrets out the types/classes/instances on which +this @Id@ depends. If this Id is to appear in an interface, then +those entities had Jolly Well be in scope. Someone else up the +call-tree decides that. + +\begin{code} +whatsMentionedInId + :: IdSet -- Ids known to be in scope + -> Id -- Id being processed + -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc. + +whatsMentionedInId in_scopes v + = let + v_ty = getIdUniType v + + (tycons, clss) + = getMentionedTyConsAndClassesFromUniType v_ty + + result0 id_bag = (id_bag, tycons, clss) + + result1 ids tcs cs + = (ids `unionBags` unitBag v, -- we add v to "mentioned"... + tcs `unionBags` tycons, + cs `unionBags` clss) + in + -- local vars first: + if v `elementOfUniqSet` in_scopes then + result0 emptyBag -- v not added to "mentioned" + + -- ones to think about: + else + let + (Id _ _ _ v_details) = v + in + case v_details of + -- specialisations and workers + SpecId unspec ty_maybes _ + -> let + (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec + in + result1 ids2 tcs2 cs2 + + WorkerId unwrkr + -> let + (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr + in + result1 ids2 tcs2 cs2 + + anything_else -> result0 (unitBag v) -- v is added to "mentioned" +\end{code} + +Tell them who my wrapper function is. +\begin{code} +myWrapperMaybe :: Id -> Maybe Id + +myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper)) = Just my_wrapper +myWrapperMaybe other_id = Nothing +\end{code} + +\begin{code} +unfoldingUnfriendlyId -- return True iff it is definitely a bad + :: Id -- idea to export an unfolding that + -> Bool -- mentions this Id. Reason: it cannot + -- possibly be seen in another module. + +unfoldingUnfriendlyId id + | not (externallyVisibleId id) -- that settles that... + = True + +unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper)) + = class_thing wrapper + where + -- "class thing": If we're going to use this worker Id in + -- an interface, we *have* to be able to untangle the wrapper's + -- strictness when reading it back in. At the moment, this + -- is not always possible: in precisely those cases where + -- we pass tcGenPragmas a "Nothing" for its "ty_maybe". + + class_thing (Id _ _ _ (SuperDictSelId _ _)) = True + class_thing (Id _ _ _ (ClassOpId _ _)) = True + class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True + class_thing other = False + +unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _)) + -- a SPEC of a DictFunId can end up w/ gratuitous + -- TyVar(Templates) in the i/face; only a problem + -- if -fshow-pragma-name-errs; but we can do without the pain. + -- A HACK in any case (WDP 94/05/02) + = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( + naughty_DictFunId dfun + --) + +unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _)) + = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) ( + naughty_DictFunId dfun -- similar deal... + --) + +unfoldingUnfriendlyId other_id = False -- is friendly in all other cases + +naughty_DictFunId :: IdDetails -> Bool + -- True <=> has a TyVar(Template) in the "type" part of its "name" + +naughty_DictFunId (DictFunId _ _ False) = False -- came from outside; must be OK +naughty_DictFunId (DictFunId _ ty _) + = not (isGroundTy ty) +\end{code} + +@externallyVisibleId@: is it true that another module might be +able to ``see'' this Id? + +We need the @toplevelishId@ check as well as @isExported@ for when we +compile instance declarations in the prelude. @DictFunIds@ are +``exported'' if either their class or tycon is exported, but, in +compiling the prelude, the compiler may not recognise that as true. + +\begin{code} +externallyVisibleId :: Id -> Bool + +externallyVisibleId id@(Id _ _ _ details) + = if isLocallyDefined id then + toplevelishId id && isExported id && not (weird_datacon details) + else + not (weird_tuplecon details) + -- if visible here, it must be visible elsewhere, too. + where + -- If it's a DataCon, it's not enough to know it (meaning + -- its TyCon) is exported; we need to know that it might + -- be visible outside. Consider: + -- + -- data Foo a = Mumble | BigFoo a WeirdLocalType + -- + -- We can't tell the outside world *anything* about Foo, because + -- of WeirdLocalType; but we need to know this when asked if + -- "Mumble" is externally visible... + + 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 + = case (getIdUnfolding id) of + IWantToBeINLINEd _ -> True + _ -> False +\end{code} + +For @unlocaliseId@: See the brief commentary in +\tr{simplStg/SimplStg.lhs}. + +\begin{code} +unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id + +unlocaliseId mod (Id u ty info (TopLevId fn)) + = Just (Id u ty info (TopLevId (unlocaliseFullName fn))) + +unlocaliseId mod (Id u ty info (LocalId sn no_ftvs)) + = --false?: ASSERT(no_ftvs) + let + full_name = unlocaliseShortName mod u sn + in + Just (Id u ty info (TopLevId full_name)) + +unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs)) + = --false?: on PreludeGlaST: ASSERT(no_ftvs) + let + full_name = unlocaliseShortName mod u sn + in + Just (Id u ty info (TopLevId full_name)) + +unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs)) + = case unlocalise_parent mod u unspec of + Nothing -> Nothing + Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs)) + +unlocaliseId mod (Id u ty info (WorkerId unwrkr)) + = case unlocalise_parent mod u unwrkr of + Nothing -> Nothing + Just xx -> Just (Id u ty info (WorkerId xx)) + +unlocaliseId mod (Id u ty info (InstId inst)) + = Just (Id u ty info (TopLevId full_name)) + -- type might be wrong, but it hardly matters + -- at this stage (just before printing C) ToDo + where + name = let (bit1:bits) = getInstNamePieces True inst in + _CONCAT_ (bit1 : [ _CONS_ '.' b | b <- bits ]) + + full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc + +#ifdef DPH +unlocaliseId mod (PodId dim ity id) + = case (unlocaliseId mod id) of + Just id' -> Just (PodId dim ity id') + Nothing -> Nothing +#endif {- Data Parallel Haskell -} + +unlocaliseId mod other_id = Nothing + +-------------------- +-- we have to be Very Careful for workers/specs of +-- local functions! + +unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs)) + = --false?: ASSERT(no_ftvs) + let + full_name = unlocaliseShortName mod uniq sn + in + Just (Id uniq ty info (TopLevId full_name)) + +unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs)) + = --false?: ASSERT(no_ftvs) + let + full_name = unlocaliseShortName mod uniq sn + in + Just (Id uniq ty info (TopLevId full_name)) + +unlocalise_parent mod uniq other_id = unlocaliseId mod other_id + -- we're OK otherwise +\end{code} + +CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: +`Top-levelish Ids'' cannot have any free type variables, so applying +the type-env cannot have any effect. (NB: checked in CoreLint?) + +The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the +former ``should be'' the usual crunch point. + +\begin{code} +applyTypeEnvToId :: TypeEnv -> Id -> Id + +applyTypeEnvToId type_env id@(Id u ty info details) + | idHasNoFreeTyVars id + = id + | otherwise + = apply_to_Id ( \ ty -> + applyTypeEnvToTy type_env ty + ) id +\end{code} + +\begin{code} +apply_to_Id :: (UniType -> UniType) + -> 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) + 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???? + where + apply_to_maybe Nothing = Nothing + apply_to_maybe (Just ty) = Just (ty_fn ty) + + apply_to_details (WorkerId unwrkr) + = let + new_unwrkr = apply_to_Id ty_fn unwrkr + in + WorkerId new_unwrkr + +#ifdef DPH + apply_to_details (PodId d ity id ) + = PodId d ity (apply_to_Id ty_fn id) +#endif {- Data Parallel Haskell -} + + apply_to_details other = other +\end{code} + +Sadly, I don't think the one using the magic typechecker substitution +can be done with @apply_to_Id@. Here we go.... + +Strictness is very important here. We can't leave behind thunks +with pointers to the substitution: it {\em must} be single-threaded. + +\begin{code} +applySubstToId :: Subst -> Id -> (Subst, Id) + +applySubstToId subst id@(Id u ty info details) + -- *cannot* have a "idHasNoFreeTyVars" get-out clause + -- because, in the typechecker, we are still + -- *concocting* the types. + = case (applySubstToTy subst ty) of { (s2, new_ty) -> + case (applySubstToIdInfo s2 info) of { (s3, new_info) -> + 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) + = case (applySubstToInst subst inst) of { (s2, new_inst) -> + (s2, InstId new_inst) } + + apply_to_details subst new_ty (SpecId unspec ty_maybes _) + = case (applySubstToId subst unspec) of { (s2, new_unspec) -> + case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) -> + (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }} + -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04) + where + apply_to_maybe subst Nothing = (subst, Nothing) + apply_to_maybe subst (Just ty) + = case (applySubstToTy subst ty) of { (s2, new_ty) -> + (s2, Just new_ty) } + + apply_to_details subst _ (WorkerId unwrkr) + = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) -> + (s2, WorkerId new_unwrkr) } + + apply_to_details subst _ other = (subst, other) + +#ifdef DPH +applySubstToId (PodId d ity id ) + = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id)) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING] + +getIdNamePieces show_uniqs (Id u ty info details) + = case details of + DataConId n _ _ _ _ _ -> + case (getOrigName n) of { (mod, name) -> + if fromPrelude mod then [name] else [mod, name] } + + TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))] + + ImportedId n -> get_fullname_pieces n + PreludeId n -> get_fullname_pieces n + TopLevId n -> get_fullname_pieces n + + SuperDictSelId c sc -> + case (getOrigName c) of { (c_mod, c_name) -> + case (getOrigName sc) of { (sc_mod, sc_name) -> + let + c_bits = if fromPreludeCore c + then [c_name] + else [c_mod, c_name] + + sc_bits= if fromPreludeCore sc + then [sc_name] + else [sc_mod, sc_name] + in + [SLIT("sdsel")] ++ c_bits ++ sc_bits }} + + ClassOpId clas op -> + case (getOrigName clas) of { (c_mod, c_name) -> + case (getClassOpString op) of { op_name -> + if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name] + } } + + DefaultMethodId clas op _ -> + case (getOrigName clas) of { (c_mod, c_name) -> + case (getClassOpString op) of { op_name -> + if fromPreludeCore clas + then [SLIT("defm"), op_name] + else [SLIT("defm"), c_mod, c_name, op_name] }} + + DictFunId c ty _ -> + case (getOrigName c) of { (c_mod, c_name) -> + let + c_bits = if fromPreludeCore c + then [c_name] + else [c_mod, c_name] + + ty_bits = getTypeString ty + in + [SLIT("dfun")] ++ c_bits ++ ty_bits } + + + ConstMethodId c ty o _ -> + case (getOrigName c) of { (c_mod, c_name) -> + case (getTypeString ty) of { ty_bits -> + case (getClassOpString o) of { o_name -> + case (if fromPreludeCore c + then [] + else [c_mod, c_name]) of { c_bits -> + [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}} + + -- if the unspecialised equiv is "top-level", + -- the name must be concocted from its name and the + -- names of the types to which specialised... + + SpecId unspec ty_maybes _ -> + getIdNamePieces show_uniqs unspec ++ ( + if not (toplevelishId unspec) + then [showUnique u] + else concat (map typeMaybeString ty_maybes) + ) + + WorkerId unwrkr -> + getIdNamePieces show_uniqs unwrkr ++ ( + if not (toplevelishId unwrkr) + then [showUnique u] + else [SLIT("wrk")] -- show u + ) + + InstId inst -> getInstNamePieces show_uniqs inst + LocalId n _ -> let local = getLocalName n in + if show_uniqs then [local, showUnique u] else [local] + SysLocalId n _ -> [getLocalName n, showUnique u] + SpecPragmaId n _ _ -> [getLocalName n, showUnique u] + +#ifdef DPH + ProcessorCon a _ -> ["MkProcessor" ++ (show a)] + PodId n ity id -> getIdNamePieces show_uniqs id ++ + ["mapped", "POD" ++ (show n), show ity] +#endif {- Data Parallel Haskell -} + +get_fullname_pieces :: FullName -> [FAST_STRING] +get_fullname_pieces n + = BIND (getOrigName n) _TO_ (mod, name) -> + if fromPrelude mod + then [name] + else [mod, name] + BEND +\end{code} + +Really Inst-ish, but only used in this module... +\begin{code} +getInstNamePieces :: Bool -> Inst -> [FAST_STRING] + +getInstNamePieces show_uniqs (Dict u clas ty _) + = let (mod, nm) = getOrigName clas in + if fromPreludeCore clas + then [SLIT("d"), nm, showUnique u] + else [SLIT("d"), mod, nm, showUnique u] + +getInstNamePieces show_uniqs (Method u id tys _) + = let local = getIdNamePieces show_uniqs id in + if show_uniqs then local ++ [showUnique u] else local + +getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u] +\end{code} + +%************************************************************************ +%* * +\subsection[Id-type-funs]{Type-related @Id@ functions} +%* * +%************************************************************************ + +\begin{code} +getIdUniType :: Id -> UniType + +getIdUniType (Id _ ty _ _) = ty + +#ifdef DPH +-- ToDo: DPH +getIdUniType (ProcessorCon _ ty) = ty +getIdUniType (PodId d ity id) + = let (foralls,rho) = splitForalls (getIdUniType id) in + let tys = get_args rho in + let itys_mask = infoTypeNumToMask ity in + let tys' = zipWith convert tys itys_mask in + mkForallTy foralls (foldr1 mkFunTy tys') + where -- ToDo(hilly) change to use getSourceType etc... + + get_args ty = case (maybeUnpackFunTy ty) of + Nothing -> [ty] + Just (arg,res) -> arg:get_args res + + convert ty cond = if cond + then ty + else (coerce ty) + + coerce ty = case (maybeUnpackFunTy ty) of + Nothing ->mkPodizedPodNTy d ty + Just (arg,res) ->mkFunTy (coerce arg) (coerce res) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class) + +getMentionedTyConsAndClassesFromId id + = getMentionedTyConsAndClassesFromUniType (getIdUniType id) +\end{code} + +\begin{code} +getIdKind i = kindFromType (getIdUniType i) +\end{code} + +\begin{code} +{- NOT USED +getIdTauType :: Id -> TauType +getIdTauType i = expandTySyn (getTauType (getIdUniType i)) + +getIdSourceTypes :: Id -> [TauType] +getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i))) + +getIdTargetType :: Id -> TauType +getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i))) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[Id-overloading]{Functions related to overloading} +%* * +%************************************************************************ + +\begin{code} +mkSuperDictSelId u c sc ty info = Id u ty info (SuperDictSelId c sc) +mkClassOpId u c op ty info = Id u ty info (ClassOpId c op) +mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen) + +mkDictFunId u c ity full_ty from_here info + = Id u full_ty info (DictFunId c ity from_here) + +mkConstMethodId u c op ity full_ty from_here info + = Id u full_ty info (ConstMethodId c ity op from_here) + +mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr) + +mkInstId inst + = Id u (getInstUniType inst) noIdInfo (InstId inst) + where + u = case inst of + Dict u c t o -> u + Method u i ts o -> u + LitInst u l ty o -> u + +{- UNUSED: +getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class)) + = (input_class, result_class) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[local-funs]{@LocalId@-related functions} +%* * +%************************************************************************ + +\begin{code} +mkImported u n ty info = Id u ty info (ImportedId n) +mkPreludeId u n ty info = Id u ty info (PreludeId n) + +#ifdef DPH +mkPodId d i = PodId d i +#endif + +updateIdType :: Id -> UniType -> Id +updateIdType (Id u _ info details) ty = Id u ty info details +\end{code} + +\begin{code} +no_free_tvs ty = null (extractTyVarsFromTy ty) + +-- SysLocal: for an Id being created by the compiler out of thin air... +-- UserLocal: an Id with a name the user might recognize... +mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> UniType -> SrcLoc -> Id + +mkSysLocal str uniq ty loc + = Id uniq ty noIdInfo (SysLocalId (mkShortName str loc) (no_free_tvs ty)) + +mkUserLocal str uniq ty loc + = Id uniq ty noIdInfo (LocalId (mkShortName str loc) (no_free_tvs ty)) + +-- for an SpecPragmaId being created by the compiler out of thin air... +mkSpecPragmaId :: FAST_STRING -> Unique -> UniType -> Maybe SpecInfo -> SrcLoc -> Id +mkSpecPragmaId str uniq ty specinfo loc + = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specinfo (no_free_tvs ty)) + +-- for new SpecId +mkSpecId u unspec ty_maybes ty info + = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) + Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty)) + +-- Specialised version of constructor: only used in STG and code generation +-- Note: The specialsied Id has the same unique as the unspeced Id + +mkSameSpecCon ty_maybes unspec@(Id u ty info details) + = ASSERT(isDataCon unspec) + ASSERT(not (maybeToBool (isSpecId_maybe unspec))) + Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty)) + where + new_ty = specialiseTy ty ty_maybes 0 + + -- pprTrace "SameSpecCon:Unique:" + -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes])) + +-- mkId builds a local or top-level Id, depending on the name given +mkId :: Name -> UniType -> IdInfo -> Id +mkId (Short uniq short) ty info = Id uniq ty info (LocalId short (no_free_tvs ty)) +mkId (OtherTopId uniq full) ty info + = Id uniq ty info + (if isLocallyDefined full then TopLevId full else ImportedId full) + +localiseId :: Id -> Id +localiseId id@(Id u ty info details) + = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty)) + 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 + = let + new_details + = case details of + InstId (Dict _ c t o) -> InstId (Dict uniq c t o) + InstId (Method _ i ts o) -> InstId (Method uniq i ts o) + InstId (LitInst _ l ty o) -> InstId (LitInst uniq l ty o) + old_details -> old_details + in + Id uniq ty info new_details + +#ifdef DPH +mkIdWithNewUniq (PodId d t id) uniq = PodId d t (mkIdWithNewUniq id uniq) +#endif {- Data Parallel Haskell -} +\end{code} + +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +\begin{code} +mkTemplateLocals :: [UniType] -> [Id] +mkTemplateLocals tys + = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkUnknownSrcLoc) + (getBuiltinUniques (length tys)) + tys +\end{code} + +\begin{code} +getIdInfo :: Id -> IdInfo + +getIdInfo (Id _ _ info _) = info + +#ifdef DPH +getIdInfo (PodId _ _ id) = getIdInfo id +#endif {- Data Parallel Haskell -} + +replaceIdInfo :: Id -> IdInfo -> Id + +replaceIdInfo (Id u ty _ details) info = Id u ty info details + +#ifdef DPH +replaceIdInfo (PodId dim ity id) info = PodId dim ity (replaceIdInfo id info) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[Id-arities]{Arity-related functions} +%* * +%************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) + +\begin{code} +getIdArity :: Id -> ArityInfo +getDataConArity :: DataCon -> Int -- a simpler i/face; they always have arities + +#ifdef DPH +getIdArity (ProcessorCon n _) = mkArityInfo n +getIdArity (PodId _ _ id) = getIdArity id +#endif {- Data Parallel Haskell -} + +getIdArity (Id _ _ id_info _) = getInfo id_info + +getDataConArity id@(Id _ _ id_info _) + = ASSERT(isDataCon id) + case (arityMaybe (getInfo id_info)) of + Nothing -> pprPanic "getDataConArity:Nothing:" (ppr PprDebug id) + Just i -> i + +addIdArity :: Id -> Int -> Id +addIdArity (Id u ty info details) arity + = Id u ty (info `addInfo` (mkArityInfo arity)) details +\end{code} + +%************************************************************************ +%* * +\subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)} +%* * +%************************************************************************ + +\begin{code} +mkDataCon :: Unique{-DataConKey-} -> FullName -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id + -- can get the tag and all the pieces of the type from the UniType + +mkDataCon k n tyvar_tmpls context args_tys tycon specenv = data_con + where + data_con = Id k type_of_constructor datacon_info + (DataConId n + (position_within fIRST_TAG data_con_family data_con) + tyvar_tmpls context args_tys tycon) + + -- Note data_con self-recursion; + -- should be OK as tags are not looked at until + -- late in the game. + + data_con_family = getTyConDataCons tycon + + position_within :: Int -> [Id] -> Id -> Int + position_within acc [] con + = panic "mkDataCon: con not found in family" + + position_within acc (c:cs) con + = if c `eqId` con then acc else position_within (acc+(1::Int)) cs con + + type_of_constructor = mkSigmaTy tyvar_tmpls context + (glueTyArgs + args_tys + (applyTyCon tycon (map mkTyVarTemplateTy tyvar_tmpls))) + + datacon_info = noIdInfo `addInfo_UF` unfolding + `addInfo` mkArityInfo arity + `addInfo` specenv + + arity = length args_tys + + unfolding + = -- if arity == 0 + -- then noIdInfo + -- else -- do some business... + let + (tyvars, dict_vars, vars) = mk_uf_bits tyvar_tmpls context args_tys tycon + tyvar_tys = map mkTyVarTy tyvars + in + BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon -> + + BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon -> + + mkUnfolding EssentialUnfolding -- for data constructors + (foldr CoTyLam lambdized_CoCon tyvars) + BEND BEND + + mk_uf_bits tyvar_tmpls context arg_tys tycon + = let + (inst_env, tyvars, tyvar_tys) + = instantiateTyVarTemplates tyvar_tmpls + (map getTheUnique tyvar_tmpls) + in + -- the "context" and "arg_tys" have TyVarTemplates in them, so + -- we instantiate those types to have the right TyVars in them + -- instead. + BIND (map (instantiateTauTy inst_env) (map ctxt_ty context)) + _TO_ inst_dict_tys -> + BIND (map (instantiateTauTy inst_env) arg_tys) _TO_ inst_arg_tys -> + + -- We can only have **ONE** call to mkTemplateLocals here; + -- otherwise, we get two blobs of locals w/ mixed-up Uniques + -- (Mega-Sigh) [ToDo] + BIND (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) _TO_ all_vars -> + + BIND (splitAt (length context) all_vars) _TO_ (dict_vars, vars) -> + + (tyvars, dict_vars, vars) + BEND BEND BEND BEND + where + -- these are really dubious UniTypes, but they are only to make the + -- binders for the lambdas for tossed-away dicts. + ctxt_ty (clas, ty) = mkDictTy clas ty +\end{code} + +\begin{code} +mkTupleCon :: Arity -> Id + +mkTupleCon arity = data_con + where + data_con = Id unique ty tuplecon_info (TupleConId arity) + unique = mkTupleDataConUnique arity + ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys)) + tycon = mkTupleTyCon arity + tyvars = take arity alphaTyVars + tyvar_tys = map mkTyVarTemplateTy tyvars + + tuplecon_info + = noIdInfo `addInfo_UF` unfolding + `addInfo` mkArityInfo arity + `addInfo` tuplecon_specenv + + tuplecon_specenv + = if arity == 2 then + pcGenerateDataSpecs ty + else + nullSpecEnv + + unfolding + = -- if arity == 0 + -- then noIdInfo + -- else -- do some business... + let + (tyvars, dict_vars, vars) = mk_uf_bits arity + tyvar_tys = map mkTyVarTy tyvars + in + BIND (CoCon data_con tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon -> + + BIND (mkCoLam (dict_vars ++ vars) plain_CoCon) _TO_ lambdized_CoCon -> + + mkUnfolding + EssentialUnfolding -- data constructors + (foldr CoTyLam lambdized_CoCon tyvars) + BEND BEND + + mk_uf_bits arity + = BIND (mkTemplateLocals tyvar_tys) _TO_ vars -> + (tyvars, [], vars) + BEND + where + tyvar_tmpls = take arity alphaTyVars + (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls) + + +#ifdef DPH +mkProcessorCon :: Arity -> Id +mkProcessorCon arity + = ProcessorCon arity ty + where + ty = mkSigmaTy tyvars [] (glueTyArgs tyvar_tys (applyTyCon tycon tyvar_tys)) + tycon = mkProcessorTyCon arity + tyvars = take arity alphaTyVars + tyvar_tys = map mkTyVarTemplateTy tyvars +#endif {- Data Parallel Haskell -} + +fIRST_TAG :: ConTag +fIRST_TAG = 1 -- Tags allocated from here for real constructors + +-- given one data constructor in a family, return a list +-- of all the data constructors in that family. + +#ifdef DPH +getDataConFamily :: DataCon -> [DataCon] + +getDataConFamily data_con + = ASSERT(isDataCon data_con) + getTyConDataCons (getDataConTyCon data_con) +#endif +\end{code} + +\begin{code} +getDataConTag :: DataCon -> ConTag -- will panic if not a DataCon + +getDataConTag (Id _ _ _ (DataConId _ tag _ _ _ _)) = tag +getDataConTag (Id _ _ _ (TupleConId _)) = fIRST_TAG +getDataConTag (Id _ _ _ (SpecId unspec _ _)) = getDataConTag unspec +#ifdef DPH +getDataConTag (ProcessorCon _ _) = fIRST_TAG +#endif {- Data Parallel Haskell -} + +getDataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon + +getDataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ tycon)) = tycon +getDataConTyCon (Id _ _ _ (TupleConId a)) = mkTupleTyCon a +getDataConTyCon (Id _ _ _ (SpecId unspec tys _)) = mkSpecTyCon (getDataConTyCon unspec) tys +#ifdef DPH +getDataConTyCon (ProcessorCon a _) = mkProcessorTyCon a +#endif {- Data Parallel Haskell -} + +getDataConSig :: DataCon -> ([TyVarTemplate], ThetaType, [TauType], TyCon) + -- will panic if not a DataCon + +getDataConSig (Id _ _ _ (DataConId _ _ tyvars theta_ty arg_tys tycon)) + = (tyvars, theta_ty, arg_tys, tycon) + +getDataConSig (Id _ _ _ (TupleConId arity)) + = (tyvars, [], tyvar_tys, mkTupleTyCon arity) + where + tyvars = take arity alphaTyVars + tyvar_tys = map mkTyVarTemplateTy tyvars + +getDataConSig (Id _ _ _ (SpecId unspec ty_maybes _)) + = (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon) + where + (tyvars, theta_ty, arg_tys, tycon) = getDataConSig unspec + + ty_env = tyvars `zip` ty_maybes + + spec_tyvars = foldr nothing_tyvars [] ty_env + nothing_tyvars (tyvar, Nothing) l = tyvar : l + nothing_tyvars (tyvar, Just ty) l = l + + spec_env = foldr just_env [] ty_env + just_env (tyvar, Nothing) l = l + just_env (tyvar, Just ty) l = (tyvar, ty) : l + spec_arg_tys = map (instantiateTauTy spec_env) arg_tys + + spec_theta_ty = if null theta_ty then [] + else panic "getDataConSig:ThetaTy:SpecDataCon" + spec_tycon = mkSpecTyCon tycon ty_maybes + +#ifdef DPH +getDataConSig (ProcessorCon arity _) + = (tyvars, [], tyvar_tys, mkProcessorTyCon arity) + where + tyvars = take arity alphaTyVars + tyvar_tys = map mkTyVarTemplateTy tyvars +#endif {- Data Parallel Haskell -} +\end{code} + +@getInstantiatedDataConSig@ takes a constructor and some types to which +it is applied; it returns its signature instantiated to these types. + +\begin{code} +getInstantiatedDataConSig :: + DataCon -- The data constructor + -- Not a specialised data constructor + -> [TauType] -- Types to which applied + -- Must be fully applied i.e. contain all types of tycon + -> ([TauType], -- Types of dict args + [TauType], -- Types of regular args + TauType -- Type of result + ) + +getInstantiatedDataConSig data_con tycon_arg_tys + = ASSERT(isDataCon data_con) + --false?? WDP 95/06: ASSERT(not (maybeToBool (isSpecId_maybe data_con))) + let + (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) = getDataConSig data_con + + inst_env = --ASSERT(length tv_tmpls == length tycon_arg_tys) +{- if (length tv_tmpls /= length tycon_arg_tys) then + pprPanic "Id:1666:" (ppCat [ppr PprShowAll data_con, ppr PprDebug tycon_arg_tys]) + else +-} tv_tmpls `zip` tycon_arg_tys + + theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ] + cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls + result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys) + in + -- Are the first/third results ever used? + (theta_tys, cmpnt_tys, result_ty) + +{- UNUSED: allows a specilaised constructor to be instantiated + (with all argument types of the unspecialsied tycon) + +getInstantiatedDataConSig data_con tycon_arg_tys + = ASSERT(isDataCon data_con) + if is_speccon && arg_tys_match_error then + pprPanic "getInstantiatedDataConSig:SpecId:" + (ppHang (ppr PprDebug data_con) 4 pp_match_error) + else + (theta_tys, cmpnt_tys, result_ty) -- Are the first/third results ever used? + where + is_speccon = maybeToBool is_speccon_maybe + is_speccon_maybe = isSpecId_maybe data_con + Just (unspec_con, spec_tys) = is_speccon_maybe + + arg_tys_match_error = maybeToBool match_error_maybe + match_error_maybe = ASSERT(length spec_tys == length tycon_arg_tys) + argTysMatchSpecTys spec_tys tycon_arg_tys + (Just pp_match_error) = match_error_maybe + + (tv_tmpls, theta, cmpnt_ty_tmpls, tycon) + = if is_speccon + then getDataConSig unspec_con + else getDataConSig data_con + + inst_env = ASSERT(length tv_tmpls == length tycon_arg_tys) + tv_tmpls `zip` tycon_arg_tys + + theta_tys = [ instantiateTauTy inst_env (mkDictTy c t) | (c,t) <- theta ] + cmpnt_tys = map (instantiateTauTy inst_env) cmpnt_ty_tmpls + result_ty = instantiateTauTy inst_env (applyTyCon tycon tycon_arg_tys) +-} +\end{code} + +The function @getDataConDeps@ is passed an @Id@ representing a data +constructor of some type. We look at the source types of the +constructor and create the set of all @TyCons@ referred to directly +from the source types. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +getDataConDeps :: Id -> [TyCon] + +getDataConDeps (Id _ _ _ (DataConId _ _ _ _ arg_tys _)) + = concat (map getReferredToTyCons arg_tys) +getDataConDeps (Id _ _ _ (TupleConId _)) = [] +getDataConDeps (Id _ _ _ (SpecId unspec ty_maybes _)) + = getDataConDeps unspec ++ concat (map getReferredToTyCons (catMaybes ty_maybes)) +#ifdef DPH +getDataConDeps (ProcessorCon _ _) = [] +#endif {- Data Parallel Haskell -} +#endif {- Semantique strictness analyser -} +\end{code} + +Data type declarations are of the form: +\begin{verbatim} +data Foo a b = C1 ... | C2 ... | ... | Cn ... +\end{verbatim} +For each constructor @Ci@, we want to generate a curried function; so, e.g., for +@C1 x y z@, we want a function binding: +\begin{verbatim} +fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> CoCon C1 [a, b] [x, y, z] +\end{verbatim} +Notice the ``big lambdas'' and type arguments to @CoCon@---we are producing +2nd-order polymorphic lambda calculus with explicit types. + +%************************************************************************ +%* * +\subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings} +%* * +%************************************************************************ + +@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case) +and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and +@TyVars@ don't really have to be new, because we are only producing a +template. + +ToDo: what if @DataConId@'s type has a context (haven't thought about it +--WDP)? + +Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT +EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the +example above: a, b, and x, y, z], which is enough (in the important +\tr{DsExpr} case). (The middle set of @Ids@ is binders for any +dictionaries, in the even of an overloaded data-constructor---none at +present.) + +\begin{code} +getIdUnfolding :: Id -> UnfoldingDetails + +#ifdef DPH +getIdUnfolding dcon@(ProcessorCon arity _) + = let + (tyvars, dict_vars, vars) = getDataConUnfolding dcon + tyvar_tys = map mkTyVarTy tyvars + in + BIND (CoCon dcon tyvar_tys [CoVarAtom v | v <- vars]) _TO_ plain_CoCon -> + BIND (mkCoLam vars plain_CoCon) _TO_ lambdized_CoCon -> + mkUnfoldTemplate (\x->False){-ToDo-} EssentialUnfolding{-ToDo???DPH-} (foldr CoTyLam lambdized_CoCon tyvars) + BEND BEND + +-- If we have a PodId whose ``id'' has an unfolding, then we need to +-- parallelize the unfolded expression for the d^th dimension. +{- +getIdUnfolding (PodId d _ id) + = case (unfoldingMaybe (getIdUnfolding id)) of + Nothing -> noInfo + Just expr -> trace ("getIdUnfolding ("++ + ppShow 80 (ppr PprDebug id) ++ + ") for " ++ show d ++ "D pod") + (podizeTemplateExpr d expr) +-} +#endif {- Data Parallel Haskell -} + +getIdUnfolding (Id _ _ id_info _) = getInfo_UF id_info + +addIdUnfolding :: Id -> UnfoldingDetails -> Id +addIdUnfolding id@(Id u ty info details) unfold_details + = ASSERT( + case (isLocallyDefined id, unfold_details) of + (_, NoUnfoldingDetails) -> True + (True, IWantToBeINLINEd _) -> True + (False, IWantToBeINLINEd _) -> False -- v bad + (False, _) -> True + _ -> False -- v bad + ) + Id u ty (info `addInfo_UF` unfold_details) details + +{- UNUSED: +clearIdUnfolding :: Id -> Id +clearIdUnfolding (Id u ty info details) = Id u ty (clearInfo_UF info) details +-} +\end{code} + +In generating selector functions (take a dictionary, give back one +component...), we need to what out for the nothing-to-select cases (in +which case the ``selector'' is just an identity function): +\begin{verbatim} +class Eq a => Foo a { } # the superdict selector for "Eq" + +class Foo a { op :: Complex b => c -> b -> a } + # the method selector for "op"; + # note local polymorphism... +\end{verbatim} + +For data constructors, we make an unfolding which has a bunch of +lambdas to bind the arguments, with a (saturated) @CoCon@ inside. In +the case of overloaded constructors, the dictionaries are just thrown +away; they were only required in the first place to ensure that the +type was indeed an instance of the required class. +\begin{code} +#ifdef DPH +getDataConUnfolding :: Id -> ([TyVar], [Id], [Id]) + +getDataConUnfolding dcon@(ProcessorCon arity _) + = BIND (mkTemplateLocals tyvar_tys) _TO_ vars -> + (tyvars, [], vars) + BEND + where + tyvar_tmpls = take arity alphaTyVars + (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getTheUnique tyvar_tmpls) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[IdInfo-funs]{Functions related to @Ids@' @IdInfos@} +%* * +%************************************************************************ + +\begin{code} +getIdDemandInfo :: Id -> DemandInfo +getIdDemandInfo (Id _ _ info _) = getInfo info + +addIdDemandInfo :: Id -> DemandInfo -> Id +addIdDemandInfo (Id u ty info details) demand_info + = Id u ty (info `addInfo` demand_info) details +\end{code} + +\begin{code} +getIdUpdateInfo :: Id -> UpdateInfo +getIdUpdateInfo (Id u ty info details) = getInfo info + +addIdUpdateInfo :: Id -> UpdateInfo -> Id +addIdUpdateInfo (Id u ty info details) upd_info + = Id u ty (info `addInfo` upd_info) details +\end{code} + +\begin{code} +getIdArgUsageInfo :: Id -> ArgUsageInfo +getIdArgUsageInfo (Id u ty info details) = getInfo info + +addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id +addIdArgUsageInfo (Id u ty info details) au_info + = Id u ty (info `addInfo` au_info) details +\end{code} + +\begin{code} +getIdFBTypeInfo :: Id -> FBTypeInfo +getIdFBTypeInfo (Id u ty info details) = getInfo info + +addIdFBTypeInfo :: Id -> FBTypeInfo -> Id +addIdFBTypeInfo (Id u ty info details) upd_info + = Id u ty (info `addInfo` upd_info) details +\end{code} + +\begin{code} +getIdSpecialisation :: Id -> SpecEnv +getIdSpecialisation (Id _ _ info _) = getInfo info + +addIdSpecialisation :: Id -> SpecEnv -> Id +addIdSpecialisation (Id u ty info details) spec_info + = Id u ty (info `addInfo` spec_info) details +\end{code} + +Strictness: we snaffle the info out of the IdInfo. + +\begin{code} +getIdStrictness :: Id -> StrictnessInfo + +getIdStrictness (Id _ _ id_info _) = getInfo id_info + +addIdStrictness :: Id -> StrictnessInfo -> Id + +addIdStrictness (Id u ty info details) strict_info + = Id u ty (info `addInfo` strict_info) details +\end{code} + +%************************************************************************ +%* * +\subsection[Id-comparison]{Comparison functions for @Id@s} +%* * +%************************************************************************ + +Comparison: equality and ordering---this stuff gets {\em hammered}. + +\begin{code} +cmpId (Id u1 _ _ _) (Id u2 _ _ _) = cmpUnique u1 u2 +-- short and very sweet +\end{code} + +\begin{code} +eqId :: Id -> Id -> Bool + +eqId a b = case cmpId a b of { EQ_ -> True; _ -> False } + +instance Eq Id where + a == b = case cmpId a b of { EQ_ -> True; _ -> False } + a /= b = case cmpId a b of { EQ_ -> False; _ -> True } + +instance Ord Id where + a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +@cmpId_withSpecDataCon@ ensures that any spectys are taken into +account when comparing two data constructors. We need to do this +because a specialsied data constructor has the same unique as its +unspeciailsed counterpart. + +\begin{code} +cmpId_withSpecDataCon :: Id -> Id -> TAG_ + +cmpId_withSpecDataCon id1 id2 + | eq_ids && isDataCon id1 && isDataCon id2 + = cmpEqDataCon id1 id2 + + | otherwise + = cmp_ids + where + 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 unspec1 unspec2 + = EQ_ + +\end{code} + +%************************************************************************ +%* * +\subsection[Id-other-instances]{Other instance declarations for @Id@s} +%* * +%************************************************************************ + +\begin{code} +instance Outputable Id where + ppr sty id = pprId sty id + +showId :: PprStyle -> Id -> String +showId sty id = ppShow 80 (pprId sty id) + +-- [used below] +-- for DictFuns (instances) and const methods (instance code bits we +-- can call directly): exported (a) if *either* the class or +-- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both* +-- class and tycon are from PreludeCore [non-std, but convenient] +-- *and* the thing was defined in this module. + +instance_export_flag :: Class -> UniType -> Bool -> ExportFlag + +instance_export_flag clas inst_ty from_here + = if instanceIsExported clas inst_ty from_here + then ExportAll + else NotExported +\end{code} + +Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from +PreludeCore''? True if the outermost TyCon is fromPreludeCore. +\begin{code} +is_prelude_core_ty :: UniType -> Bool + +is_prelude_core_ty inst_ty + = case getUniDataTyCon_maybe inst_ty of + Just (tycon,_,_) -> fromPreludeCore tycon + Nothing -> panic "Id: is_prelude_core_ty" +\end{code} + +Default printing code (not used for interfaces): +\begin{code} +pprId :: PprStyle -> Id -> Pretty + +pprId other_sty id + = let + pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id + + for_code + = let + pieces_to_print -- maybe use Unique only + = if isSysLocalId id then tail pieces else pieces + in + ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print) + in + case other_sty of + PprForC _ -> for_code + PprForAsm _ _ _ -> for_code + PprInterface _ -> ppPStr occur_name + PprForUser -> ppPStr occur_name + PprUnfolding _ -> qualified_name pieces + PprDebug -> qualified_name pieces + PprShowAll -> ppBesides [qualified_name pieces, + (ppCat [pp_uniq id, + ppPStr SLIT("{-"), + ppr other_sty (getIdUniType id), + ppIdInfo other_sty id True (\x->x) nullIdEnv (getIdInfo id), + ppPStr SLIT("-}") ])] + where + occur_name = getOccurrenceName id _APPEND_ + ( _PK_ (if not (isSysLocalId id) + then "" + else "." ++ (_UNPK_ (showUnique (getTheUnique id))))) + + qualified_name pieces + = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id) + + pp_uniq (Id _ _ _ (PreludeId _)) = ppNil -- No uniq to add + pp_uniq (Id _ _ _ (DataConId _ _ _ _ _ _)) = ppNil -- No uniq to add + pp_uniq (Id _ _ _ (TupleConId _)) = ppNil -- No uniq to add + pp_uniq (Id _ _ _ (LocalId _ _)) = ppNil -- uniq printed elsewhere + pp_uniq (Id _ _ _ (SysLocalId _ _)) = ppNil -- ditto + pp_uniq (Id _ _ _ (SpecPragmaId _ _ _)) = ppNil -- ditto + pp_uniq (Id _ _ _ (InstId _)) = ppNil -- ditto + pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getTheUnique other_id), ppPStr SLIT("-}")] + + -- For Robin Popplestone: print PprDebug Ids with # afterwards + -- if they are of primitive type. + pp_ubxd pretty = if isPrimType (getIdUniType id) + then ppBeside pretty (ppChar '#') + else pretty +\end{code} + +\begin{code} +instance NamedThing Id where + getExportFlag (Id _ _ _ details) + = get details + where + get (DataConId _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName + get (TupleConId _) = NotExported + get (ImportedId n) = getExportFlag n + get (PreludeId n) = getExportFlag n + get (TopLevId n) = getExportFlag n + get (SuperDictSelId c _) = getExportFlag c + get (ClassOpId c _) = getExportFlag c + get (DefaultMethodId c _ _) = getExportFlag c + get (DictFunId c ty from_here) = instance_export_flag c ty from_here + get (ConstMethodId c ty _ from_here) = instance_export_flag c ty from_here + get (SpecId unspec _ _) = getExportFlag unspec + get (WorkerId unwrkr) = getExportFlag unwrkr + get (InstId _) = NotExported + get (LocalId _ _) = NotExported + get (SysLocalId _ _) = NotExported + get (SpecPragmaId _ _ _) = NotExported +#ifdef DPH + get (ProcessorCon _ _) = NotExported + get (PodId _ _ i) = getExportFlag i +#endif {- Data Parallel Haskell -} + + isLocallyDefined this_id@(Id _ _ _ details) + = get details + where + get (DataConId _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName + get (TupleConId _) = False + get (ImportedId _) = False + get (PreludeId _) = False + get (TopLevId n) = isLocallyDefined n + get (SuperDictSelId c _) = isLocallyDefined c + get (ClassOpId c _) = isLocallyDefined c + get (DefaultMethodId c _ _) = isLocallyDefined c + get (DictFunId c tyc from_here) = from_here + -- For DictFunId and ConstMethodId things, you really have to + -- know whether it came from an imported instance or one + -- really here; no matter where the tycon and class came from. + + get (ConstMethodId c tyc _ from_here) = from_here + get (SpecId unspec _ _) = isLocallyDefined unspec + get (WorkerId unwrkr) = isLocallyDefined unwrkr + get (InstId _) = True + get (LocalId _ _) = True + get (SysLocalId _ _) = True + get (SpecPragmaId _ _ _) = True +#ifdef DPH + get (ProcessorCon _ _) = False + get (PodId _ _ i) = isLocallyDefined i +#endif {- Data Parallel Haskell -} + + getOrigName this_id@(Id u _ _ details) + = get details + where + get (DataConId n _ _ _ _ _) = getOrigName n + get (TupleConId a) = (pRELUDE_BUILTIN, SLIT("Tup") _APPEND_ _PK_ (show a)) + get (ImportedId n) = getOrigName n + get (PreludeId n) = getOrigName n + get (TopLevId n) = getOrigName n + + get (ClassOpId c op) = case (getOrigName c) of -- ToDo; better ??? + (mod, _) -> (mod, getClassOpString op) + + get (SpecId unspec ty_maybes _) + = BIND getOrigName unspec _TO_ (mod, unspec_nm) -> + BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix -> + (mod, + unspec_nm _APPEND_ + (if not (toplevelishId unspec) + then showUnique u + else tys_suffix) + ) + BEND BEND + + get (WorkerId unwrkr) + = BIND getOrigName unwrkr _TO_ (mod, unwrkr_nm) -> + (mod, + unwrkr_nm _APPEND_ + (if not (toplevelishId unwrkr) + then showUnique u + else SLIT(".wrk")) + ) + BEND + + get (InstId inst) + = (panic "NamedThing.Id.getOrigName (InstId)", + BIND (getInstNamePieces True inst) _TO_ (piece1:pieces) -> + BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces -> + _CONCAT_ (piece1 : dotted_pieces) + BEND BEND ) + + get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)", + getLocalName n) + get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)", + getLocalName n) + get (SpecPragmaId n _ _)=(panic "NamedThing.Id.getOrigName (SpecPragmaId)", + getLocalName n) +#ifdef DPH + get (ProcessorCon a _) = ("PreludeBuiltin", + "MkProcessor" ++ (show a)) + get (PodId d ity id) + = BIND (getOrigName id) _TO_ (m,n) -> + (m,n ++ ".mapped.POD"++ show d ++ "." ++ show ity) + BEND + -- ToDo(hilly): should the above be using getIdNamePieces??? +#endif {- Data Parallel Haskell -} + + get other_details + -- the remaining internally-generated flavours of + -- Ids really do not have meaningful "original name" stuff, + -- but we need to make up something (usually for debugging output) + + = BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) -> + BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces -> + (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) + BEND BEND + + getOccurrenceName this_id@(Id _ _ _ details) + = get details + where + get (DataConId n _ _ _ _ _) = getOccurrenceName n + get (TupleConId a) = SLIT("Tup") _APPEND_ (_PK_ (show a)) + get (ImportedId n) = getOccurrenceName n + get (PreludeId n) = getOccurrenceName n + get (TopLevId n) = getOccurrenceName n + get (ClassOpId _ op) = getClassOpString op +#ifdef DPH + get (ProcessorCon a _) = "MkProcessor" ++ (show a) + get (PodId _ _ id) = getOccurrenceName id +#endif {- Data Parallel Haskell -} + get _ = snd (getOrigName this_id) + + getInformingModules id = panic "getInformingModule:Id" + + getSrcLoc (Id _ _ id_info details) + = get details + where + get (DataConId n _ _ _ _ _) = getSrcLoc n + get (TupleConId _) = mkBuiltinSrcLoc + get (ImportedId n) = getSrcLoc n + get (PreludeId n) = getSrcLoc n + get (TopLevId n) = getSrcLoc n + get (SuperDictSelId c _)= getSrcLoc c + get (ClassOpId c _) = getSrcLoc c + get (SpecId unspec _ _) = getSrcLoc unspec + get (WorkerId unwrkr) = getSrcLoc unwrkr + get (InstId i) = let (loc,_) = getInstOrigin i + in loc + get (LocalId n _) = getSrcLoc n + get (SysLocalId n _) = getSrcLoc n + get (SpecPragmaId n _ _)= getSrcLoc n +#ifdef DPH + get (ProcessorCon _ _) = mkBuiltinSrcLoc + get (PodId _ _ n) = getSrcLoc n +#endif {- Data Parallel Haskell -} + -- well, try the IdInfo + get something_else = getSrcLocIdInfo id_info + + getTheUnique (Id u _ _ _) = u + + fromPreludeCore (Id _ _ _ details) + = get details + where + get (DataConId _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName + get (TupleConId _) = True + get (ImportedId n) = fromPreludeCore n + get (PreludeId n) = fromPreludeCore n + get (TopLevId n) = fromPreludeCore n + get (SuperDictSelId c _) = fromPreludeCore c + get (ClassOpId c _) = fromPreludeCore c + get (DefaultMethodId c _ _) = fromPreludeCore c + get (DictFunId c t _) = fromPreludeCore c && is_prelude_core_ty t + get (ConstMethodId c t _ _) = fromPreludeCore c && is_prelude_core_ty t + get (SpecId unspec _ _) = fromPreludeCore unspec + get (WorkerId unwrkr) = fromPreludeCore unwrkr + get (InstId _) = False + get (LocalId _ _) = False + get (SysLocalId _ _) = False + get (SpecPragmaId _ _ _) = False +#ifdef DPH + get (ProcessorCon _ _) = True + get (PodId _ _ id) = fromPreludeCore id +#endif {- Data Parallel Haskell -} + + hasType id = True + getType id = getIdUniType id +\end{code} + +Reason for @getTheUnique@: The code generator doesn't carry a +@UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@ +given to it. diff --git a/ghc/compiler/basicTypes/IdInfo.hi b/ghc/compiler/basicTypes/IdInfo.hi new file mode 100644 index 0000000..9206d06 --- /dev/null +++ b/ghc/compiler/basicTypes/IdInfo.hi @@ -0,0 +1,284 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface IdInfo where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import InstEnv(InstTemplate, InstTy) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda) +import Outputable(Outputable) +import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..)) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SimplEnv(FormSummary, IdVal, InExpr(..), OutAtom(..), OutExpr(..), OutId(..), SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..)) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc, mkUnknownSrcLoc) +import Subst(Subst) +import TaggedCore(SimplifiableBinder(..), SimplifiableCoreExpr(..)) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(UniqSM(..), Unique, UniqueSupply) +class OptIdInfo a where + noInfo :: a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "U(SAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-} + getInfo :: IdInfo -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: IdInfo -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-} + addInfo :: IdInfo -> a -> IdInfo + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: IdInfo -> u0 -> IdInfo) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-} + ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-} +data ArgUsage = ArgUsage Int | UnknownArgUsage +data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-} +type ArgUsageType = [ArgUsage] +data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data DeforestInfo = Don'tDeforest | DoDeforest +data Demand = WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum +data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-} +data FBConsum = FBGoodConsum | FBBadConsum +data FBProd = FBGoodProd | FBBadProd +data FBType = FBType [FBConsum] FBProd +data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type PlainCoreAtom = CoreAtom Id +type PlainCoreExpr = CoreExpr Id Id +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data FormSummary {-# GHC_PRAGMA WhnfForm | BottomForm | OtherForm #-} +data IdVal {-# GHC_PRAGMA InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id) #-} +type InExpr = CoreExpr (Id, BinderInfo) Id +type OutAtom = CoreAtom Id +type OutExpr = CoreExpr Id Id +type OutId = Id +data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance +data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +type SimplifiableBinder = (Id, BinderInfo) +type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id +data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-} +data SpecInfo = SpecInfo [Labda UniType] Int Id +data StrictnessInfo = NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSM a = UniqueSupply -> (UniqueSupply, a) +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-} +type UpdateSpec = [Int] +addInfo_UF :: IdInfo -> UnfoldingDetails -> IdInfo + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_ #-} +addOneToSpecEnv :: SpecEnv -> SpecInfo -> SpecEnv + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(L)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +applySubstToIdInfo :: Subst -> IdInfo -> (Subst, IdInfo) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLU(S)LLLLLLL)" _N_ _N_ #-} +apply_to_IdInfo :: (UniType -> UniType) -> IdInfo -> IdInfo + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLLLLLLLL)" _N_ _N_ #-} +arityMaybe :: ArityInfo -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ArityInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo UnknownArity -> _!_ _ORIG_ Maybes Hamna [Int] []; _ORIG_ IdInfo ArityExactly (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; _NO_DEFLT_ } _N_ #-} +boringIdInfo :: IdInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SLALLLLAAA)" _N_ _N_ #-} +bottomIsGuaranteed :: StrictnessInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo BottomGuaranteed -> _!_ True [] []; (u1 :: StrictnessInfo) -> _!_ False [] [] } _N_ #-} +getArgUsage :: ArgUsageInfo -> [ArgUsage] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: ArgUsageInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo NoArgUsageInfo -> _!_ _NIL_ [ArgUsage] []; _ORIG_ IdInfo SomeArgUsageInfo (u1 :: [ArgUsage]) -> u1; _NO_DEFLT_ } _N_ #-} +getFBType :: FBTypeInfo -> Labda FBType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: FBTypeInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo NoFBTypeInfo -> _!_ _ORIG_ Maybes Hamna [FBType] []; _ORIG_ IdInfo SomeFBTypeInfo (u1 :: FBType) -> _!_ _ORIG_ Maybes Ni [FBType] [u1]; _NO_DEFLT_ } _N_ #-} +getInfo_UF :: IdInfo -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UnfoldingDetails) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u5; _NO_DEFLT_ } _N_ #-} +getSrcLocIdInfo :: IdInfo -> SrcLoc + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> ua; _NO_DEFLT_ } _N_ #-} +getWorkerId :: StrictnessInfo -> Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getWrapperArgTypeCategories :: UniType -> StrictnessInfo -> Labda [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: UnfoldingGuidance) -> _!_ _ORIG_ SimplEnv IWantToBeINLINEd [] [u0] _N_ #-} +indicatesWorker :: [Demand] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +lookupConstMethodId :: SpecEnv -> UniType -> Labda Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(S)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupSpecEnv :: SpecEnv -> [UniType] -> Labda (Id, [UniType], Int) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(S)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupSpecId :: Id -> [Labda UniType] -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLU(LLU(S)LLLLLLL)L)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkArgUsageInfo :: [ArgUsage] -> ArgUsageInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [ArgUsage]) -> _!_ _ORIG_ IdInfo SomeArgUsageInfo [] [u0] _N_ #-} +mkArityInfo :: Int -> ArityInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ IdInfo ArityExactly [] [u0] _N_ #-} +mkBottomStrictnessInfo :: StrictnessInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo BottomGuaranteed [] [] _N_ #-} +mkDemandInfo :: Demand -> DemandInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Demand) -> _!_ _ORIG_ IdInfo DemandedAsPer [] [u0] _N_ #-} +mkFBTypeInfo :: FBType -> FBTypeInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: FBType) -> _!_ _ORIG_ IdInfo SomeFBTypeInfo [] [u0] _N_ #-} +mkMagicUnfolding :: _PackedString -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkSpecEnv :: [SpecInfo] -> SpecEnv + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_ #-} +mkStrictnessInfo :: [Demand] -> Labda Id -> StrictnessInfo + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [Demand]) (u1 :: Labda Id) -> case u0 of { _ALG_ (:) (u2 :: Demand) (u3 :: [Demand]) -> _!_ _ORIG_ IdInfo StrictnessInfo [] [u0, u1]; _NIL_ -> _!_ _ORIG_ IdInfo NoStrictnessInfo [] []; _NO_DEFLT_ } _N_ #-} +mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkUnknownSrcLoc :: SrcLoc + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkUpdateInfo :: [Int] -> UpdateInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Int]) -> _!_ _ORIG_ IdInfo SomeUpdateInfo [] [u0] _N_ #-} +noIdInfo :: IdInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _ORIG_ IdInfo IdInfo [] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo noInfo (DemandInfo), _ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo noInfo (StrictnessInfo), _ORIG_ IdInfo noInfo_UF, _CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo noInfo (FBTypeInfo), _ORIG_ SrcLoc mkUnknownSrcLoc] _N_ #-} +noInfo_UF :: UnfoldingDetails + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ SimplEnv NoUnfoldingDetails [] [] _N_ #-} +nonAbsentArgs :: [Demand] -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +nullSpecEnv :: SpecEnv + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ppIdInfo :: PprStyle -> Id -> Bool -> (Id -> Id) -> UniqFM UnfoldingDetails -> IdInfo -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 6 _U_ 22122222 _N_ _S_ "LLLLLU(SLLLLLLALA)" _N_ _N_ #-} +unknownArity :: ArityInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownArity [] [] _N_ #-} +updateInfoMaybe :: UpdateInfo -> Labda [Int] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +willBeDemanded :: DemandInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +workerExists :: StrictnessInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +wwEnum :: Demand + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo WwEnum [] [] _N_ #-} +wwLazy :: Demand + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wwPrim :: Demand + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo WwPrim [] [] _N_ #-} +wwStrict :: Demand + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo WwStrict [] [] _N_ #-} +wwUnpack :: [Demand] -> Demand + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Demand]) -> _!_ _ORIG_ IdInfo WwUnpack [] [u0] _N_ #-} +instance Eq Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Demand -> Demand -> Bool), (Demand -> Demand -> Bool)] [_CONSTM_ Eq (==) (Demand), _CONSTM_ Eq (/=) (Demand)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq FBConsum + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBConsum -> FBConsum -> Bool), (FBConsum -> FBConsum -> Bool)] [_CONSTM_ Eq (==) (FBConsum), _CONSTM_ Eq (/=) (FBConsum)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq FBProd + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBProd -> FBProd -> Bool), (FBProd -> FBProd -> Bool)] [_CONSTM_ Eq (==) (FBProd), _CONSTM_ Eq (/=) (FBProd)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq FBType + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBType -> FBType -> Bool), (FBType -> FBType -> Bool)] [_CONSTM_ Eq (==) (FBType), _CONSTM_ Eq (/=) (FBType)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Eq UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool)] [_CONSTM_ Eq (==) (UpdateInfo), _CONSTM_ Eq (/=) (UpdateInfo)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance OptIdInfo ArgUsageInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArgUsageInfo, (IdInfo -> ArgUsageInfo), (IdInfo -> ArgUsageInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArgUsageInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo getInfo (ArgUsageInfo), _CONSTM_ OptIdInfo addInfo (ArgUsageInfo), _CONSTM_ OptIdInfo ppInfo (ArgUsageInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoArgUsageInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArgUsageInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u8; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo ArityInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArityInfo, (IdInfo -> ArityInfo), (IdInfo -> ArityInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArityInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo getInfo (ArityInfo), _CONSTM_ OptIdInfo addInfo (ArityInfo), _CONSTM_ OptIdInfo ppInfo (ArityInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownArity [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArityInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo DeforestInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DeforestInfo, (IdInfo -> DeforestInfo), (IdInfo -> DeforestInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DeforestInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo getInfo (DeforestInfo), _CONSTM_ OptIdInfo addInfo (DeforestInfo), _CONSTM_ OptIdInfo ppInfo (DeforestInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo Don'tDeforest [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAEAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DeforestInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u7; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)E" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAE" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo DemandInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DemandInfo, (IdInfo -> DemandInfo), (IdInfo -> DemandInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DemandInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DemandInfo), _CONSTM_ OptIdInfo getInfo (DemandInfo), _CONSTM_ OptIdInfo addInfo (DemandInfo), _CONSTM_ OptIdInfo ppInfo (DemandInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownDemand [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DemandInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LALLLLLLLL)L" _N_ _N_, + ppInfo = _A_ 3 _U_ 10122 _N_ _S_ "SAL" {_A_ 2 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo FBTypeInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [FBTypeInfo, (IdInfo -> FBTypeInfo), (IdInfo -> FBTypeInfo -> IdInfo), (PprStyle -> (Id -> Id) -> FBTypeInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (FBTypeInfo), _CONSTM_ OptIdInfo getInfo (FBTypeInfo), _CONSTM_ OptIdInfo addInfo (FBTypeInfo), _CONSTM_ OptIdInfo ppInfo (FBTypeInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoFBTypeInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: FBTypeInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u9; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20222 _N_ _S_ "SAS" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo SpecEnv + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [SpecEnv, (IdInfo -> SpecEnv), (IdInfo -> SpecEnv -> IdInfo), (PprStyle -> (Id -> Id) -> SpecEnv -> Int -> Bool -> PrettyRep)] [_ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo getInfo (SpecEnv), _CONSTM_ OptIdInfo addInfo (SpecEnv), _CONSTM_ OptIdInfo ppInfo (SpecEnv)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ IdInfo nullSpecEnv _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAU(L)AAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u3; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 11 _N_ _S_ "U(LLU(L)LLLLLLL)U(L)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLU(S)" {_A_ 3 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance OptIdInfo StrictnessInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [StrictnessInfo, (IdInfo -> StrictnessInfo), (IdInfo -> StrictnessInfo -> IdInfo), (PprStyle -> (Id -> Id) -> StrictnessInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (StrictnessInfo), _CONSTM_ OptIdInfo getInfo (StrictnessInfo), _CONSTM_ OptIdInfo addInfo (StrictnessInfo), _CONSTM_ OptIdInfo ppInfo (StrictnessInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoStrictnessInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StrictnessInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-} +instance OptIdInfo UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [UpdateInfo, (IdInfo -> UpdateInfo), (IdInfo -> UpdateInfo -> IdInfo), (PprStyle -> (Id -> Id) -> UpdateInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo getInfo (UpdateInfo), _CONSTM_ OptIdInfo addInfo (UpdateInfo), _CONSTM_ OptIdInfo ppInfo (UpdateInfo)] _N_ + noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoUpdateInfo [] [] _N_, + getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UpdateInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_, + ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Demand}}, (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Demand), (Demand -> Demand -> Demand), (Demand -> Demand -> _CMP_TAG)] [_DFUN_ Eq (Demand), _CONSTM_ Ord (<) (Demand), _CONSTM_ Ord (<=) (Demand), _CONSTM_ Ord (>=) (Demand), _CONSTM_ Ord (>) (Demand), _CONSTM_ Ord max (Demand), _CONSTM_ Ord min (Demand), _CONSTM_ Ord _tagCmp (Demand)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq UpdateInfo}}, (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> _CMP_TAG)] [_DFUN_ Eq (UpdateInfo), _CONSTM_ Ord (<) (UpdateInfo), _CONSTM_ Ord (<=) (UpdateInfo), _CONSTM_ Ord (>=) (UpdateInfo), _CONSTM_ Ord (>) (UpdateInfo), _CONSTM_ Ord max (UpdateInfo), _CONSTM_ Ord min (UpdateInfo), _CONSTM_ Ord _tagCmp (UpdateInfo)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Demand) _N_ + ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Text Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Demand, [Char])]), (Int -> Demand -> [Char] -> [Char]), ([Char] -> [([Demand], [Char])]), ([Demand] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Demand), _CONSTM_ Text showsPrec (Demand), _CONSTM_ Text readList (Demand), _CONSTM_ Text showList (Demand)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Demand, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Demand) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> Demand -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_, + readList = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + showList = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance Text UpdateInfo + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(UpdateInfo, [Char])]), (Int -> UpdateInfo -> [Char] -> [Char]), ([Char] -> [([UpdateInfo], [Char])]), ([UpdateInfo] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (UpdateInfo), _CONSTM_ Text showsPrec (UpdateInfo), _CONSTM_ Text readList (UpdateInfo), _CONSTM_ Text showList (UpdateInfo)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: UpdateInfo) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> UpdateInfo -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs new file mode 100644 index 0000000..47ce3a8 --- /dev/null +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -0,0 +1,1172 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) + +\begin{code} +#include "HsVersions.h" + +module IdInfo ( + IdInfo, -- abstract + noIdInfo, + boringIdInfo, + ppIdInfo, + applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please + + OptIdInfo(..), -- class; for convenience only, really + -- all the *Infos herein are instances of it + + -- component "id infos"; also abstract: + ArityInfo, + mkArityInfo, unknownArity, arityMaybe, + + DemandInfo, + mkDemandInfo, + willBeDemanded, + + SpecEnv, SpecInfo(..), + nullSpecEnv, mkSpecEnv, addOneToSpecEnv, + lookupSpecId, lookupSpecEnv, lookupConstMethodId, + + SrcLoc, + getSrcLocIdInfo, + + StrictnessInfo(..), -- non-abstract + Demand(..), -- non-abstract + wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, +--UNUSED: isStrict, absentArg, + indicatesWorker, nonAbsentArgs, + mkStrictnessInfo, mkBottomStrictnessInfo, + getWrapperArgTypeCategories, + getWorkerId, + workerExists, + bottomIsGuaranteed, + + UnfoldingDetails(..), -- non-abstract! re-exported + UnfoldingGuidance(..), -- non-abstract; ditto + mkUnfolding, +--OLD: mkUnfolding_NoGuideGiven, -- a convenient interface; for imported things only + iWantToBeINLINEd, mkMagicUnfolding, +--UNUSED: haveUnfolding, + noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus +--UNUSED: clearInfo_UF, + + UpdateInfo, + mkUpdateInfo, + UpdateSpec(..), + updateInfoMaybe, + + DeforestInfo(..), + + ArgUsageInfo, + ArgUsage(..), + ArgUsageType(..), + mkArgUsageInfo, + getArgUsage, + + FBTypeInfo, + FBType(..), + FBConsum(..), + FBProd(..), + mkFBTypeInfo, + getFBType, + + -- and to make the interface self-sufficient... + Bag, BasicLit, BinderInfo, CoreAtom, CoreExpr, Id, + IdEnv(..), UniqFM, Unique, IdVal, FormSummary, + InstTemplate, MagicUnfoldingFun, Maybe, UniType, UniqSM(..), + SimplifiableBinder(..), SimplifiableCoreExpr(..), + PlainCoreExpr(..), PlainCoreAtom(..), PprStyle, Pretty(..), + PrettyRep, UniqueSupply, InExpr(..), OutAtom(..), OutExpr(..), + OutId(..), Subst + + -- and to make sure pragmas work... + IF_ATTACK_PRAGMAS(COMMA mkUnknownSrcLoc) + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import AbsPrel ( mkFunTy, nilDataCon{-HACK-} + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType +import Bag ( emptyBag, Bag ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Id ( getIdUniType, getDataConSig, + getInstantiatedDataConSig, getIdInfo, + externallyVisibleId, isDataCon, + unfoldingUnfriendlyId, isWorkerId, + isWrapperId, DataCon(..) + IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToId) + IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling + ) +import IdEnv -- ( nullIdEnv, lookupIdEnv ) +import Inst ( apply_to_Inst, applySubstToInst, Inst ) +import MagicUFs +import Maybes +import Outputable +import PlainCore +import Pretty +import SimplEnv -- UnfoldingDetails(..), UnfoldingGuidance(..) +import SrcLoc +import Subst ( applySubstToTy, Subst ) +import OccurAnal ( occurAnalyseGlobalExpr ) +import TaggedCore -- SimplifiableCore* ... +import Unique +import Util +import WwLib ( mAX_WORKER_ARGS ) +\end{code} + +An @IdInfo@ gives {\em optional} information about an @Id@. If +present it never lies, but it may not be present, in which case there +is always a conservative assumption which can be made. + +Two @Id@s may have different info even though they have the same +@Unique@ (and are hence the same @Id@); for example, one might lack +the properties attached to the other. + +The @IdInfo@ gives information about the value, or definition, of the +@Id@. It does {\em not} contain information about the @Id@'s usage +(except for @DemandInfo@? ToDo). + +\begin{code} +data IdInfo + = IdInfo + ArityInfo -- Its arity + + DemandInfo -- Whether or not it is definitely + -- demanded + + SpecEnv -- Specialisations of this function which exist + + StrictnessInfo -- Strictness properties, notably + -- how to conjure up "worker" functions + + UnfoldingDetails -- Its unfolding; for locally-defined + -- things, this can *only* be NoUnfoldingDetails + -- or IWantToBeINLINEd (i.e., INLINE pragma). + + UpdateInfo -- Which args should be updated + + DeforestInfo -- Whether its definition should be + -- unfolded during deforestation + + ArgUsageInfo -- how this Id uses its arguments + + FBTypeInfo -- the Foldr/Build W/W property of this function. + + SrcLoc -- Source location of definition + + -- ToDo: SrcLoc is in FullNames too (could rm?) but it + -- is needed here too for things like ConstMethodIds and the + -- like, which don't have full-names of their own Mind you, + -- perhaps the FullName for a constant method could give the + -- class/type involved? +\end{code} + +\begin{code} +noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF + noInfo noInfo noInfo noInfo mkUnknownSrcLoc + +-- "boring" means: nothing to put an interface +boringIdInfo (IdInfo UnknownArity + UnknownDemand + nullSpecEnv + strictness + unfolding + NoUpdateInfo + Don'tDeforest + _ {- arg_usage: currently no interface effect -} + _ {- no f/b w/w -} + _ {- src_loc: no effect on interfaces-}) + | boring_strictness strictness + && boring_unfolding unfolding + = True + where + boring_strictness NoStrictnessInfo = True + boring_strictness BottomGuaranteed = False + boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args + + boring_unfolding NoUnfoldingDetails = True + boring_unfolding _ = False + +boringIdInfo _ = False + +pp_NONE = ppPStr SLIT("_N_") +\end{code} + +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 update deforest arg_usage fb_ww srcloc) + = let + new_spec = apply_spec spec + + -- NOT a good idea: + -- apply_strict strictness `thenLft` \ new_strict -> + -- apply_wrap wrap `thenLft` \ new_wrap -> + in + IdInfo arity demand + new_spec strictness unfold + update deforest arg_usage fb_ww srcloc + where + apply_spec (SpecEnv is) + = SpecEnv (map do_one is) + where + do_one (SpecInfo ty_maybes ds spec_id) + = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id -> + SpecInfo (map apply_to_maybe ty_maybes) ds spec_id + where + apply_to_maybe Nothing = Nothing + apply_to_maybe (Just ty) = Just (ty_fn ty) + +{- NOT a good idea; + apply_strict info@NoStrictnessInfo = returnLft info + apply_strict BottomGuaranteed = ??? + apply_strict (StrictnessInfo wrap_arg_info id_maybe) + = (case id_maybe of + Nothing -> returnLft Nothing + Just xx -> applySubstToId subst xx `thenLft` \ new_xx -> + returnLft (Just new_xx) + ) `thenLft` \ new_id_maybe -> + returnLft (StrictnessInfo wrap_arg_info new_id_maybe) +-} +\end{code} + +Variant of the same thing for the typechecker. +\begin{code} +applySubstToIdInfo s0 + (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc) + = case (apply_spec s0 spec) of { (s1, new_spec) -> + (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) } + where + apply_spec s0 (SpecEnv is) + = case (mapAccumL do_one s0 is) of { (s1, new_is) -> + (s1, SpecEnv new_is) } + where + do_one s0 (SpecInfo ty_maybes ds spec_id) + = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) -> + (s1, SpecInfo new_maybes ds spec_id) } + where + apply_to_maybe s0 Nothing = (s0, Nothing) + apply_to_maybe s0 (Just ty) + = case (applySubstToTy s0 ty) of { (s1, new_ty) -> + (s1, Just new_ty) } +\end{code} + +\begin{code} +ppIdInfo :: PprStyle + -> Id -- The Id for which we're printing this IdInfo + -> Bool -- True <=> print specialisations, please + -> (Id -> Id) -- to look up "better Ids" w/ better IdInfos; + -> IdEnv UnfoldingDetails + -- inlining info for top-level fns in this module + -> IdInfo -- see MkIface notes + -> Pretty + +ppIdInfo sty for_this_id specs_please better_id_fn inline_env + i@(IdInfo arity demand specialise strictness unfold update deforest arg_usage fbtype srcloc) + | boringIdInfo i + = ppPStr SLIT("_NI_") + + | otherwise + = let + stuff = ppCat [ + -- order is important!: + ppInfo sty better_id_fn arity, + ppInfo sty better_id_fn update, + ppInfo sty better_id_fn deforest, + pp_strictness sty (Just for_this_id) + better_id_fn inline_env strictness, + pp_unfolding sty for_this_id inline_env unfold, + if specs_please + then pp_specs sty (not (isDataCon for_this_id)) + better_id_fn inline_env specialise + else pp_NONE, + + -- DemandInfo needn't be printed since it has no effect on interfaces + ppInfo sty better_id_fn demand, + ppInfo sty better_id_fn fbtype + ] + in + case sty of + PprInterface sw_chker -> if sw_chker OmitInterfacePragmas + then ppNil + else stuff + _ -> stuff +\end{code} + +\begin{code} +{- OLD: +pp_info_op :: String -> Pretty -- like pprNonOp + +pp_info_op name + = if isAvarop name || isAconop name + then ppBesides [ppLparen, ppStr name, ppRparen] + else ppStr name +-} +\end{code} + +%************************************************************************ +%* * +\subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)} +%* * +%************************************************************************ + +\begin{code} +class OptIdInfo a where + noInfo :: a + getInfo :: IdInfo -> a + addInfo :: IdInfo -> a -> IdInfo + -- By default, "addInfo" will not overwrite + -- "info" with "non-info"; look at any instance + -- to see an example. + ppInfo :: PprStyle -> (Id -> Id) -> a -> Pretty +\end{code} + +%************************************************************************ +%* * +\subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@} +%* * +%************************************************************************ + +Not used much, but... +\begin{code} +getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc +\end{code} + +%************************************************************************ +%* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +%* * +%************************************************************************ + +\begin{code} +data ArityInfo + = UnknownArity -- no idea + | ArityExactly Int -- arity is exactly this +\end{code} + +\begin{code} +mkArityInfo = ArityExactly +unknownArity = UnknownArity + +arityMaybe :: ArityInfo -> Maybe Int + +arityMaybe UnknownArity = Nothing +arityMaybe (ArityExactly i) = Just i +\end{code} + +\begin{code} +instance OptIdInfo ArityInfo where + noInfo = UnknownArity + + getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity + + addInfo id_info UnknownArity = id_info + addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j + + ppInfo sty _ UnknownArity = ifPprInterface sty pp_NONE + ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity] +\end{code} + +%************************************************************************ +%* * +\subsection[demand-IdInfo]{Demand info about an @Id@} +%* * +%************************************************************************ + +Whether a value is certain to be demanded or not. (This is the +information that is computed by the ``front-end'' of the strictness +analyser.) + +This information is only used within a module, it is not exported +(obviously). + +\begin{code} +data DemandInfo + = UnknownDemand + | DemandedAsPer Demand +\end{code} + +\begin{code} +mkDemandInfo :: Demand -> DemandInfo +mkDemandInfo demand = DemandedAsPer demand + +willBeDemanded :: DemandInfo -> Bool +willBeDemanded (DemandedAsPer demand) = isStrict demand +willBeDemanded _ = False +\end{code} + +\begin{code} +instance OptIdInfo DemandInfo where + noInfo = UnknownDemand + + getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand + +{- DELETED! If this line is in, there is no way to + nuke a DemandInfo, and we have to be able to do that + when floating let-bindings around + addInfo id_info UnknownDemand = id_info +-} + addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j + + ppInfo (PprInterface _) _ _ = ppNil + ppInfo sty _ UnknownDemand = ppStr "{-# L #-}" + ppInfo sty _ (DemandedAsPer info) + = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"] +\end{code} + +%************************************************************************ +%* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +%* * +%************************************************************************ + +The details of one specialisation, held in an @Id@'s +@SpecEnv@ are as follows: +\begin{code} +data SpecInfo + = SpecInfo [Maybe UniType] -- Instance types; no free type variables in here + Int -- No. of dictionaries to eat + Id -- Specialised version +\end{code} + +For example, if \tr{f} has this @SpecInfo@: +\begin{verbatim} + SpecInfo [Just t1, Nothing, Just t3] 2 f' +\end{verbatim} +then +\begin{verbatim} + f t1 t2 t3 d1 d2 ===> f t2 +\end{verbatim} +The \tr{Nothings} identify type arguments in which the specialised +version is polymorphic. + +\begin{code} +data SpecEnv = SpecEnv [SpecInfo] + +mkSpecEnv = SpecEnv +nullSpecEnv = SpecEnv [] +addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs) + +lookupConstMethodId :: SpecEnv -> UniType -> Maybe Id + -- slight variant on "lookupSpecEnv" below + +lookupConstMethodId (SpecEnv spec_infos) spec_ty + = firstJust (map try spec_infos) + where + try (SpecInfo (Just ty:nothings) _ const_meth_id) + = ASSERT(all nothing_is_nothing nothings) + case (cmpUniType True{-properly-} ty spec_ty) of + EQ_ -> Just const_meth_id + _ -> Nothing + + nothing_is_nothing Nothing = True -- debugging only + nothing_is_nothing _ = panic "nothing_is_nothing!" + +lookupSpecId :: Id -- *un*specialised Id + -> [Maybe UniType] -- types to which it is to be specialised + -> Id -- specialised Id + +lookupSpecId unspec_id ty_maybes + = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos -> + + case (firstJust (map try spec_infos)) of + Just id -> id + Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id))) + } + where + try (SpecInfo template_maybes _ id) + | and (zipWith same template_maybes ty_maybes) + && length template_maybes == length ty_maybes = Just id + | otherwise = Nothing + + same Nothing Nothing = True + same (Just ty1) (Just ty2) = ty1 == ty2 + same _ _ = False + +lookupSpecEnv :: SpecEnv + -> [UniType] + -> Maybe (Id, + [UniType], + Int) + +lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case + +lookupSpecEnv spec_env [] = Nothing -- another common case + + -- This can happen even if there is a non-empty spec_env, because + -- of eta reduction. For example, we might have a defn + -- + -- f = /\a -> \d -> g a d + -- which gets transformed to + -- f = g + -- + -- Now g isn't applied to any arguments + +lookupSpecEnv se@(SpecEnv spec_infos) spec_tys + = select_match spec_infos + where + select_match [] -- no matching spec_infos + = Nothing + select_match (SpecInfo ty_maybes toss spec_id : rest) + = case (match ty_maybes spec_tys) of + Nothing -> select_match rest + Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest + + -- Ambiguity can only arise as a result of specialisations with + -- an explicit spec_id. The best match is deemed to be the match + -- with least polymorphism i.e. has the least number of tys left. + -- This is a non-critical approximation. The only type arguments + -- where there may be some discretion is for non-overloaded boxed + -- types. Unboxed types must be matched and we insist that we + -- always specialise on overloaded types (and discard all the dicts). + + select_next best _ toss [] + = case best of + [match] -> Just match -- Unique best match + ambig -> pprPanic "Ambiguous Specialisation:\n" + (ppAboves [ppStr "(check specialisations with explicit spec ids)", + ppCat (ppStr "between spec ids:" : + map (ppr PprDebug) [id | (id, _, _) <- ambig]), + pp_stuff]) + + select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest) + = ASSERT(dnum == toss) + case (match ty_maybes spec_tys) of + Nothing -> select_next best tnum dnum rest + Just tys_left -> + let tys_len = length tys_left in + case _tagCmp tnum tys_len of + _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match + _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match + _GT -> select_next best tnum dnum rest -- worse match + + + match [{-out of templates-}] [] = Just [] + + match (Nothing:ty_maybes) (spec_ty:spec_tys) + = case (isUnboxedDataType spec_ty) of + True -> Nothing -- Can only match boxed type against + -- type argument which has not been + -- specialised on + False -> case match ty_maybes spec_tys of + Nothing -> Nothing + Just tys -> Just (spec_ty:tys) + + match (Just ty:ty_maybes) (spec_ty:spec_tys) + = case (cmpUniType True{-properly-} ty spec_ty) of + EQ_ -> match ty_maybes spec_tys + other -> Nothing + + match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff + -- This is a Real Problem + + match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff + -- Partial eta abstraction might make this happen; + -- meanwhile let's leave in the check + + pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys) +\end{code} + + +\begin{code} +instance OptIdInfo SpecEnv where + noInfo = nullSpecEnv + + getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec + + addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec) + = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j + -- We *add* the new specialisation info rather than just replacing it + -- so that we don't lose old specialisation details. + + ppInfo sty better_id_fn spec_env + = pp_specs sty True better_id_fn nullIdEnv spec_env + +pp_specs sty _ _ _ (SpecEnv []) = pp_NONE +pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs) + = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [ + ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack, + ppInt numds, + let + better_spec_id = better_id_fn spec_id + spec_id_info = getIdInfo better_spec_id + in + if not print_spec_ids || boringIdInfo spec_id_info then + ppNil + else + ppCat [ppChar '{', + ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info, + ppChar '}'] + ] + | (SpecInfo ty_maybes numds spec_id) <- specs ]) + where + pp_the_list [p] = p + pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps] + + pp_maybe Nothing = ifPprInterface sty pp_NONE + pp_maybe (Just t) = pprParendUniType sty t +\end{code} + +%************************************************************************ +%* * +\subsection[strictness-IdInfo]{Strictness info about an @Id@} +%* * +%************************************************************************ + +We specify the strictness of a function by giving information about +each of the ``wrapper's'' arguments (see the description about +worker/wrapper-style transformations in the PJ/Launchbury paper on +unboxed types). + +The list of @Demands@ specifies: (a)~the strictness properties +of a function's arguments; (b)~the {\em existence} of a ``worker'' +version of the function; and (c)~the type signature of that worker (if +it exists); i.e. its calling convention. + +\begin{code} +data StrictnessInfo + = NoStrictnessInfo + + | BottomGuaranteed -- This Id guarantees never to return; + -- it is bottom regardless of its arguments. + -- Useful for "error" and other disguised + -- variants thereof. + + | StrictnessInfo [Demand] -- the main stuff; see below. + (Maybe Id) -- worker's Id, if applicable. +\end{code} + +This type is also actually used in the strictness analyser: +\begin{code} +data Demand + = WwLazy -- Argument is lazy as far as we know + MaybeAbsent -- (does not imply worker's existence [etc]). + -- If MaybeAbsent == True, then it is + -- *definitely* lazy. (NB: Absence implies + -- a worker...) + + | WwStrict -- Argument is strict but that's all we know + -- (does not imply worker's existence or any + -- calling-convention magic) + + | WwUnpack -- Argument is strict & a single-constructor + [Demand] -- type; its constituent parts (whose StrictInfos + -- are in the list) should be passed + -- as arguments to the worker. + + | WwPrim -- Argument is of primitive type, therefore + -- strict; doesn't imply existence of a worker; + -- argument should be passed as is to worker. + + | WwEnum -- Argument is strict & an enumeration type; + -- an Int# representing the tag (start counting + -- at zero) should be passed to the worker. + deriving (Eq, Ord) + -- we need Eq/Ord to cross-chk update infos in interfaces + +type MaybeAbsent = Bool -- True <=> not even used + +-- versions that don't worry about Absence: +wwLazy = WwLazy False +wwStrict = WwStrict +wwUnpack xs = WwUnpack xs +wwPrim = WwPrim +wwEnum = WwEnum +\end{code} + +\begin{code} +mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo + +mkStrictnessInfo [] _ = NoStrictnessInfo +mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr + +mkBottomStrictnessInfo = BottomGuaranteed + +bottomIsGuaranteed BottomGuaranteed = True +bottomIsGuaranteed other = False + +getWrapperArgTypeCategories + :: UniType -- wrapper's type + -> StrictnessInfo -- strictness info about its args + -> Maybe String + +getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing +getWrapperArgTypeCategories _ BottomGuaranteed + = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong +getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing + +getWrapperArgTypeCategories ty (StrictnessInfo arg_info _) + = Just (mkWrapperArgTypeCategories ty arg_info) + +workerExists :: StrictnessInfo -> Bool +workerExists (StrictnessInfo _ (Just worker_id)) = True +workerExists other = False + +getWorkerId :: StrictnessInfo -> Id + +getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id +#ifdef DEBUG +getWorkerId junk = pprPanic "getWorkerId: Nothing" (ppInfo PprDebug (\x->x) junk) +#endif +\end{code} + +\begin{code} +isStrict :: Demand -> Bool + +isStrict WwStrict = True +isStrict (WwUnpack _) = True +isStrict WwPrim = True +isStrict WwEnum = True +isStrict _ = False + +{- UNUSED: +absentArg :: Demand -> Bool + +absentArg (WwLazy absentp) = absentp +absentArg other = False +-} + +nonAbsentArgs :: [Demand] -> Int + +nonAbsentArgs cmpts + = foldr tick_non 0 cmpts + where + tick_non (WwLazy True) acc = acc + tick_non other acc = acc + 1 + +all_present_WwLazies :: [Demand] -> Bool +all_present_WwLazies infos + = and (map is_L infos) + where + is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count! + is_L _ = False -- (as they imply a worker) +\end{code} + +WDP 95/04: It is no longer enough to look at a list of @Demands@ for +an ``Unpack'' or an ``Absent'' and declare a worker. We also have to +check that @mAX_WORKER_ARGS@ hasn't been exceeded. Therefore, +@indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@ +in \tr{WwLib.lhs}. A worker is ``indicated'' when we hit an Unpack +or an Absent {\em that we accept}. +\begin{code} +indicatesWorker :: [Demand] -> Bool + +indicatesWorker dems + = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems + where + fake_mk_ww _ [] = False + fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent + fake_mk_ww extra_args (WwUnpack cmpnts : dems) + | extra_args_now > 0 = True -- we accepted an Unpack + where + extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts + + fake_mk_ww extra_args (_ : dems) + = fake_mk_ww extra_args dems +\end{code} + +\begin{code} +mkWrapperArgTypeCategories + :: UniType -- wrapper's type + -> [Demand] -- info about its arguments + -> String -- a string saying lots about the args + +mkWrapperArgTypeCategories wrapper_ty wrap_info + = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) -> + map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) + } + where + -- ToDo: this needs FIXING UP (it was a hack anyway...) + do_one (WwPrim, _) = 'P' + do_one (WwEnum, _) = 'E' + do_one (WwStrict, arg_ty_char) = arg_ty_char + do_one (WwUnpack _, arg_ty_char) + = if arg_ty_char `elem` "CIJFDTS" + then toLower arg_ty_char + else if arg_ty_char == '+' then 't' + else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-' + do_one (other_wrap_info, _) = '-' +\end{code} + +Whether a worker exists depends on whether the worker has an +absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments. + +If a @WwUnpack@ argument is for an {\em abstract} type (or one that +will be abstract outside this module), which might happen for an +imported function, then we can't (or don't want to...) unpack the arg +as the worker requires. Hence we have to give up altogether, and call +the wrapper only; so under these circumstances we return \tr{False}. + +\begin{code} +instance Text Demand where + readList str = read_em [{-acc-}] str + where + read_em acc [] = [(reverse acc, "")] + -- lower case indicates absence... + read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs + read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs + read_em acc ('S' : xs) = read_em (WwStrict : acc) xs + read_em acc ('P' : xs) = read_em (WwPrim : acc) xs + read_em acc ('E' : xs) = read_em (WwEnum : acc) xs + + read_em acc (')' : xs) = [(reverse acc, xs)] + read_em acc ( 'U' : '(' : xs) + = case (read_em [] xs) of + [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest + _ -> panic ("Text.Demand:"++str++"::"++xs) + + read_em acc other = panic ("IdInfo.readem:"++other) + + showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest + where + show1 (WwLazy False) = "L" + show1 (WwLazy True) = "A" + show1 WwStrict = "S" + show1 WwPrim = "P" + show1 WwEnum = "E" + show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")" + +instance Outputable Demand where + ppr sty si = ppStr (showList [si] "") + +instance OptIdInfo StrictnessInfo where + noInfo = NoStrictnessInfo + + getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict + + addInfo id_info NoStrictnessInfo = id_info + addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j + + ppInfo sty better_id_fn strictness_info + = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info +\end{code} + +We'll omit the worker info if the thing has an explicit unfolding +already. +\begin{code} +pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE + +pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_") + +pp_strictness sty for_this_id_maybe better_id_fn inline_env + info@(StrictnessInfo wrapper_args wrkr_maybe) + = let + (have_wrkr, wrkr_id) = case wrkr_maybe of + Nothing -> (False, panic "ppInfo(Strictness)") + Just xx -> (True, xx) + + wrkr_to_print = better_id_fn wrkr_id + wrkr_info = getIdInfo wrkr_to_print + + -- if we aren't going to be able to *read* the strictness info + -- in TcPragmas, we need not even print it. + wrapper_args_to_use + = if not (indicatesWorker wrapper_args) then + wrapper_args -- no worker/wrappering in any case + else + case for_this_id_maybe of + Nothing -> wrapper_args + Just id -> if externallyVisibleId id + && (unfoldingUnfriendlyId id || not have_wrkr) then + -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) ( + map un_workerise wrapper_args + -- ) + else + wrapper_args + + id_is_worker + = case for_this_id_maybe of + Nothing -> False + Just id -> isWorkerId id + + am_printing_iface + = case sty of + PprInterface _ -> True + _ -> False + + pp_basic_info + = ppBesides [ppStr "_S_ \"", + ppStr (showList wrapper_args_to_use ""), ppStr "\""] + + pp_with_worker + = ppBesides [ ppSP, ppChar '{', + ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info, + ppChar '}' ] + in + if all_present_WwLazies wrapper_args_to_use then -- too boring + ifPprInterface sty pp_NONE + + else if id_is_worker && am_printing_iface then + pp_NONE -- we don't put worker strictness in interfaces + -- (it can be deduced) + + else if not (indicatesWorker wrapper_args_to_use) + || not have_wrkr + || boringIdInfo wrkr_info then + ppBeside pp_basic_info ppNil + else + ppBeside pp_basic_info pp_with_worker + where + un_workerise (WwLazy _) = WwLazy False -- avoid absence + un_workerise (WwUnpack _) = WwStrict + un_workerise other = other +\end{code} + +%************************************************************************ +%* * +\subsection[unfolding-IdInfo]{Unfolding info about an @Id@} +%* * +%************************************************************************ + +\begin{code} +mkUnfolding :: UnfoldingGuidance -> PlainCoreExpr -> UnfoldingDetails +iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails +mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails + +mkUnfolding guide expr + = GeneralForm False (mkFormSummary NoStrictnessInfo{-NB:lying-} expr) + (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC) + guide +\end{code} + +\begin{code} +iWantToBeINLINEd guide = IWantToBeINLINEd guide + +mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag) + +{- UNUSED: +haveUnfolding NoUnfoldingDetails = False +haveUnfolding (IWantToBeINLINEd _) = False -- don't have the unfolding *YET* +haveUnfolding _ = True +-} +\end{code} + +\begin{code} +noInfo_UF = NoUnfoldingDetails + +getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding + +addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info +addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j + +--UNUSED:clearInfo_UF (IdInfo a b d e xxx f g h i j) = IdInfo a b d e noInfo_UF f g h i j +\end{code} + +\begin{code} +pp_unfolding sty for_this_id inline_env uf_details + = case (lookupIdEnv inline_env for_this_id) of + Nothing -> pp uf_details + Just dt -> pp dt + where + pp NoUnfoldingDetails = pp_NONE + + pp (IWantToBeINLINEd guide) -- not in interfaces + = if isWrapperId for_this_id + then pp_NONE -- wrapper: don't complain or mutter + else ppCat [ppStr "{-IWantToBeINLINEd", ppr sty guide, ppStr "-}", pp_NONE] + + pp (MagicForm tag _) + = ppCat [ppPStr SLIT("_MF_"), ppPStr tag] + + pp (GeneralForm _ _ template guide) + = let + untagged = unTagBinders template + in + if untagged `isWrapperFor` for_this_id + then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged)) + pp_NONE + else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged] + +\end{code} + +%************************************************************************ +%* * +\subsection[update-IdInfo]{Update-analysis info about an @Id@} +%* * +%************************************************************************ + +\begin{code} +data UpdateInfo + = NoUpdateInfo + | SomeUpdateInfo UpdateSpec + deriving (Eq, Ord) + -- we need Eq/Ord to cross-chk update infos in interfaces + +-- the form in which we pass update-analysis info between modules: +type UpdateSpec = [Int] +\end{code} + +\begin{code} +mkUpdateInfo = SomeUpdateInfo + +updateInfoMaybe NoUpdateInfo = Nothing +updateInfoMaybe (SomeUpdateInfo []) = Nothing +updateInfoMaybe (SomeUpdateInfo u) = Just u +\end{code} + +Text instance so that the update annotations can be read in. + +\begin{code} +instance Text UpdateInfo where + readsPrec p s | null s = panic "IdInfo: empty update pragma?!" + | otherwise = [(SomeUpdateInfo (map ok_digit s),"")] + where + ok_digit c | c >= '0' && c <= '2' = ord c - ord '0' + | otherwise = panic "IdInfo: not a digit while reading update pragma" + +instance OptIdInfo UpdateInfo where + noInfo = NoUpdateInfo + + getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update + + addInfo id_info NoUpdateInfo = id_info + addInfo (IdInfo a b d e f _ g h i j) upd_info = IdInfo a b d e f upd_info g h i j + + ppInfo sty better_id_fn NoUpdateInfo = ifPprInterface sty pp_NONE + ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE + ppInfo sty better_id_fn (SomeUpdateInfo spec) + = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec)) +\end{code} + +%************************************************************************ +%* * +\subsection[deforest-IdInfo]{Deforestation info about an @Id@} +%* * +%************************************************************************ + +The deforest info says whether this Id is to be unfolded during +deforestation. Therefore, when the deforest pragma is true, we must +also have the unfolding information available for this Id. + +\begin{code} +data DeforestInfo + = Don'tDeforest -- just a bool, might extend this + | DoDeforest -- later. + -- deriving (Eq, Ord) +\end{code} + +\begin{code} +instance OptIdInfo DeforestInfo where + noInfo = Don'tDeforest + + getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest + + addInfo id_info Don'tDeforest = id_info + addInfo (IdInfo a b d e f g _ h i j) deforest = + IdInfo a b d e f g deforest h i j + + ppInfo sty better_id_fn Don'tDeforest + = ifPprInterface sty pp_NONE + ppInfo sty better_id_fn DoDeforest + = ppPStr SLIT("_DEFOREST_") +\end{code} + +%************************************************************************ +%* * +\subsection[argUsage-IdInfo]{Argument Usage info about an @Id@} +%* * +%************************************************************************ + +\begin{code} +data ArgUsageInfo + = NoArgUsageInfo + | SomeArgUsageInfo ArgUsageType + -- ??? deriving (Eq, Ord) + +data ArgUsage = ArgUsage Int -- number of arguments (is linear!) + | UnknownArgUsage +type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB +\end{code} + +\begin{code} +mkArgUsageInfo = SomeArgUsageInfo + +getArgUsage :: ArgUsageInfo -> ArgUsageType +getArgUsage NoArgUsageInfo = [] +getArgUsage (SomeArgUsageInfo u) = u +\end{code} + +\begin{code} +instance OptIdInfo ArgUsageInfo where + noInfo = NoArgUsageInfo + + getInfo (IdInfo _ _ _ _ _ _ _ au _ _) = au + + addInfo id_info NoArgUsageInfo = id_info + addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j + + ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE + ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE + ppInfo sty better_id_fn (SomeArgUsageInfo aut) + = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut) + + +ppArgUsage (ArgUsage n) = ppInt n +ppArgUsage (UnknownArgUsage) = ppChar '-' + +ppArgUsageType aut = ppBesides + [ ppChar '"' , + ppIntersperse ppComma (map ppArgUsage aut), + ppChar '"' ] +\end{code} +%************************************************************************ +%* * +\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes} +%* * +%************************************************************************ + +\begin{code} +data FBTypeInfo + = NoFBTypeInfo + | SomeFBTypeInfo FBType + -- ??? deriving (Eq, Ord) + +data FBType = FBType [FBConsum] FBProd deriving (Eq) + +data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq) +data FBProd = FBGoodProd | FBBadProd deriving(Eq) +\end{code} + +\begin{code} +mkFBTypeInfo = SomeFBTypeInfo + +getFBType :: FBTypeInfo -> Maybe FBType +getFBType NoFBTypeInfo = Nothing +getFBType (SomeFBTypeInfo u) = Just u +\end{code} + +\begin{code} +instance OptIdInfo FBTypeInfo where + noInfo = NoFBTypeInfo + + getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb + + addInfo id_info NoFBTypeInfo = id_info + addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j + + ppInfo (PprInterface _) better_id_fn NoFBTypeInfo = ppNil + ppInfo sty better_id_fn NoFBTypeInfo = ifPprInterface sty pp_NONE + ppInfo sty better_id_fn (SomeFBTypeInfo (FBType cons prod)) + = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod) + +--ppFBType (FBType n) = ppBesides [ppInt n] +--ppFBType (UnknownFBType) = ppBesides [ppStr "-"] +-- + +ppFBType cons prod = ppBesides + ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ]) + where + ppCons FBGoodConsum = ppChar 'G' + ppCons FBBadConsum = ppChar 'B' + ppProd FBGoodProd = ppChar 'G' + ppProd FBBadProd = ppChar 'B' +\end{code} diff --git a/ghc/compiler/basicTypes/Inst.hi b/ghc/compiler/basicTypes/Inst.hi new file mode 100644 index 0000000..1941fd5 --- /dev/null +++ b/ghc/compiler/basicTypes/Inst.hi @@ -0,0 +1,89 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Inst where +import Bag(Bag) +import Class(Class, ClassOp) +import HsBinds(Binds) +import HsExpr(ArithSeqInfo, Expr, Qual, RenamedArithSeqInfo(..), RenamedExpr(..)) +import HsLit(Literal) +import HsMatches(Match) +import HsPat(InPat, RenamedPat(..)) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdInfo(IdInfo, SpecEnv) +import InstEnv(ClassInstEnv(..), InstTemplate, InstTy, InstanceMapper(..), MatchEnv(..)) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(Outputable) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle, PrettyRep) +import PrimKind(PrimKind) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniTyFuns(isTyVarTy) +import UniType(UniType) +import Unique(Unique) +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data ArithSeqInfo a b {-# GHC_PRAGMA From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data Inst = Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin +data InstOrigin = OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin +data OverloadedLit = OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id +type RenamedArithSeqInfo = ArithSeqInfo Name (InPat Name) +type RenamedExpr = Expr Name (InPat Name) +data Literal {-# GHC_PRAGMA CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type RenamedPat = InPat Name +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type ClassInstEnv = [(UniType, InstTemplate)] +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv) +type MatchEnv a b = [(a, b)] +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +applySubstToInst :: Subst -> Inst -> (Subst, Inst) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +extractConstrainedTyVarsFromInst :: Inst -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarsFromInst :: Inst -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getDictClassAndType :: Inst -> (Class, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getInstOrigin :: Inst -> (SrcLoc, PprStyle -> Int -> Bool -> PrettyRep) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getInstUniType :: Inst -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instBindingRequired :: Inst -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instCanBeGeneralised :: Inst -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTyVarDict :: Inst -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: Inst) -> case u0 of { _ALG_ _ORIG_ Inst Dict (u1 :: Unique) (u2 :: Class) (u3 :: UniType) (u4 :: InstOrigin) -> _APP_ _ORIG_ UniTyFuns isTyVarTy [ u3 ]; (u5 :: Inst) -> _!_ False [] [] } _N_ #-} +isTyVarTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +matchesInst :: Inst -> Inst -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +mkDict :: Unique -> Class -> UniType -> InstOrigin -> Inst + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: Class) (u2 :: UniType) (u3 :: InstOrigin) -> _!_ _ORIG_ Inst Dict [] [u0, u1, u2, u3] _N_ #-} +mkLitInst :: Unique -> OverloadedLit -> UniType -> InstOrigin -> Inst + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: OverloadedLit) (u2 :: UniType) (u3 :: InstOrigin) -> _!_ _ORIG_ Inst LitInst [] [u0, u1, u2, u3] _N_ #-} +mkMethod :: Unique -> Id -> [UniType] -> InstOrigin -> Inst + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: Id) (u2 :: [UniType]) (u3 :: InstOrigin) -> _!_ _ORIG_ Inst Method [] [u0, u1, u2, u3] _N_ #-} +instance Outputable Inst + {-# GHC_PRAGMA _M_ Inst {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Inst) _N_ + ppr = _A_ 2 _U_ 1222 _N_ _S_ "SS" _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/Inst.lhs b/ghc/compiler/basicTypes/Inst.lhs new file mode 100644 index 0000000..82c1b9c --- /dev/null +++ b/ghc/compiler/basicTypes/Inst.lhs @@ -0,0 +1,391 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Inst]{The @Inst@ type: dictionaries or method instances} + +\begin{code} +#include "HsVersions.h" + +module Inst ( + Inst(..), InstOrigin(..), OverloadedLit(..), + + mkDict, mkMethod, mkLitInst, + getInstUniType, +--UNUSED: getInstLocalName, + getInstOrigin, getDictClassAndType, +--UNUSED: instantiateInst, + applySubstToInst, + apply_to_Inst, -- not for general use, please + extractTyVarsFromInst, extractConstrainedTyVarsFromInst, + matchesInst, + isTyVarDict, +--UNUSED: isNullaryTyConDict, + instBindingRequired, instCanBeGeneralised, + + -- and to make the interface self-sufficient... + Class, ClassOp, ArithSeqInfo, RenamedArithSeqInfo(..), + Literal, InPat, RenamedPat(..), Expr, RenamedExpr(..), + Id, Name, SrcLoc, Subst, PrimKind, + TyVar, TyVarTemplate, TyCon, UniType, Unique, InstTemplate, + InstanceMapper(..), ClassInstEnv(..), MatchEnv(..) + + IF_ATTACK_PRAGMAS(COMMA isTyVarTy) + ) where + +import AbsSyn +import AbsUniType +import Id ( eqId, applySubstToId, + getInstNamePieces, getIdUniType, + Id + ) +import InstEnv +import ListSetOps +import Maybes ( Maybe(..) ) +import Outputable +import Pretty +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Subst ( applySubstToTy, Subst ) +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection[Inst-types]{@Inst@ types} +%* * +%************************************************************************ + +An @Inst@ is either a dictionary, an instance of an overloaded +literal, or an instance of an overloaded value. We call the latter a +``method'' even though it may not correspond to a class operation. +For example, we might have an instance of the @double@ function at +type Int, represented by + + Method 34 doubleId [Int] origin + +\begin{code} +data Inst + = Dict + Unique + Class -- The type of the dict is (c t), where + UniType -- c is the class and t the unitype; + InstOrigin + + | Method + Unique + Id -- (I expect) be a global, local, or ClassOpId. + -- Inside instance decls (only) it can also be an InstId! + -- The id needn't be completely polymorphic, + [UniType] -- The types to which its polymorphic tyvars + -- should be instantiated + -- These types may not saturate the Id's foralls. + InstOrigin + + | LitInst + Unique + OverloadedLit + UniType -- the type at which the literal is used + InstOrigin -- always a literal; but more convenient to carry this around + +mkDict = Dict +mkMethod = Method +mkLitInst= LitInst + +data OverloadedLit + = OverloadedIntegral Integer -- the number + Id Id -- cached fromInt, fromInteger + | OverloadedFractional Rational -- the number + Id -- cached fromRational + +{- UNUSED: +getInstLocalName (Dict _ clas _ _) = getLocalName clas +getInstLocalName (Method _ id _ _) = getLocalName id +-} + +-- this is used for error messages +getDictClassAndType :: Inst -> (Class, UniType) +getDictClassAndType (Dict _ clas ty _) = (clas, ty) + +getInstUniType :: Inst -> UniType +getInstUniType (Dict _ clas ty _) = mkDictTy clas ty +getInstUniType (LitInst _ _ ty _) = ty +getInstUniType (Method _ id tys _) + = instantiateTauTy (tyvars `zip` tys) tau_ty + where + (tyvars, theta, tau_ty) = splitType (getIdUniType id) + -- Note that we ignore the overloading; this is + -- an INSTANCE of an overloaded operation +\end{code} + +@applySubstToInst@ doesn't make any assumptions, but @instantiateInst@ +assumes that the @Id@ in a @Method@ is fully polymorphic (ie has no free +tyvars) + +\begin{code} +{- UNUSED: +instantiateInst :: [(TyVarTemplate, UniType)] -> Inst -> Inst + +instantiateInst tenv (Dict uniq clas ty orig) + = Dict uniq clas (instantiateTy tenv ty) orig + +instantiateInst tenv (Method uniq id tys orig) + = --False:ASSERT(idHasNoFreeTyVars id) + Method uniq id (map (instantiateTy tenv) tys) orig + +instantiateInst tenv (LitInst u lit ty orig) + = LitInst u lit (instantiateTy tenv ty) orig +-} + +----------------------------------------------------------------- +-- too bad we can't use apply_to_Inst + +applySubstToInst subst (Dict uniq clas ty orig) + = case (applySubstToTy subst ty) of { (s2, new_ty) -> + (s2, Dict uniq clas new_ty orig) } + +applySubstToInst subst (Method uniq id tys orig) + -- NB: *must* zap "id" in the typechecker + = case (applySubstToId subst id) of { (s2, new_id) -> + case (mapAccumL applySubstToTy s2 tys) of { (s3, new_tys) -> + (s3, Method uniq new_id new_tys orig) }} + +applySubstToInst subst (LitInst u lit ty orig) + = case (applySubstToTy subst ty) of { (s2, new_ty) -> + (s2, LitInst u lit new_ty orig) } + +----------------------------------------------------------------- +apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst + +apply_to_Inst ty_fn (Dict uniq clas ty orig) + = Dict uniq clas (ty_fn ty) orig + +apply_to_Inst ty_fn (Method uniq id tys orig) + = --FALSE: ASSERT(idHasNoFreeTyVars id) + Method uniq id (map ty_fn tys) orig + +apply_to_Inst ty_fn (LitInst u lit ty orig) + = LitInst u lit (ty_fn ty) orig +\end{code} + +\begin{code} +extractTyVarsFromInst, extractConstrainedTyVarsFromInst :: Inst -> [TyVar] + +extractTyVarsFromInst (Dict _ _ ty _) = extractTyVarsFromTy ty +extractTyVarsFromInst (Method _ _ tys _) = extractTyVarsFromTys tys +extractTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy ty + +extractConstrainedTyVarsFromInst (Dict _ _ ty _) = extractTyVarsFromTy ty +extractConstrainedTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy ty + +-- `Method' is different! +extractConstrainedTyVarsFromInst (Method _ m tys _) + = foldr unionLists [] (zipWith xxx tvs tys) + where + (tvs,theta,tau_ty) = splitType (getIdUniType m) + + constrained_tvs + = foldr unionLists [] [extractTyVarTemplatesFromTy t | (_,t) <- theta ] + + xxx tv ty | tv `elem` constrained_tvs = extractTyVarsFromTy ty + | otherwise = [] +\end{code} + +@matchesInst@ checks when two @Inst@s are instances of the same +thing at the same type, even if their uniques differ. + +\begin{code} +matchesInst :: Inst -> Inst -> Bool +matchesInst (Dict _ clas1 ty1 _) (Dict _ clas2 ty2 _) + = clas1 == clas2 && ty1 == ty2 +matchesInst (Method _ id1 tys1 _) (Method _ id2 tys2 _) + = id1 `eqId` id2 && tys1 == tys2 +matchesInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) + = lit1 `eq` lit2 && ty1 == ty2 + where + (OverloadedIntegral i1 _ _) `eq` (OverloadedIntegral i2 _ _) = i1 == i2 + (OverloadedFractional f1 _) `eq` (OverloadedFractional f2 _) = f1 == f2 + _ `eq` _ = False + +matchesInst other1 other2 = False +\end{code} + + +\begin{code} +isTyVarDict :: Inst -> Bool +isTyVarDict (Dict _ _ ty _) = isTyVarTy ty +isTyVarDict other = False + +{- UNUSED: +isNullaryTyConDict :: Inst -> Bool +isNullaryTyConDict (Dict _ _ ty _) + = case (getUniDataTyCon_maybe ty) of + Just (tycon, [], _) -> True -- NB null args to tycon + other -> False +-} +\end{code} + +Two predicates which deal with the case where +class constraints don't necessarily result in bindings. +The first tells whether an @Inst@ must be witnessed by an +actual binding; the second tells whether an @Inst@ can be +generalised over. + +\begin{code} +instBindingRequired :: Inst -> Bool +instBindingRequired inst + = case get_origin_really inst of + CCallOrigin _ _ _ -> False -- No binding required + LitLitOrigin _ _ -> False + other -> True + +instCanBeGeneralised :: Inst -> Bool +instCanBeGeneralised inst + = case get_origin_really inst of + CCallOrigin _ _ _ -> False -- Can't be generalised + LitLitOrigin _ _ -> False -- Can't be generalised + other -> True +\end{code} + +ToDo: improve these pretty-printing things. The ``origin'' is really only +relevant in error messages. + +\begin{code} +-- ToDo: this instance might be nukable (maybe not: used for error msgs) + +instance Outputable Inst where + ppr PprForUser (LitInst _ lit _ _) + = case lit of + OverloadedIntegral i _ _ -> ppInteger i +#if __GLASGOW_HASKELL__ <= 22 + OverloadedFractional f _ -> ppDouble (fromRational f) -- ToDo: better +#else + OverloadedFractional f _ -> ppRational f +#endif + + ppr sty inst + = ppIntersperse (ppChar '.') (map ppPStr (getInstNamePieces True inst)) +\end{code} + + +%************************************************************************ +%* * +\subsection[Inst-origin]{The @InstOrigin@ type} +%* * +%************************************************************************ + +The @InstOrigin@ type gives information about where a dictionary came from. +This is important for decent error message reporting because dictionaries +don't appear in the original source code. Doubtless this type will evolve... + +\begin{code} +data InstOrigin + = OccurrenceOf Id -- Occurrence of an overloaded identifier + SrcLoc + + | InstanceDeclOrigin SrcLoc -- Typechecking an instance decl + + | LiteralOrigin Literal -- Occurrence of a literal + SrcLoc -- (now redundant? ToDo) + + | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc + SrcLoc + + | SignatureOrigin -- A dict created from a type signature + -- I don't expect this ever to appear in + -- an error message so I can't be bothered + -- to give it a source location... + + | ClassDeclOrigin SrcLoc -- Manufactured during a class decl + + | DerivingOrigin InstanceMapper + Class + Bool -- True <=> deriving for *functions*; + -- do *not* look at the TyCon! [WDP 94/09] + TyCon + SrcLoc + + -- During "deriving" operations we have an ever changing + -- mapping of classes to instances, so we record it inside the + -- origin information. This is a bit of a hack, but it works + -- fine. (Simon is to blame [WDP].) + + | InstanceSpecOrigin InstanceMapper + Class -- in a SPECIALIZE instance pragma + UniType + SrcLoc + + -- When specialising instances the instance info attached to + -- each class is not yet ready, so we record it inside the + -- origin information. This is a bit of a hack, but it works + -- fine. (Patrick is to blame [WDP].) + + | DefaultDeclOrigin SrcLoc -- Related to a `default' declaration + + | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value + SrcLoc + + -- Argument or result of a ccall + -- Dictionaries with this origin aren't actually mentioned in the + -- translated term, and so need not be bound. Nor should they + -- be abstracted over. + | CCallOrigin SrcLoc + String -- CCall label + (Maybe RenamedExpr) -- Nothing if it's the result + -- Just arg, for an argument + + | LitLitOrigin SrcLoc + String -- the litlit + + | UnknownOrigin -- Help! I give up... +\end{code} + +\begin{code} +get_origin_really (Dict u clas ty origin) = origin +get_origin_really (Method u clas ty origin) = origin +get_origin_really (LitInst u lit ty origin) = origin + +getInstOrigin inst + = let origin = get_origin_really inst + in get_orig origin + where + get_orig :: InstOrigin -> (SrcLoc, PprStyle -> Pretty) + + get_orig (OccurrenceOf id loc) + = (loc, \ sty -> ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"), + ppr sty id, ppChar '\'']) + get_orig (InstanceDeclOrigin loc) + = (loc, \ sty -> ppStr "in an instance declaration") + get_orig (LiteralOrigin lit loc) + = (loc, \ sty -> ppCat [ppStr "at an overloaded literal:", ppr sty lit]) + get_orig (ArithSeqOrigin seq loc) + = (loc, \ sty -> ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]) + get_orig SignatureOrigin + = (mkUnknownSrcLoc, \ sty -> ppStr "in a type signature") + get_orig (ClassDeclOrigin loc) + = (loc, \ sty -> ppStr "in a class declaration") + get_orig (DerivingOrigin _ clas is_function tycon loc) + = (loc, \ sty -> ppBesides [ppStr "in a `deriving' clause; class \"", + ppr sty clas, + if is_function + then ppStr "\"; type: functions" + else ppBeside (ppStr "\"; offending type \"") (ppr sty tycon), + ppStr "\""]) + get_orig (InstanceSpecOrigin _ clas ty loc) + = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", + ppr sty clas, ppStr "\" type: ", ppr sty ty]) + get_orig (DefaultDeclOrigin loc) + = (loc, \ sty -> ppStr "in a `default' declaration") + get_orig (ValSpecOrigin name loc) + = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE user-pragma for `", + ppr sty name, ppStr "'"]) + get_orig (CCallOrigin loc clabel Nothing{-ccall result-}) + = (loc, \ sty -> ppBesides [ppStr "in the result of the _ccall_ to `", + ppStr clabel, ppStr "'"]) + get_orig (CCallOrigin loc clabel (Just arg_expr)) + = (loc, \ sty -> ppBesides [ppStr "in an argument in the _ccall_ to `", + ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]) + get_orig (LitLitOrigin loc s) + = (loc, \ sty -> ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]) + get_orig UnknownOrigin + = (mkUnknownSrcLoc, \ sty -> ppStr "in... oops -- I don't know where the overloading came from!") +\end{code} diff --git a/ghc/compiler/basicTypes/Jmakefile b/ghc/compiler/basicTypes/Jmakefile new file mode 100644 index 0000000..46f17a0 --- /dev/null +++ b/ghc/compiler/basicTypes/Jmakefile @@ -0,0 +1,12 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) + +HaskellSuffixRules() + +/* LIT2LATEX_OPTS=-tbird */ + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTargetWithNamedOutput(basicTypes,lit,basicTypes-standalone) diff --git a/ghc/compiler/basicTypes/NameTypes.hi b/ghc/compiler/basicTypes/NameTypes.hi new file mode 100644 index 0000000..d6bc211 --- /dev/null +++ b/ghc/compiler/basicTypes/NameTypes.hi @@ -0,0 +1,59 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface NameTypes where +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludePS(_PackedString) +import SrcLoc(SrcLoc) +import Unique(Unique) +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data Provenance = ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString] +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +fromPrelude :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +invisibleFullName :: FullName -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAEA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Bool) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u5; _NO_DEFLT_ } _N_ #-} +mkFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkPreludeCoreName :: _PackedString -> _PackedString -> FullName + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkPrivateFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkShortName :: _PackedString -> SrcLoc -> ShortName + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: SrcLoc) -> _!_ _ORIG_ NameTypes ShortName [] [u0, u1] _N_ #-} +unlocaliseFullName :: FullName -> FullName + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLALL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +unlocaliseShortName :: _PackedString -> Unique -> ShortName -> FullName + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LLU(LL)" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-} +instance NamedThing ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +instance Outputable FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/NameTypes.lhs b/ghc/compiler/basicTypes/NameTypes.lhs new file mode 100644 index 0000000..dee7c44 --- /dev/null +++ b/ghc/compiler/basicTypes/NameTypes.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +%************************************************************************ +%* * +\section[NameTypes]{@NameTypes@: The flavours of names that we stick on things} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module NameTypes ( + ShortName, FullName, -- abstract types + Provenance(..), + + fromPrelude, + + mkShortName, + + mkFullName, mkPrivateFullName, mkPreludeCoreName, + + invisibleFullName, + + unlocaliseFullName, unlocaliseShortName, + +#ifdef DPH + isInventedFullName, +#endif {- Data Parallel Haskell -} + + -- and to make the interface self-sufficient.... + ExportFlag, Unique, SrcLoc + ) where + +import CLabelInfo ( identToC, cSEP ) +import Outputable +import PrelFuns ( pRELUDE, pRELUDE_CORE ) -- NB: naughty import +import Pretty +import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) +import Unique ( showUnique, Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[NameTypes-flavours]{Datatypes for names} +%* * +%************************************************************************ + +Here are the types; see the notes that follow. +\begin{code} +data ShortName + = ShortName FAST_STRING -- entity's name in this module + SrcLoc -- defining location (only one possible) + +data FullName + = FullName FAST_STRING -- original module name + FAST_STRING -- entity's name in original module + Provenance -- where this thing came from + -- (also records its local name, if any) + ExportFlag -- where this thing is going (from here) + Bool -- True <=> invisible to the user + SrcLoc -- defining location (just one) +\end{code} +(@FullNames@ don't have fast-comparison keys; the things with +@FullNames@ do.) + +\begin{description} +%---------------------------------------------------------------------- +\item[@ShortName@:] + +These are used for entities local to the module being compiled; for +example, function parameters, where- and let-bound things. These are +@TyVars@ (ToDo: what if imported???) and local @Ids@. They have +@Uniques@ for fast comparison. + +%---------------------------------------------------------------------- +\item[@FullName@:] +These are used for things that either have, or may be required to +have, full-blown original names. All @Classes@ and @TyCons@ have full +names. All data-constructor and top-level @Ids@ (things that were +top-level in the original source) have fullnames. +\end{description} + +%************************************************************************ +%* * +\subsection[NameTypes-Provenance]{Where a name(d thing) came from} +%* * +%************************************************************************ + +The ``provenance'' of a name says something about where it came from. +This is used: +\begin{itemize} +\item +to decide whether to generate the code fragments for constructors +(only done for @ThisModule@). +\item +to detect when a thing is from @PreludeCore@, in which case we +use shorter target-code names. +\end{itemize} + +\begin{code} +data Provenance + = ThisModule + + | InventedInThisModule -- for workers/wrappers, specialized + -- versions, etc: anything "conjured up" + -- on the compiler's initiative. + + | ExportedByPreludeCore -- these are the immutable, unrenamable + -- things the compiler knows about + + | OtherPrelude FAST_STRING -- the FullName gave the *original* + -- name; this says what it was renamed + -- to (if anything); really just for + -- pretty-printing + + | OtherModule FAST_STRING -- as for OtherPrelude, just the occurrence + -- name + [FAST_STRING]-- The modules from whose interface we + -- got the information about this thing + + | HereInPreludeCore -- used when compiling PreludeCore bits: + -- == ThisModule + ExportedByPreludeCore + + | OtherInstance -- For imported instances. + FAST_STRING -- The module where this instance supposedly + -- was declared; "" if we don't know. + [FAST_STRING] -- The modules whose interface told us about + -- this instance. +\end{code} + +%************************************************************************ +%* * +\subsection[NameTypes-access-fns]{Access functions for names} +%* * +%************************************************************************ + +Things to make 'em: +\begin{code} +mkShortName = ShortName + +mkFullName m n p e l = FullName m n p e False{-not invisible-} l + +mkPrivateFullName m n p e l = FullName m n p e True{-invisible-} l + +mkPreludeCoreName mod name + = FullName mod name ExportedByPreludeCore ExportAll False mkBuiltinSrcLoc + -- Mark them as Exported; mkInterface may decide against it + -- later. (Easier than marking them NotExported, then later + -- deciding it would be a good idea...) +\end{code} + +\begin{code} +#ifdef DPH +isInventedFullName (FullName _ _ p _ _ _) + = case p of + InventedInThisModule -> True + _ -> False + +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +unlocaliseShortName :: FAST_STRING -> Unique -> ShortName -> FullName + +{- We now elucidate Simon's favourite piece of code: + + When we are told to "unlocalise" a ShortName, we really really want + the resulting monster to be unique (across the entire universe). + We can't count on the module name being printed (for Prelude + things, it isn't), so we brutally force the module-name into the + regular-name component. + + We change the provenance to InventedInThisModule, because + that's what it is. +-} +unlocaliseShortName mod u (ShortName nm loc) + = FullName mod + (mod _APPEND_ nm _APPEND_ (showUnique u)) + InventedInThisModule + ExportAll False loc + +-- FullNames really can't be mangled; someone out there +-- *expects* the thing to have this name. +-- We only change the export status. + +unlocaliseFullName (FullName m n p _ i l) + = FullName m n p ExportAll i l +\end{code} + +%************************************************************************ +%* * +\subsection[NameTypes-instances]{Instance declarations for various names} +%* * +%************************************************************************ + +We don't have equality and ordering; that's defined for the things +that have @ShortNames@ and @FullNames@ in them. + +\begin{code} +instance NamedThing ShortName where + getExportFlag a = NotExported + isLocallyDefined a = True + getOrigName (ShortName s l) = (panic "NamedThing.ShortName.getOrigName", s) + getOccurrenceName (ShortName s l) = s + getSrcLoc (ShortName s l) = l + fromPreludeCore (ShortName _ _) = False +#ifdef DEBUG + getTheUnique (ShortName s l) = panic "NamedThing.ShortName.getTheUnique" + getInformingModules a = panic "NamedThing.ShortName.getInformingModule" + hasType a = panic "NamedThing.ShortName.hasType" + getType a = panic "NamedThing.ShortName.getType" +#endif +\end{code} + +\begin{code} +instance NamedThing FullName where + + getExportFlag (FullName m s p e i l) = e + getOrigName (FullName m s p e i l) = (m, s) + getSrcLoc (FullName m s p e i l) = l + + isLocallyDefined (FullName m s p e i l) + = case p of + ThisModule -> True + InventedInThisModule -> True + HereInPreludeCore -> True + _ -> False + + getOccurrenceName (FullName _ s p _ _ _) + = case p of + OtherPrelude o -> o + OtherModule o _ -> o + _ -> s + + fromPreludeCore (FullName _ _ p _ _ _) + = case p of + ExportedByPreludeCore -> True + HereInPreludeCore -> True + _ -> False + + getInformingModules (FullName _ _ p _ _ _) + = case p of + ThisModule -> [] -- Urgh. ToDo + InventedInThisModule -> [] + OtherModule _ ms -> ms + OtherInstance _ ms -> ms + ExportedByPreludeCore -> [pRELUDE_CORE] + HereInPreludeCore -> [pRELUDE_CORE] + OtherPrelude _ -> [pRELUDE] + +#ifdef DEBUG + getTheUnique = panic "NamedThing.FullName.getTheUnique" + hasType = panic "NamedThing.FullName.hasType" + getType = panic "NamedThing.FullName.getType" +#endif +\end{code} + +A hack (ToDo?): +\begin{code} +fromPrelude :: FAST_STRING -> Bool + +fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude")) + +invisibleFullName (FullName m s p e i l) = i +\end{code} + +Forcing and printing: +\begin{code} +instance Outputable ShortName where + ppr sty (ShortName s loc) = ppPStr s + +instance Outputable FullName where + ppr sty name@(FullName m s p e i l) + = let pp_name = + ppBeside (if fromPreludeCore name + then ppNil + else case sty of + PprForUser -> ppNil + PprDebug -> ppNil + PprInterface _ -> ppNil + PprUnfolding _ -> ppNil -- ToDo: something diff later? + PprForC _ -> ppBeside (identToC m) (ppPStr cSEP) + PprForAsm _ False _ -> ppBeside (identToC m) (ppPStr cSEP) + PprForAsm _ True _ -> ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP] + _ -> ppBeside (ppPStr m) (ppChar '.')) + (if codeStyle sty + then identToC s + else case sty of + PprInterface _ -> pp_local_name s p + PprForUser -> pp_local_name s p + _ -> ppPStr s) + + pp_debug = ppBeside pp_name (pp_occur_name s p) + in + case sty of + PprShowAll -> ppBesides [pp_debug, pp_exp e] -- (ppr sty loc) + PprDebug -> pp_debug + PprUnfolding _ -> pp_debug + _ -> pp_name + where + pp_exp NotExported = ppNil + pp_exp ExportAll = ppPStr SLIT("/EXP(..)") + pp_exp ExportAbs = ppPStr SLIT("/EXP") + +-- little utility gizmos... +pp_occur_name, pp_local_name :: FAST_STRING -> Provenance -> Pretty + +pp_occur_name s (OtherPrelude o) | s /= o = ppBesides [ppChar '{', ppPStr o, ppChar '}'] +pp_occur_name s (OtherModule o ms)| s /= o = ppBesides [ppChar '{', ppPStr o, ppChar '}'] + -- ToDo: print the "informant modules"? +pp_occur_name _ _ = ppNil + +pp_local_name s (OtherPrelude o) | s /= o = ppPStr o +pp_local_name s (OtherModule o ms)| s /= o = ppPStr o +pp_local_name s _ = ppPStr s +\end{code} diff --git a/ghc/compiler/basicTypes/OrdList.hi b/ghc/compiler/basicTypes/OrdList.hi new file mode 100644 index 0000000..43fbd75 --- /dev/null +++ b/ghc/compiler/basicTypes/OrdList.hi @@ -0,0 +1,14 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface OrdList where +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +flattenOrdList :: OrdList a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkEmptyList :: OrdList a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ OrdList NoObj [u0] [] _N_ #-} +mkParList :: OrdList a -> OrdList a -> OrdList a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: OrdList u0) (u2 :: OrdList u0) -> _!_ _ORIG_ OrdList ParList [u0] [u1, u2] _N_ #-} +mkSeqList :: OrdList a -> OrdList a -> OrdList a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: OrdList u0) (u2 :: OrdList u0) -> _!_ _ORIG_ OrdList SeqList [u0] [u1, u2] _N_ #-} +mkUnitList :: a -> OrdList a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ OrdList OrdObj [u0] [u1] _N_ #-} + diff --git a/ghc/compiler/basicTypes/OrdList.lhs b/ghc/compiler/basicTypes/OrdList.lhs new file mode 100644 index 0000000..a97bb80 --- /dev/null +++ b/ghc/compiler/basicTypes/OrdList.lhs @@ -0,0 +1,236 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1994 +% + +% +% This is useful, general stuff for the Native Code Generator. +% + +\begin{code} + +module OrdList ( + OrdList, + + mkParList, mkSeqList, mkEmptyList, mkUnitList, + + flattenOrdList +-- UNUSED: +-- concatOrdList, fnOrdList, foldOrdList, +-- mapAccumBOrdList, mapAccumLOrdList, mapAccumROrdList, +-- mapOrdList, reverseOrdList, simplOrdList + ) where + +import Util ( mapAccumB, mapAccumL, mapAccumR ) + +\end{code} + +This section provides an ordering list that allows fine grain +parallelism to be expressed. This is used (ultimately) for scheduling +of assembly language instructions. + +\begin{code} + +data OrdList a = SeqList (OrdList a) (OrdList a) + | ParList (OrdList a) (OrdList a) + | OrdObj a + | NoObj + deriving () + +mkSeqList a b = SeqList a b +mkParList a b = ParList a b +mkEmptyList = NoObj +mkUnitList = OrdObj + +\end{code} + +%------------------------------------------------------------------------ + +This simplifies an ordering list, using correctness preserving transformations. +Notice the duality between @Seq@ and @Par@. + +\begin{code} +{- UNUSED: +simplOrdList :: OrdList a -> OrdList a +simplOrdList (SeqList vs) = + case (concat [ + (case simplOrdList v of + SeqList xs -> xs + OrdObj a -> [OrdObj a] + NoObj -> [] + xs -> [xs]) | v <- vs]) of + [] -> NoObj + [x] -> x + v -> SeqList v +simplOrdList (ParList vs) = + case (concat [ + (case simplOrdList v of + ParList xs -> xs + OrdObj a -> [OrdObj a] + NoObj -> [] + xs -> [xs]) | v <- vs]) of + [] -> NoObj + [x] -> x + v -> ParList v +simplOrdList v = v +-} +\end{code} + +%------------------------------------------------------------------------ + +First the foldr ! + +\begin{code} +{- UNUSED: + +foldOrdList + :: ([b] -> b) + -> ([b] -> b) + -> (a -> b) + -> b + -> (b -> b -> b) + -> OrdList a + -> b +foldOrdList s p o n c (SeqList vs) = s (map (foldOrdList s p o n c) vs) +foldOrdList s p o n c (ParList vs) = p (map (foldOrdList s p o n c) vs) +foldOrdList s p o n c (OrdObj a) = o a +foldOrdList s p o n c NoObj = n + +fnOrdList :: (a -> OrdList b) -> OrdList a -> OrdList b +fnOrdList f (SeqList vs) = SeqList (map (fnOrdList f) vs) +fnOrdList f (ParList vs) = ParList (map (fnOrdList f) vs) +fnOrdList f (OrdObj a) = f a +fnOrdList f NoObj = NoObj +-} +\end{code} + +This does a concat on an ordering list of ordering lists. + +\begin{code} +{- UNUSED: +concatOrdList :: OrdList (OrdList a) -> OrdList a +concatOrdList = fnOrdList id +-} +\end{code} + +This performs a map over an ordering list. + +\begin{code} +{- UNUSED: +mapOrdList :: (a -> b) -> OrdList a -> OrdList b +mapOrdList f = fnOrdList (OrdObj.f) +-} +\end{code} + +Here is the reverse over the OrdList. + +\begin{code} +{- UNUSED: +reverseOrdList :: OrdList a -> OrdList a +reverseOrdList NoObj = NoObj +reverseOrdList (OrdObj a) = OrdObj a +reverseOrdList (ParList vs) = ParList (reverse (map reverseOrdList vs)) +reverseOrdList (SeqList vs) = SeqList (reverse (map reverseOrdList vs)) +-} +\end{code} + +Notice this this throws away all potential expression of parrallism. + +\begin{code} +flattenOrdList :: OrdList a -> [a] + +flattenOrdList ol + = -- trace (shows ol "\n") ( + flat ol [] + -- ) + where + flat :: OrdList a -> [a] -> [a] + flat NoObj rest = rest + flat (OrdObj x) rest = x:rest + flat (ParList a b) rest = flat a (flat b rest) + flat (SeqList a b) rest = flat a (flat b rest) + +{- DEBUGGING ONLY: +instance Text (OrdList a) where + showsPrec _ NoObj = showString "_N_" + showsPrec _ (OrdObj _) = showString "_O_" + showsPrec _ (ParList a b) = showString "(PAR " . shows a . showChar ')' + showsPrec _ (SeqList a b) = showString "(SEQ " . shows a . showChar ')' +-} +\end{code} + +This is like mapAccumR, but over OrdList's. + +\begin{code} +{- UNUSED: +mapAccumROrdList :: (s -> a -> (s,b)) -> s -> OrdList a -> (s,OrdList b) +mapAccumROrdList f s NoObj = (s,NoObj) +mapAccumROrdList f s (OrdObj a) = + case f s a of + (s',b) -> (s',OrdObj b) +mapAccumROrdList f s (SeqList vs) = + case mapAccumR (mapAccumROrdList f) s vs of + (s',b) -> (s',SeqList b) +mapAccumROrdList f s (ParList vs) = + case mapAccumR (mapAccumROrdList f) s vs of + (s',b) -> (s',ParList b) + +mapAccumLOrdList :: (s -> a -> (s,b)) -> s -> OrdList a -> (s,OrdList b) +mapAccumLOrdList f s NoObj = (s,NoObj) +mapAccumLOrdList f s (OrdObj a) = + case f s a of + (s',b) -> (s',OrdObj b) +mapAccumLOrdList f s (SeqList vs) = + case mapAccumL (mapAccumLOrdList f) s vs of + (s',b) -> (s',SeqList b) +mapAccumLOrdList f s (ParList vs) = + case mapAccumL (mapAccumLOrdList f) s vs of + (s',b) -> (s',ParList b) + +mapAccumBOrdList :: (accl -> accr -> x -> (accl, accr, y)) + -> accl -> accr -> OrdList x -> (accl, accr, OrdList y) + +mapAccumBOrdList f a b NoObj = (a,b,NoObj) +mapAccumBOrdList f a b (OrdObj x) = + case f a b x of + (a',b',y) -> (a',b',OrdObj y) +mapAccumBOrdList f a b (SeqList xs) = + case mapAccumB (mapAccumBOrdList f) a b xs of + (a',b',ys) -> (a',b',SeqList ys) +mapAccumBOrdList f a b (ParList xs) = + case mapAccumB (mapAccumBOrdList f) a b xs of + (a',b',ys) -> (a',b',ParList ys) +-} +\end{code} + +%------------------------------------------------------------------------ + +In our printing schema, we use @||@ for parallel operations, +and @;@ for sequential ones. + +\begin{code} + +#ifdef _GOFER_ + +instance (Text a) => Text (OrdList a) where + showsPrec _ (ParList [a]) = shows a + showsPrec _ (ParList as ) = showString "( " . + showOurList as " || " . + showString " )" + showsPrec _ (SeqList [a]) = shows a + showsPrec _ (SeqList as ) = showString "( " . + showOurList as " ; " . + showString " )" + showsPrec _ (OrdObj a) = shows a + showsPrec _ (NoObj) = showString "$" + +showOurList :: (Text a) => [a] -> String -> ShowS +showOurList [] s = showString "" +showOurList [a] s = shows a +showOurList (a:as) s = shows a . + showString s . + showOurList as s + +#endif + +\end{code} + diff --git a/ghc/compiler/basicTypes/ProtoName.hi b/ghc/compiler/basicTypes/ProtoName.hi new file mode 100644 index 0000000..65a1e01 --- /dev/null +++ b/ghc/compiler/basicTypes/ProtoName.hi @@ -0,0 +1,45 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ProtoName where +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import TyCon(TyCon) +import Unique(Unique) +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data ProtoName = Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name +cmpByLocalName :: ProtoName -> ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpProtoName :: ProtoName -> ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +elemByLocalNames :: ProtoName -> [ProtoName] -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +elemProtoNames :: ProtoName -> [ProtoName] -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +eqByLocalName :: ProtoName -> ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqProtoName :: ProtoName -> ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +isConopPN :: ProtoName -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkPreludeProtoName :: Name -> ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _!_ _ORIG_ ProtoName Prel [] [u0] _N_ #-} +instance NamedThing ProtoName + {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ProtoName -> ExportFlag), (ProtoName -> Bool), (ProtoName -> (_PackedString, _PackedString)), (ProtoName -> _PackedString), (ProtoName -> [_PackedString]), (ProtoName -> SrcLoc), (ProtoName -> Unique), (ProtoName -> Bool), (ProtoName -> UniType), (ProtoName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ProtoName), _CONSTM_ NamedThing isLocallyDefined (ProtoName), _CONSTM_ NamedThing getOrigName (ProtoName), _CONSTM_ NamedThing getOccurrenceName (ProtoName), _CONSTM_ NamedThing getInformingModules (ProtoName), _CONSTM_ NamedThing getSrcLoc (ProtoName), _CONSTM_ NamedThing getTheUnique (ProtoName), _CONSTM_ NamedThing hasType (ProtoName), _CONSTM_ NamedThing getType (ProtoName), _CONSTM_ NamedThing fromPreludeCore (ProtoName)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: ProtoName) -> case u0 of { _ALG_ _ORIG_ ProtoName Unk (u1 :: _PackedString) -> u1; _ORIG_ ProtoName Imp (u2 :: _PackedString) (u3 :: _PackedString) (u4 :: [_PackedString]) (u5 :: _PackedString) -> u5; _ORIG_ ProtoName Prel (u6 :: Name) -> _APP_ _CONSTM_ NamedThing getOccurrenceName (Name) [ u6 ]; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ProtoName) -> _!_ False [] [] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-} +instance Outputable ProtoName + {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ProtoName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/ProtoName.lhs b/ghc/compiler/basicTypes/ProtoName.lhs new file mode 100644 index 0000000..e7f6bb8 --- /dev/null +++ b/ghc/compiler/basicTypes/ProtoName.lhs @@ -0,0 +1,256 @@ +%************************************************************************ +%* * +\section[ProtoName]{@ProtoName@: name type used early in the compiler} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module ProtoName ( + ProtoName(..), + + mkPreludeProtoName, + + cmpProtoName, eqProtoName, elemProtoNames, + cmpByLocalName, eqByLocalName, elemByLocalNames, + + isConopPN, + + -- and to make the module self-sufficient... + Name, Maybe +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import Name ( cmpName, Name + IF_ATTACK_PRAGMAS(COMMA eqName) + ) +import Outputable +import Pretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsection{The main type declaration} +%* * +%************************************************************************ + +\begin{code} +data ProtoName + = Unk FAST_STRING -- local name in module + + | Imp FAST_STRING -- name of defining module + FAST_STRING -- name used in defining name + [FAST_STRING] -- name of the module whose interfaces + -- told me about this thing + FAST_STRING -- occurrence name; Nothing => same as field 2 + | Prel Name +{- LATER: + | Unk2 FAST_INT -- same as Unk but this FAST_INT is + -- the index into hash table (makes for + -- superbly great equality comparisons!) + FAST_STRING +-} +\end{code} + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + +\begin{code} +mkPreludeProtoName :: Name -> ProtoName + +mkPreludeProtoName prel_name = Prel prel_name +\end{code} + +%************************************************************************ +%* * +\subsection{Ordering} +%* * +%************************************************************************ + +Comparing @ProtoNames@. These functions are used to bring together +duplicate declarations for things, and eliminate all but one. + +In general, the things thus manipulated are not prelude things, but we +still need to be able to compare prelude classes and type constructors +so that we can compare instance declarations. However, since all +Prelude classes and type constructors come from @PreludeCore@, and +hence can't not be in scope, they will always be of the form (@Prel@ +n), so we don't need to compare @Prel@ things against @Imp@ or @Unk@ +things. + +(Later the same night...: but, oh yes, you do: + +Given two instance decls + +\begin{verbatim} +instance Eq {-PreludeCore-} Foo +instance Bar {-user-defined-} Foo +\end{verbatim} + +you will get a comparison of "Eq" (a Prel) with "Bar" (an {Unk,Imp})) + +@cmp_name@ compares either by ``local name'' (the string by which +the entity is known in this module, renaming and all) or by original +name, in which case the module name is also taken into account. +(Just watch what happens on @Imps@...) + +\begin{code} +cmp_name :: Bool -> ProtoName -> ProtoName -> TAG_ + +cmp_name by_local (Unk n1) (Unk n2) = _CMP_STRING_ n1 n2 +cmp_name by_local (Unk n1) (Imp m n2 _ o2) = _CMP_STRING_ n1 (if by_local then o2 else n2) +cmp_name by_local (Unk n1) (Prel nm) + = let (_, n2) = getOrigName nm in + _CMP_STRING_ n1 n2 + +cmp_name by_local (Prel n1) (Prel n2) = cmpName n1 n2 + +-- in ordering these things, it's *most* important to have "names" (vs "modules") +-- as the primary comparison key; otherwise, a list of ProtoNames like... +-- +-- Imp H.T , Imp P.I , Unk T +-- +-- will *not* be re-ordered to bring the "Imp H.T" and "Unk T" `next to each other'... +-- + +cmp_name True (Imp _ _ _ o1) (Imp _ _ _ o2) = _CMP_STRING_ o1 o2 + +cmp_name False (Imp m1 n1 _ _) (Imp m2 n2 _ _) + = case _CMP_STRING_ n1 n2 of { + LT_ -> LT_; + EQ_ -> case _CMP_STRING_ m1 m2 of { + EQ_ -> EQ_; + xxx -> if _NULL_ m1 || _NULL_ m2 + then EQ_ + else xxx + }; + GT__ -> GT_ + } + -- That's a real **HACK** on comparing "original module" names! + -- The thing is: we `make up' ProtoNames for instances for + -- sorting-out-interfaces purposes, but we *may* not know the + -- original module, so it will be Nil. This is the *ONLY* way + -- that a "" `module name' can arise! Rather than say "not equal", + -- we want that Nil to compare as a `wildcard', matching anything. + -- + -- We could do this elsewhere in the compiler, but there is + -- an efficiency issue -- we plow through *piles* of instances. + +cmp_name True (Imp _ _ _ o1) (Prel nm) + = let + n2 = case (getOrigName nm) of { (_, x) -> x } -- stricter for speed + in + _CMP_STRING_ o1 n2 + +cmp_name False (Imp m1 n1 _ _) (Prel nm) + = case getOrigName nm of { (m2, n2) -> + case _CMP_STRING_ n1 n2 of { LT_ -> LT_; EQ_ -> _CMP_STRING_ m1 m2; GT__ -> GT_ }} + +cmp_name by_local other_p1 other_p2 + = case cmp_name by_local other_p2 other_p1 of -- compare the other way around + LT_ -> GT_ + EQ_ -> EQ_ + GT__ -> LT_ +\end{code} + +\begin{code} +eqProtoName, eqByLocalName :: ProtoName -> ProtoName -> Bool + +eqProtoName a b + = case cmp_name False a b of { EQ_ -> True; _ -> False } + +cmpProtoName a b = cmp_name False a b + +eqByLocalName a b + = case cmp_name True a b of { EQ_ -> True; _ -> False } + +cmpByLocalName a b = cmp_name True a b +\end{code} + +\begin{code} +elemProtoNames, elemByLocalNames :: ProtoName -> [ProtoName] -> Bool + +elemProtoNames _ [] = False +elemProtoNames x (y:ys) + = case cmp_name False x y of + LT_ -> elemProtoNames x ys + EQ_ -> True + GT__ -> elemProtoNames x ys + +elemByLocalNames _ [] = False +elemByLocalNames x (y:ys) + = case cmp_name True x y of + LT_ -> elemByLocalNames x ys + EQ_ -> True + GT__ -> elemByLocalNames x ys + +isConopPN :: ProtoName -> Bool +isConopPN (Unk s) = isConop s +isConopPN (Imp _ n _ _) = isConop n -- ToDo: should use occurrence name??? +\end{code} + +%************************************************************************ +%* * +\subsection{Instances} +%* * +%************************************************************************ + +********** REMOVE THESE WHEN WE FIX THE SET-ery IN RenameBinds4 ********* + +\begin{code} +{- THESE INSTANCES ARE TOO DELICATE TO BE USED! +Use eqByLocalName, ...., etc. instead + +instance Eq ProtoName where + a == b = case cmp_name False a b of { EQ_ -> True; _ -> False } + +instance Ord ProtoName where + a < b = case cmp_name False a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a <= b = case cmp_name False a b of { LT_ -> True; EQ_ -> True; GT__ -> False } +-} +\end{code} + +\begin{code} +instance NamedThing ProtoName where + + getOrigName (Unk _) = panic "NamedThing.ProtoName.getOrigName (Unk)" + getOrigName (Imp m s _ _) = (m, s) + getOrigName (Prel name) = getOrigName name + + getOccurrenceName (Unk s) = s + getOccurrenceName (Imp m s _ o) = o + getOccurrenceName (Prel name) = getOccurrenceName name + + hasType pn = False + +#ifdef DEBUG + getSrcLoc pn = panic "NamedThing.ProtoName.getSrcLoc" + getInformingModules pn = panic "NamedThing.ProtoName.getInformingModule" + getTheUnique pn = panic "NamedThing.ProtoName.getUnique" + fromPreludeCore pn = panic "NamedThing.ProtoName.fromPreludeCore" + getExportFlag pn = panic "NamedThing.ProtoName.getExportFlag" + isLocallyDefined pn = panic "NamedThing.ProtoName.isLocallyDefined" + getType pn = panic "NamedThing.ProtoName.getType" +#endif +\end{code} + +\begin{code} +instance Outputable ProtoName where + ppr sty (Unk s) = ppPStr s + ppr sty (Prel name) = ppBeside (ppr sty name) (ifPprShowAll sty (ppPStr SLIT("/PREL"))) + ppr sty (Imp mod dec imod loc) + = ppBesides [ppPStr mod, ppChar '.', ppPStr dec, pp_occur_name dec loc ] + -- ToDo: print "informant modules" if high debugging level + where + pp_occur_name s o | s /= o = ppBesides [ppChar '{', ppPStr o, ppChar '}'] + | otherwise = ppNil +\end{code} diff --git a/ghc/compiler/basicTypes/SplitUniq.hi b/ghc/compiler/basicTypes/SplitUniq.hi new file mode 100644 index 0000000..8466f01 --- /dev/null +++ b/ghc/compiler/basicTypes/SplitUniq.hi @@ -0,0 +1,31 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SplitUniq where +import Unique(Unique, mkUniqueGrimily) +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +getSUnique :: SplitUniqSupply -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)LA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSUniques :: Int -> SplitUniqSupply -> [Unique] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)L" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +initSUs :: SplitUniqSupply -> (SplitUniqSupply -> a) -> (SplitUniqSupply, a) + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(ALL)L" {_A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 6 _/\_ u0 -> \ (u1 :: SplitUniqSupply) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply -> u0) -> let {(u4 :: u0) = _APP_ u3 [ u1 ]} in _!_ _TUP_2 [SplitUniqSupply, u0] [u2, u4] _N_} _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: SplitUniqSupply) (u2 :: SplitUniqSupply -> u0) -> case u1 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u3 :: Int) (u4 :: SplitUniqSupply) (u5 :: SplitUniqSupply) -> let {(u6 :: u0) = _APP_ u2 [ u4 ]} in _!_ _TUP_2 [SplitUniqSupply, u0] [u5, u6]; _NO_DEFLT_ } _N_ #-} +mapAndUnzipSUs :: (a -> SplitUniqSupply -> (b, c)) -> [a] -> SplitUniqSupply -> ([b], [c]) + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +mapSUs :: (a -> SplitUniqSupply -> b) -> [a] -> SplitUniqSupply -> [b] + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +mkSplitUniqSupply :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkUniqueGrimily :: Int# -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-} +returnSUs :: a -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "SL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) -> u1 _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +thenSUs :: (SplitUniqSupply -> a) -> (a -> SplitUniqSupply -> b) -> SplitUniqSupply -> b + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LSS" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> u0) (u3 :: u0 -> SplitUniqSupply -> u1) (u4 :: SplitUniqSupply) -> case _APP_ _ORIG_ SplitUniq splitUniqSupply [ u4 ] of { _ALG_ _TUP_2 (u5 :: SplitUniqSupply) (u6 :: SplitUniqSupply) -> let {(u7 :: u0) = _APP_ u2 [ u5 ]} in _APP_ u3 [ u7, u6 ]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/basicTypes/SplitUniq.lhs b/ghc/compiler/basicTypes/SplitUniq.lhs new file mode 100644 index 0000000..3d408c9 --- /dev/null +++ b/ghc/compiler/basicTypes/SplitUniq.lhs @@ -0,0 +1,305 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[Unique]{The @SplitUniqSupply@ data type (``splittable Unique supply'')} + +\begin{code} +#include "HsVersions.h" + +module SplitUniq ( + SplitUniqSupply, -- abstract types + + getSUnique, getSUniques, -- basic ops + getSUniqueAndDepleted, getSUniquesAndDepleted, -- DEPRECATED! + + SUniqSM(..), -- type: unique supply monad + initSUs, thenSUs, returnSUs, + mapSUs, mapAndUnzipSUs, + + mkSplitUniqSupply, + splitUniqSupply, + + -- to make interface self-sufficient + Unique + IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily) + +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +import Outputable -- class for printing, forcing +import Pretty -- pretty-printing utilities +import PrimOps -- ** DIRECTLY ** +import Unique +import Util + +#if defined(__HBC__) +{-hide import from mkdependHS-} +import + Word +import + NameSupply renaming ( Name to HBC_Name ) +#endif +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ >= 26 +import PreludeGlaST +# else +import PreludePrimIO +import PreludeGlaST ( unsafeInterleaveST + IF_ATTACK_PRAGMAS(COMMA fixST) + ) +# endif +#endif + +infixr 9 `thenUs` + +#ifdef __GLASGOW_HASKELL__ +w2i x = word2Int# x +i2w x = int2Word# x +i2w_s x = (x :: Int#) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[SplitUniqSupply-type]{@SplitUniqSupply@ type and operations} +%* * +%************************************************************************ + +A value of type @SplitUniqSupply@ is unique, and it can +supply {\em one} distinct @Unique@. Also, from the supply, one can +also manufacture an arbitrary number of further @UniqueSupplies@, +which will be distinct from the first and from all others. + +Common type signatures +\begin{code} +-- mkSplitUniqSupply :: differs by implementation! + +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) +getSUnique :: SplitUniqSupply -> Unique +getSUniques :: Int -> SplitUniqSupply -> [Unique] +getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply) +getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Chalmers implementation of @SplitUniqSupply@} +%* * +%************************************************************************ + +\begin{code} +#if defined(__HBC__) + +data SplitUniqSupply = MkSplit NameSupply + +mkSplitUniqSupply :: Char -> SplitUniqSupply -- NB: not the same type + +mkSplitUniqSupply _ = MkSplit initialNameSupply + +splitUniqSupply (MkSplit us) + = case (splitNameSupply us) of { (s1, s2) -> + (MkSplit s1, MkSplit s2) } + +getSUnique supply = error "getSUnique" -- mkUniqueGrimily (getName supply) + +getSUniques i supply + = error "getSUniques" -- [ mkUniqueGrimily (getName s) | s <- take i (listNameSupply supply) ] + +getSUniqueAndDepleted supply + = error "getSUniqueAndDepleted" +{- + let + u = mkUniqueGrimily (getName supply) + (s1, _) = splitNameSupply supply + in + (u, s1) +-} + +getSUniquesAndDepleted i supply + = error "getSUniquesAndDepleted" +{- + = let + supplies = take (i+1) (listNameSupply supply) + uniqs = [ mkUniqueGrimily (getName s) | s <- take i supplies ] + last_supply = drop i supplies + in + (uniqs, last_supply) +-} + +#endif {- end of Chalmers implementation -} +\end{code} + +%************************************************************************ +%* * +\subsubsection{Glasgow implementation of @SplitUniqSupply@} +%* * +%************************************************************************ + +Glasgow Haskell implementation: +\begin{code} +#ifdef __GLASGOW_HASKELL__ + +# ifdef IGNORE_REFERENTIAL_TRANSPARENCY + +data SplitUniqSupply = MkSplitUniqSupply {-does nothing-} + +mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply +mkSplitUniqSupply (MkChar c#) = returnPrimIO MkSplitUniqSupply + +splitUniqSupply _ = (MkSplitUniqSupply, MkSplitUniqSupply) + +getSUnique s = unsafe_mk_unique s + +getSUniques i@(MkInt i#) supply = get_from i# supply + where + get_from 0# s = [] + get_from n# s + = unsafe_mk_unique s : get_from (n# `minusInt#` 1#) s + +getSUniqueAndDepleted s = (unsafe_mk_unique s, MkSplitUniqSupply) + +getSUniquesAndDepleted i@(MkInt i#) s = get_from [] i# s + where + get_from acc 0# s = (acc, MkSplitUniqSupply) + get_from acc n# s + = get_from (unsafe_mk_unique s : acc) (n# `minusInt#` 1#) s + +unsafe_mk_unique supply -- this is the TOTALLY unacceptable bit + = unsafePerformPrimIO ( + _ccall_ genSymZh junk `thenPrimIO` \ (W# u#) -> + returnPrimIO (mkUniqueGrimily (w2i (mask# `or#` u#))) + ) + where + mask# = (i2w (ord# 'x'#)) `shiftL#` (i2w_s 24#) + junk = case supply of { MkSplitUniqSupply -> (1::Int) } + +# else {- slight attention to referential transparency -} + +data SplitUniqSupply + = MkSplitUniqSupply Int -- make the Unique with this + SplitUniqSupply SplitUniqSupply + -- when split => these two supplies +\end{code} + +@mkSplitUniqSupply@ is used to get a @SplitUniqSupply@ started. +\begin{code} + +mkSplitUniqSupply :: Char -> PrimIO SplitUniqSupply + +-- ToDo: 64-bit bugs here!!??? + +mkSplitUniqSupply (MkChar c#) + = let + mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#) + + -- here comes THE MAGIC: + + mk_supply# +{- OLD: + = unsafe_interleave mk_unique `thenPrimIO` \ uniq -> + unsafe_interleave mk_supply# `thenPrimIO` \ s1 -> + unsafe_interleave mk_supply# `thenPrimIO` \ s2 -> + returnPrimIO (MkSplitUniqSupply uniq s1 s2) +-} + = unsafe_interleave ( + mk_unique `thenPrimIO` \ uniq -> + mk_supply# `thenPrimIO` \ s1 -> + mk_supply# `thenPrimIO` \ s2 -> + returnPrimIO (MkSplitUniqSupply uniq s1 s2) + ) + where + -- inlined copy of unsafeInterleavePrimIO; + -- this is the single-most-hammered bit of code + -- in the compiler.... + unsafe_interleave m s + = let + (r, new_s) = m s + in + (r, s) + + mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) -> + returnPrimIO (MkInt (w2i (mask# `or#` u#))) + in + mk_supply# + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +\end{code} + +\begin{code} +getSUnique (MkSplitUniqSupply (MkInt n) _ _) = mkUniqueGrimily n + +getSUniques i@(MkInt i#) supply = i# `get_from` supply + where + get_from 0# _ = [] + get_from n# (MkSplitUniqSupply (MkInt u#) _ s2) + = mkUniqueGrimily u# : get_from (n# `minusInt#` 1#) s2 + +getSUniqueAndDepleted (MkSplitUniqSupply (MkInt n) s1 _) = (mkUniqueGrimily n, s1) + +getSUniquesAndDepleted i@(MkInt i#) supply = get_from [] i# supply + where + get_from acc 0# s = (acc, s) + get_from acc n# (MkSplitUniqSupply (MkInt u#) _ s2) + = get_from (mkUniqueGrimily u# : acc) (n# `minusInt#` 1#) s2 + +# endif {- slight attention to referential transparency -} + +#endif {- end of Glasgow implementation -} +\end{code} + +%************************************************************************ +%* * +\subsection[SplitUniq-monad]{Splittable Unique-supply monad} +%* * +%************************************************************************ + +\begin{code} +type SUniqSM result = SplitUniqSupply -> result + +-- the initUs function also returns the final SplitUniqSupply + +initSUs :: SplitUniqSupply -> SUniqSM a -> (SplitUniqSupply, a) + +initSUs init_us m + = case (splitUniqSupply init_us) of { (s1, s2) -> + (s2, m s1) } + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenSUs #-} +{-# INLINE returnSUs #-} +{-# INLINE splitUniqSupply #-} +#endif +\end{code} + +@thenSUs@ is where we split the @SplitUniqSupply@. +\begin{code} +thenSUs :: SUniqSM a -> (a -> SUniqSM b) -> SUniqSM b + +thenSUs expr cont us + = case (splitUniqSupply us) of { (s1, s2) -> + case (expr s1) of { result -> + cont result s2 }} +\end{code} + +\begin{code} +returnSUs :: a -> SUniqSM a +returnSUs result us = result + +mapSUs :: (a -> SUniqSM b) -> [a] -> SUniqSM [b] + +mapSUs f [] = returnSUs [] +mapSUs f (x:xs) + = f x `thenSUs` \ r -> + mapSUs f xs `thenSUs` \ rs -> + returnSUs (r:rs) + +mapAndUnzipSUs :: (a -> SUniqSM (b,c)) -> [a] -> SUniqSM ([b],[c]) + +mapAndUnzipSUs f [] = returnSUs ([],[]) +mapAndUnzipSUs f (x:xs) + = f x `thenSUs` \ (r1, r2) -> + mapAndUnzipSUs f xs `thenSUs` \ (rs1, rs2) -> + returnSUs (r1:rs1, r2:rs2) +\end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.hi b/ghc/compiler/basicTypes/SrcLoc.hi new file mode 100644 index 0000000..1bb1a0b --- /dev/null +++ b/ghc/compiler/basicTypes/SrcLoc.hi @@ -0,0 +1,21 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SrcLoc where +import Outputable(Outputable) +import PreludePS(_PackedString) +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +mkBuiltinSrcLoc :: SrcLoc + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkGeneratedSrcLoc :: SrcLoc + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkSrcLoc :: _PackedString -> _PackedString -> SrcLoc + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _ORIG_ SrcLoc SrcLoc [] [u0, u1] _N_ #-} +mkSrcLoc2 :: _PackedString -> Int -> SrcLoc + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: Int#) -> _!_ _ORIG_ SrcLoc SrcLoc2 [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: _PackedString) (u1 :: Int) -> case u1 of { _ALG_ I# (u2 :: Int#) -> _!_ _ORIG_ SrcLoc SrcLoc2 [] [u0, u2]; _NO_DEFLT_ } _N_ #-} +mkUnknownSrcLoc :: SrcLoc + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpackSrcLoc :: SrcLoc -> (_PackedString, _PackedString) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance Outputable SrcLoc + {-# GHC_PRAGMA _M_ SrcLoc {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (SrcLoc) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs new file mode 100644 index 0000000..423b4b3 --- /dev/null +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -0,0 +1,84 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +%************************************************************************ +%* * +\section[SrcLoc]{The @SrcLoc@ type} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module SrcLoc ( + SrcLoc, -- abstract + + mkSrcLoc, mkSrcLoc2, -- the usual + mkUnknownSrcLoc, -- "I'm sorry, I haven't a clue" + mkBuiltinSrcLoc, -- something wired into the compiler + mkGeneratedSrcLoc, -- code generated within the compiler + unpackSrcLoc + ) where + +import Outputable +import Pretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +%* * +%************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +\begin{code} +data SrcLoc + = SrcLoc FAST_STRING -- source file name + FAST_STRING -- line number in source file + | SrcLoc2 FAST_STRING -- same, but w/ an Int line# + FAST_INT +\end{code} + +Note that an entity might be imported via more than one route, and +there could be more than one ``definition point'' --- in two or more +\tr{.hi} files. We deemed it probably-unworthwhile to cater for this +rare case. + +%************************************************************************ +%* * +\subsection[SrcLoc-access-fns]{Access functions for names} +%* * +%************************************************************************ + +Things to make 'em: +\begin{code} +mkSrcLoc = SrcLoc +mkSrcLoc2 x IBOX(y) = SrcLoc2 x y +mkUnknownSrcLoc = SrcLoc SLIT("") SLIT("") +mkBuiltinSrcLoc = SrcLoc SLIT("") SLIT("") +mkGeneratedSrcLoc = SrcLoc SLIT("") SLIT("") + +unpackSrcLoc (SrcLoc src_file src_line) = (src_file, src_line) +unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line))) +\end{code} + +%************************************************************************ +%* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +%* * +%************************************************************************ + +\begin{code} +instance Outputable SrcLoc where + ppr PprForUser (SrcLoc src_file src_line) + = ppBesides [ ppChar '"', ppPStr src_file, ppPStr SLIT("\", line "), ppPStr src_line ] + + ppr sty (SrcLoc src_file src_line) + = ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP, + ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")] + + ppr sty (SrcLoc2 src_file src_line) + = ppr sty (SrcLoc src_file (_PK_ (show IBOX(src_line)))) +\end{code} diff --git a/ghc/compiler/basicTypes/Unique.hi b/ghc/compiler/basicTypes/Unique.hi new file mode 100644 index 0000000..579615c --- /dev/null +++ b/ghc/compiler/basicTypes/Unique.hi @@ -0,0 +1,335 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Unique where +import CharSeq(CSeq) +import PreludePS(_PackedString) +import Pretty(PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import UniType(UniType) +infixr 9 `thenUs` +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +type UniqSM a = UniqueSupply -> (UniqueSupply, a) +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +absentErrorIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +arrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +binaryClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +boolTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +buildDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +buildIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +byteArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cCallableClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cReturnableClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cmpTagTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cmpUnique :: Unique -> Unique -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> 0#; False -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> -1#; False -> 1#; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +consDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +dialogueTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doublePrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +enumClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqTagDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqUnique :: Unique -> Unique -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +errorIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +falseDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatingClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +foldlIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +foldrIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +forkIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +fractionalClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +getBuiltinUniques :: Int -> [Unique] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +getUnique :: UniqueSupply -> (UniqueSupply, Unique) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getUniques :: Int -> UniqueSupply -> (UniqueSupply, [Unique]) + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)S" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +gtTagDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +iOTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +initUs :: UniqueSupply -> (UniqueSupply -> (UniqueSupply, a)) -> (UniqueSupply, a) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: UniqueSupply) (u2 :: UniqueSupply -> (UniqueSupply, u0)) -> _APP_ u2 [ u1 ] _N_ #-} +intDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerMinusOneIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerPlusOneIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerZeroIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integralClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ixClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +liftDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +liftTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +listTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ltTagDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mallocPtrDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mallocPtrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mallocPtrTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mapAndUnzipUs :: (a -> UniqueSupply -> (UniqueSupply, (b, c))) -> [a] -> UniqueSupply -> (UniqueSupply, ([b], [c])) + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +mapUs :: (a -> UniqueSupply -> (UniqueSupply, b)) -> [a] -> UniqueSupply -> (UniqueSupply, [b]) + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +mkBuiltinUnique :: Int -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkPrimOpIdUnique :: PrimOp -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkPseudoUnique1 :: Int -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkPseudoUnique2 :: Int -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkPseudoUnique3 :: Int -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkTupleDataConUnique :: Int -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkUnifiableTyVarUnique :: Int -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkUniqueGrimily :: Int# -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-} +mkUniqueSupplyGrimily :: SplitUniqSupply -> UniqueSupply + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: SplitUniqSupply) -> _!_ _ORIG_ Unique MkNewSupply [] [u0] _N_ #-} +mutableArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mutableByteArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +nilDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +numClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ordClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +packCStringIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +parErrorIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +parIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +patErrorIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pprUnique :: Unique -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprUnique10 :: Unique -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +primIoTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ratioDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ratioTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +rationalTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realFloatClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realFracClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldPrimIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +return2GMPsDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +return2GMPsTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +returnIntAndGMPDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +returnIntAndGMPTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +returnUs :: a -> UniqueSupply -> (UniqueSupply, a) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: UniqueSupply) -> _!_ _TUP_2 [UniqueSupply, u0] [u2, u1] _N_ #-} +runBuiltinUs :: (UniqueSupply -> (UniqueSupply, a)) -> a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +runSTIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +seqIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +showUnique :: Unique -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +stTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stablePtrDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stablePtrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stablePtrTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndAddrPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndAddrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndArrayPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndByteArrayPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndByteArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndCharPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndCharPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndDoublePrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndDoublePrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndFloatPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndFloatPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndIntPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndIntPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMallocPtrPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMallocPtrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMutableArrayPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMutableArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMutableByteArrayPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMutableByteArrayPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndPtrPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndPtrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndStablePtrPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndStablePtrPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndSynchVarPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndSynchVarPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndWordPrimDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndWordPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +statePrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stringTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +synchVarPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +textClassKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +thenUs :: (UniqueSupply -> (UniqueSupply, a)) -> (a -> UniqueSupply -> (UniqueSupply, b)) -> UniqueSupply -> (UniqueSupply, b) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: UniqueSupply -> (UniqueSupply, u0)) (u3 :: u0 -> UniqueSupply -> (UniqueSupply, u1)) (u4 :: UniqueSupply) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: UniqueSupply) (u6 :: u0) -> _APP_ u3 [ u6, u5 ]; _NO_DEFLT_ } _N_ #-} +traceIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +trueDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +uniqSupply_u :: UniqueSupply + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpackCStringIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpkUnifiableTyVarUnique :: Unique -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +voidPrimIdKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +voidPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordDataConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordPrimTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordTyConKey :: Unique + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs new file mode 100644 index 0000000..81e3af1 --- /dev/null +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -0,0 +1,866 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Unique]{The @Unique@ data type and a (monadic) supply thereof} + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). + +\begin{code} +#include "HsVersions.h" + +module Unique ( + Unique, + UniqueSupply, -- abstract types + u2i, -- hack: used in UniqFM + getUnique, getUniques, -- basic ops + eqUnique, cmpUnique, -- comparison is everything! + +--not exported: mkUnique, unpkUnique, + mkUniqueGrimily, -- use in SplitUniq only! + mkUniqueSupplyGrimily, -- ditto! (but FALSE: WDP 95/01) + mkUnifiableTyVarUnique, + unpkUnifiableTyVarUnique, + showUnique, pprUnique, pprUnique10, + + UniqSM(..), -- type: unique supply monad + initUs, thenUs, returnUs, + mapUs, mapAndUnzipUs, + + -- the pre-defined unique supplies: +{- NOT exported: + uniqSupply_r, uniqSupply_t, uniqSupply_d, + uniqSupply_s, uniqSupply_c, uniqSupply_T, + uniqSupply_f, + uniqSupply_P, +-} + uniqSupply_u, +#ifdef DPH + -- otherwise, not exported + uniqSupply_p, uniqSupply_S, uniqSupply_L, +#endif + + -- and the access functions for the `builtin' UniqueSupply + getBuiltinUniques, mkBuiltinUnique, runBuiltinUs, + mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, + + -- now all the built-in Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkPrimOpIdUnique, + mkTupleDataConUnique, + + absentErrorIdKey, + runSTIdKey, realWorldPrimIdKey, + arrayPrimTyConKey, + byteArrayPrimTyConKey, --UNUSED: byteArrayDataConKey, byteArrayTyConKey, + binaryClassKey, + boolTyConKey, buildDataConKey, buildIdKey, charDataConKey, + charPrimTyConKey, charTyConKey, cmpTagTyConKey, + consDataConKey, + dialogueTyConKey, + doubleDataConKey, + doublePrimTyConKey, + doubleTyConKey, + enumClassKey, eqClassKey, + eqTagDataConKey, errorIdKey, + falseDataConKey, floatDataConKey, + floatPrimTyConKey, floatTyConKey, floatingClassKey, + foldlIdKey, foldrIdKey, + forkIdKey, + fractionalClassKey, + gtTagDataConKey, --UNUSED: iOErrorTyConKey, +--UNUSED: iOIntPrimTyConKey, -- UNUSED: int2IntegerIdKey, + iOTyConKey, + intDataConKey, + wordPrimTyConKey, wordTyConKey, wordDataConKey, + addrPrimTyConKey, addrTyConKey, addrDataConKey, + intPrimTyConKey, intTyConKey, + integerDataConKey, integerTyConKey, integralClassKey, + ixClassKey, +--UNUSED: lexIdKey, + liftDataConKey, liftTyConKey, listTyConKey, + ltTagDataConKey, + mutableArrayPrimTyConKey, -- UNUSED: mutableArrayDataConKey, mutableArrayTyConKey, + mutableByteArrayPrimTyConKey, -- UNUSED: mutableByteArrayDataConKey, +--UNUSED: mutableByteArrayTyConKey, + synchVarPrimTyConKey, + nilDataConKey, numClassKey, ordClassKey, + parIdKey, parErrorIdKey, +#ifdef GRAN + parGlobalIdKey, parLocalIdKey, copyableIdKey, noFollowIdKey, +#endif + patErrorIdKey, + ratioDataConKey, ratioTyConKey, + rationalTyConKey, +--UNUSED: readParenIdKey, + realClassKey, realFloatClassKey, + realFracClassKey, +--UNUSED: requestTyConKey, responseTyConKey, + return2GMPsDataConKey, return2GMPsTyConKey, + returnIntAndGMPDataConKey, returnIntAndGMPTyConKey, + seqIdKey, -- UNUSED: seqIntPrimTyConKey, +--UNUSED: seqTyConKey, +--UNUSED: showParenIdKey, +--UNUSED: showSpaceIdKey, + statePrimTyConKey, stateTyConKey, stateDataConKey, + voidPrimTyConKey, + realWorldTyConKey, + stablePtrPrimTyConKey, stablePtrTyConKey, stablePtrDataConKey, + mallocPtrPrimTyConKey, mallocPtrTyConKey, mallocPtrDataConKey, + stateAndPtrPrimTyConKey, + stateAndPtrPrimDataConKey, + stateAndCharPrimTyConKey, + stateAndCharPrimDataConKey, + stateAndIntPrimTyConKey, + stateAndIntPrimDataConKey, + stateAndWordPrimTyConKey, + stateAndWordPrimDataConKey, + stateAndAddrPrimTyConKey, + stateAndAddrPrimDataConKey, + stateAndStablePtrPrimTyConKey, + stateAndStablePtrPrimDataConKey, + stateAndMallocPtrPrimTyConKey, + stateAndMallocPtrPrimDataConKey, + stateAndFloatPrimTyConKey, + stateAndFloatPrimDataConKey, + stateAndDoublePrimTyConKey, + stateAndDoublePrimDataConKey, + stateAndArrayPrimTyConKey, + stateAndArrayPrimDataConKey, + stateAndMutableArrayPrimTyConKey, + stateAndMutableArrayPrimDataConKey, + stateAndByteArrayPrimTyConKey, + stateAndByteArrayPrimDataConKey, + stateAndMutableByteArrayPrimTyConKey, + stateAndMutableByteArrayPrimDataConKey, + stateAndSynchVarPrimTyConKey, + stateAndSynchVarPrimDataConKey, + stringTyConKey, + stTyConKey, primIoTyConKey, +--UNUSED: ioResultTyConKey, + textClassKey, + traceIdKey, + trueDataConKey, + unpackCStringIdKey, + packCStringIdKey, + integerZeroIdKey, integerPlusOneIdKey, integerMinusOneIdKey, + voidPrimIdKey, + cCallableClassKey, + cReturnableClassKey, +--UNUSED: packedStringTyConKey, psDataConKey, cpsDataConKey, + + -- to make interface self-sufficient + PrimOp, SplitUniqSupply, CSeq + +#ifndef __GLASGOW_HASKELL__ + , TAG_ +#endif + ) where + +import Outputable -- class for printing, forcing +import Pretty +import PrimOps -- ** DIRECTLY ** +import SplitUniq +import Util + +#ifndef __GLASGOW_HASKELL__ +{-hide import from mkdependHS-} +import + Word +#endif +#ifdef __GLASGOW_HASKELL__ +import PreludeGlaST +#endif + +infixr 9 `thenUs` +\end{code} + +%************************************************************************ +%* * +\subsection[Unique-type]{@Unique@ type and operations} +%* * +%************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: + +\begin{code} +u2i :: Unique -> FAST_INT + +#ifdef __GLASGOW_HASKELL__ + +data Unique = MkUnique Int# +u2i (MkUnique i) = i + +#else + +data Unique = MkUnique Word{-#STRICT#-} +u2i (MkUnique w) = wordToInt w + +#endif +\end{code} + +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. + +\begin{code} +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUnifiableTyVarUnique :: Int -> Unique -- Injects a subst-array index into the Unique type +unpkUnifiableTyVarUnique :: Unique -> Int -- The reverse process + +#ifdef __GLASGOW_HASKELL__ +mkUniqueGrimily :: Int# -> Unique -- A trap-door for SplitUniq +#else +mkUniqueGrimily :: Int -> Unique +#endif +\end{code} + + +\begin{code} +#ifdef __GLASGOW_HASKELL__ +mkUniqueGrimily x = MkUnique x +#else +mkUniqueGrimily x = MkUnique (fromInteger (toInteger x)) +#endif + +mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i + +unpkUnifiableTyVarUnique uniq + = case (unpkUnique uniq) of { (tag, i) -> + ASSERT(tag == '_'{-MAGIC CHAR-}) + i } + +-- pop the Char in the top 8 bits of the Unique(Supply) + +#ifdef __GLASGOW_HASKELL__ + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +w2i x = word2Int# x +i2w x = int2Word# x +i2w_s x = (x::Int#) + +mkUnique (MkChar c#) (MkInt i#) + = MkUnique (w2i (((i2w (ord# c#)) `shiftL#` (i2w_s 24#)) `or#` (i2w i#))) + +unpkUnique (MkUnique u) + = let + tag = MkChar (chr# (w2i ((i2w u) `shiftr` (i2w_s 24#)))) + i = MkInt (w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-})) + in + (tag, i) +# if __GLASGOW_HASKELL__ >= 23 + where + shiftr x y = shiftRA# x y +# else + shiftr x y = shiftR# x y +# endif + +#else {-probably HBC-} + +mkUnique c i + = MkUnique (((fromInt (ord c)) `bitLsh` 24) `bitOr` (fromInt i)) + +unpkUnique (MkUnique u) + = let + tag = chr (wordToInt (u `bitRsh` 24)) + i = wordToInt (u `bitAnd` 16777215 {-0x00ffffff-}) + in + (tag, i) + +#endif {-probably HBC-} +\end{code} + +%************************************************************************ +%* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +%* * +%************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). + +\begin{code} +#ifdef __GLASGOW_HASKELL__ + +{-# INLINE eqUnique #-} -- this is Hammered City here... +{-# INLINE cmpUnique #-} + +eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2 +ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2 +leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2 + +cmpUnique (MkUnique u1) (MkUnique u2) + = if u1 ==# u2 then EQ_ else if u1 <# u2 then LT_ else GT_ + +#else +eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 +leUnique (MkUnique u1) (MkUnique u2) = u1 <= u2 + +cmpUnique (MkUnique u1) (MkUnique u2) + = if u1 == u2 then EQ_ else if u1 < u2 then LT_ else GT_ +#endif + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Ord Unique where + a < b = ltUnique a b + a <= b = leUnique a b + a > b = not (leUnique a b) + a >= b = not (ltUnique a b) +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpUnique a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +And for output: +\begin{code} +{- OLD: +instance Outputable Unique where + ppr any_style uniq + = case unpkUnique uniq of + (tag, u) -> ppStr (tag : iToBase62 u) +-} +\end{code} + +We do sometimes make strings with @Uniques@ in them: +\begin{code} +pprUnique, pprUnique10 :: Unique -> Pretty + +pprUnique uniq + = case unpkUnique uniq of + (tag, u) -> ppBeside (ppChar tag) (iToBase62 u) + +pprUnique10 uniq -- in base-10, dudes + = case unpkUnique uniq of + (tag, u) -> ppBeside (ppChar tag) (ppInt u) + +showUnique :: Unique -> FAST_STRING +showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq)) + +instance Text Unique where + showsPrec p uniq rest = _UNPK_ (showUnique uniq) + readsPrec p = panic "no readsPrec for Unique" +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-base62]{Base-62 numbers} +%* * +%************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. +\begin{code} +iToBase62 :: Int -> Pretty + +#ifdef __GLASGOW_HASKELL__ +iToBase62 n@(I# n#) + = ASSERT(n >= 0) + let + bytes = case chars62 of { _ByteArray bounds_who_needs_'em bytes -> bytes } + in + if n# <# 62# then + case (indexCharArray# bytes n#) of { c -> + ppChar (C# c) } + else + case (quotRem n 62) of { (q, I# r#) -> + case (indexCharArray# bytes r#) of { c -> + ppBeside (iToBase62 q) (ppChar (C# c)) }} + +-- keep this at top level! (bug on 94/10/24 WDP) +chars62 :: _ByteArray Int +chars62 + = _runST ( + newCharArray (0, 61) `thenStrictlyST` \ ch_array -> + fill_in ch_array 0 62 "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + `seqStrictlyST` + unsafeFreezeByteArray ch_array + ) + where + fill_in ch_array i lim str + | i == lim + = returnStrictlyST () + | otherwise + = writeCharArray ch_array i (str !! i) `seqStrictlyST` + fill_in ch_array (i+1) lim str + +#else {- not GHC -} +iToBase62 n + = ASSERT(n >= 0) + if n < 62 then + ppChar (chars62 ! n) + else + case (quotRem n 62) of { (q, r) -> + ppBeside (iToBase62 q) (ppChar (chars62 ! r)) } + +-- keep this at top level! (bug on 94/10/24 WDP) +chars62 :: Array Int Char +chars62 + = array (0,61) (zipWith (:=) [0..] "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") +#endif {- not GHC -} +\end{code} + +%************************************************************************ +%* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +%* * +%************************************************************************ + +\begin{code} +mkPreludeClassUnique i = mkUnique '1' i +mkPreludeTyConUnique i = mkUnique '2' i +mkPreludeDataConUnique i = mkUnique '3' i +mkTupleDataConUnique i = mkUnique '4' i +-- mkPrimOpIdUnique op: see below (uses '5') +mkPreludeMiscIdUnique i = mkUnique '7' i +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +%* * +%************************************************************************ + +\begin{code} +eqClassKey = mkPreludeClassUnique 1 +ordClassKey = mkPreludeClassUnique 2 +numClassKey = mkPreludeClassUnique 3 +integralClassKey = mkPreludeClassUnique 4 +fractionalClassKey = mkPreludeClassUnique 5 +floatingClassKey = mkPreludeClassUnique 6 +realClassKey = mkPreludeClassUnique 7 +realFracClassKey = mkPreludeClassUnique 8 +realFloatClassKey = mkPreludeClassUnique 9 +ixClassKey = mkPreludeClassUnique 10 +enumClassKey = mkPreludeClassUnique 11 +textClassKey = mkPreludeClassUnique 12 +binaryClassKey = mkPreludeClassUnique 13 +cCallableClassKey = mkPreludeClassUnique 14 +cReturnableClassKey = mkPreludeClassUnique 15 +#ifdef DPH +pidClassKey = mkPreludeClassUnique 16 +processorClassKey = mkPreludeClassUnique 17 +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +%* * +%************************************************************************ + +\begin{code} +addrPrimTyConKey = mkPreludeTyConUnique 1 +addrTyConKey = mkPreludeTyConUnique 2 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +--UNUSED:byteArrayTyConKey = mkPreludeTyConUnique 6 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +cmpTagTyConKey = mkPreludeTyConUnique 9 +dialogueTyConKey = mkPreludeTyConUnique 10 +doublePrimTyConKey = mkPreludeTyConUnique 11 +doubleTyConKey = mkPreludeTyConUnique 12 +floatPrimTyConKey = mkPreludeTyConUnique 13 +floatTyConKey = mkPreludeTyConUnique 14 +--UNUSED:iOErrorTyConKey = mkPreludeTyConUnique 14 +--UNUSED:iOIntPrimTyConKey = mkPreludeTyConUnique 15 +iOTyConKey = mkPreludeTyConUnique 16 +intPrimTyConKey = mkPreludeTyConUnique 17 +intTyConKey = mkPreludeTyConUnique 18 +integerTyConKey = mkPreludeTyConUnique 19 +liftTyConKey = mkPreludeTyConUnique 20 +listTyConKey = mkPreludeTyConUnique 21 +mallocPtrPrimTyConKey = mkPreludeTyConUnique 22 +mallocPtrTyConKey = mkPreludeTyConUnique 23 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 24 +--UNUSED:mutableArrayTyConKey = mkPreludeTyConUnique 25 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 26 +--UNUSED:mutableByteArrayTyConKey = mkPreludeTyConUnique 27 +--UNUSED:packedStringTyConKey = mkPreludeTyConUnique 28 +synchVarPrimTyConKey = mkPreludeTyConUnique 29 +ratioTyConKey = mkPreludeTyConUnique 30 +rationalTyConKey = mkPreludeTyConUnique 31 +realWorldTyConKey = mkPreludeTyConUnique 32 +--UNUSED:requestTyConKey = mkPreludeTyConUnique 33 +--UNUSED:responseTyConKey = mkPreludeTyConUnique 34 +return2GMPsTyConKey = mkPreludeTyConUnique 35 +returnIntAndGMPTyConKey = mkPreludeTyConUnique 36 +--UNUSED:seqIntPrimTyConKey = mkPreludeTyConUnique 37 +--UNUSED:seqTyConKey = mkPreludeTyConUnique 38 +stablePtrPrimTyConKey = mkPreludeTyConUnique 39 +stablePtrTyConKey = mkPreludeTyConUnique 40 +stateAndAddrPrimTyConKey = mkPreludeTyConUnique 41 +stateAndArrayPrimTyConKey = mkPreludeTyConUnique 42 +stateAndByteArrayPrimTyConKey = mkPreludeTyConUnique 43 +stateAndCharPrimTyConKey = mkPreludeTyConUnique 44 +stateAndDoublePrimTyConKey = mkPreludeTyConUnique 45 +stateAndFloatPrimTyConKey = mkPreludeTyConUnique 46 +stateAndIntPrimTyConKey = mkPreludeTyConUnique 47 +stateAndMallocPtrPrimTyConKey = mkPreludeTyConUnique 48 +stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 49 +stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 50 +stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 51 +stateAndPtrPrimTyConKey = mkPreludeTyConUnique 52 +stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 53 +stateAndWordPrimTyConKey = mkPreludeTyConUnique 54 +statePrimTyConKey = mkPreludeTyConUnique 55 +stateTyConKey = mkPreludeTyConUnique 56 +stringTyConKey = mkPreludeTyConUnique 57 +stTyConKey = mkPreludeTyConUnique 58 +primIoTyConKey = mkPreludeTyConUnique 59 +--UNUSED:ioResultTyConKey = mkPreludeTyConUnique 60 +voidPrimTyConKey = mkPreludeTyConUnique 61 +wordPrimTyConKey = mkPreludeTyConUnique 62 +wordTyConKey = mkPreludeTyConUnique 63 + +#ifdef DPH +podTyConKey = mkPreludeTyConUnique 64 +interfacePodTyConKey = mkPreludeTyConUnique 65 + +podizedPodTyConKey _ = panic "ToDo:DPH:podizedPodTyConKey" +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +%* * +%************************************************************************ + +\begin{code} +addrDataConKey = mkPreludeDataConUnique 1 +buildDataConKey = mkPreludeDataConUnique 2 +--UNUSED:byteArrayDataConKey = mkPreludeDataConUnique 3 +charDataConKey = mkPreludeDataConUnique 4 +consDataConKey = mkPreludeDataConUnique 5 +doubleDataConKey = mkPreludeDataConUnique 6 +eqTagDataConKey = mkPreludeDataConUnique 7 +falseDataConKey = mkPreludeDataConUnique 8 +floatDataConKey = mkPreludeDataConUnique 9 +gtTagDataConKey = mkPreludeDataConUnique 10 +intDataConKey = mkPreludeDataConUnique 11 +integerDataConKey = mkPreludeDataConUnique 12 +liftDataConKey = mkPreludeDataConUnique 13 +ltTagDataConKey = mkPreludeDataConUnique 14 +mallocPtrDataConKey = mkPreludeDataConUnique 15 +--UNUSED:mutableArrayDataConKey = mkPreludeDataConUnique 16 +--UNUSED:mutableByteArrayDataConKey = mkPreludeDataConUnique 17 +nilDataConKey = mkPreludeDataConUnique 18 +--UNUSED:psDataConKey = mkPreludeDataConUnique 19 +--UNUSED:cpsDataConKey = mkPreludeDataConUnique 20 +ratioDataConKey = mkPreludeDataConUnique 21 +return2GMPsDataConKey = mkPreludeDataConUnique 22 +returnIntAndGMPDataConKey = mkPreludeDataConUnique 23 +stablePtrDataConKey = mkPreludeDataConUnique 24 +stateAndAddrPrimDataConKey = mkPreludeDataConUnique 25 +stateAndArrayPrimDataConKey = mkPreludeDataConUnique 26 +stateAndByteArrayPrimDataConKey = mkPreludeDataConUnique 27 +stateAndCharPrimDataConKey = mkPreludeDataConUnique 28 +stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29 +stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30 +stateAndIntPrimDataConKey = mkPreludeDataConUnique 31 +stateAndMallocPtrPrimDataConKey = mkPreludeDataConUnique 32 +stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33 +stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34 +stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35 +stateAndPtrPrimDataConKey = mkPreludeDataConUnique 36 +stateAndStablePtrPrimDataConKey = mkPreludeDataConUnique 37 +stateAndWordPrimDataConKey = mkPreludeDataConUnique 38 +stateDataConKey = mkPreludeDataConUnique 39 +trueDataConKey = mkPreludeDataConUnique 40 +wordDataConKey = mkPreludeDataConUnique 41 + +#ifdef DPH +interfacePodDataConKey = mkPreludeDataConUnique 42 +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +%* * +%************************************************************************ + +First, for raw @PrimOps@ and their boxed versions: +\begin{code} +mkPrimOpIdUnique :: PrimOp -> Unique + +mkPrimOpIdUnique op = mkUnique '5' IBOX((tagOf_PrimOp op)) +\end{code} + +Now for other non-@DataCon@ @Ids@: +\begin{code} +absentErrorIdKey = mkPreludeMiscIdUnique 1 +buildIdKey = mkPreludeMiscIdUnique 2 +errorIdKey = mkPreludeMiscIdUnique 3 +foldlIdKey = mkPreludeMiscIdUnique 4 +foldrIdKey = mkPreludeMiscIdUnique 5 +forkIdKey = mkPreludeMiscIdUnique 6 +int2IntegerIdKey = mkPreludeMiscIdUnique 7 +integerMinusOneIdKey = mkPreludeMiscIdUnique 8 +integerPlusOneIdKey = mkPreludeMiscIdUnique 9 +integerZeroIdKey = mkPreludeMiscIdUnique 10 +--UNUSED:lexIdKey = mkPreludeMiscIdUnique 11 +packCStringIdKey = mkPreludeMiscIdUnique 12 +parIdKey = mkPreludeMiscIdUnique 13 +parErrorIdKey = mkPreludeMiscIdUnique 14 +patErrorIdKey = mkPreludeMiscIdUnique 15 +--UNUSED:readParenIdKey = mkPreludeMiscIdUnique 16 +realWorldPrimIdKey = mkPreludeMiscIdUnique 17 +runSTIdKey = mkPreludeMiscIdUnique 18 +seqIdKey = mkPreludeMiscIdUnique 19 +--UNUSED:showParenIdKey = mkPreludeMiscIdUnique 20 +--UNUSED:showSpaceIdKey = mkPreludeMiscIdUnique 21 +traceIdKey = mkPreludeMiscIdUnique 22 +unpackCStringIdKey = mkPreludeMiscIdUnique 23 +voidPrimIdKey = mkPreludeMiscIdUnique 24 + +#ifdef GRAN +parLocalIdKey = mkPreludeMiscIdUnique 25 +parGlobalIdKey = mkPreludeMiscIdUnique 26 +noFollowIdKey = mkPreludeMiscIdUnique 27 +copyableIdKey = mkPreludeMiscIdUnique 28 +#endif + +#ifdef DPH +podSelectorIdKey = mkPreludeMiscIdUnique 29 +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[UniqueSupply-type]{@UniqueSupply@ type and operations} +%* * +%************************************************************************ + +\begin{code} +#ifdef __GLASGOW_HASKELL__ +data UniqueSupply + = MkUniqueSupply Int# + | MkNewSupply SplitUniqSupply + +#else +data UniqueSupply + = MkUniqueSupply Word{-#STRICT#-} + | MkNewSupply SplitUniqSupply +#endif +\end{code} + +@mkUniqueSupply@ is used to get a @UniqueSupply@ started. +\begin{code} +mkUniqueSupply :: Char -> UniqueSupply + +#ifdef __GLASGOW_HASKELL__ + +mkUniqueSupply (MkChar c#) + = MkUniqueSupply (w2i ((i2w (ord# c#)) `shiftL#` (i2w_s 24#))) + +#else + +mkUniqueSupply c + = MkUniqueSupply ((fromInt (ord c)) `bitLsh` 24) + +#endif + +mkUniqueSupplyGrimily s = MkNewSupply s +\end{code} + +The basic operation on a @UniqueSupply@ is to get a @Unique@ (or a +few). It's just plain different when splittable vs.~not... +\begin{code} +getUnique :: UniqueSupply -> (UniqueSupply, Unique) + +getUnique (MkUniqueSupply n) +#ifdef __GLASGOW_HASKELL__ + = (MkUniqueSupply (n +# 1#), MkUnique n) +#else + = (MkUniqueSupply (n + 1), MkUnique n) +#endif +getUnique (MkNewSupply s) + = let + (u, s1) = getSUniqueAndDepleted s + in + (MkNewSupply s1, u) + +getUniques :: Int -- how many you want + -> UniqueSupply + -> (UniqueSupply, [Unique]) + +#ifdef __GLASGOW_HASKELL__ +getUniques i@(MkInt i#) (MkUniqueSupply n) + = (MkUniqueSupply (n +# i#), + [ case x of { MkInt x# -> + MkUnique (n +# x#) } | x <- [0 .. i-1] ]) +#else +getUniques i (MkUniqueSupply n) + = (MkUniqueSupply (n + fromInt i), [ MkUnique (n + fromInt x) | x <- [0 .. i-1] ]) +#endif +getUniques i (MkNewSupply s) + = let + (us, s1) = getSUniquesAndDepleted i s + in + (MkNewSupply s1, us) +\end{code} + +[OLD-ish NOTE] Simon says: The last line is preferable over @(n+i, + [n .. (n+i-1)])@, because it is a little lazier. If n=bot +you get ([bot, bot, bot], bot) back instead of (bot,bot). This is +sometimes important for knot-tying. + +Alternatively, if you hate the inefficiency: +\begin{pseudocode} +(range 0, n+i) where range m | m=i = [] + range m = n+m : range (m+1) +\end{pseudocode} + +%************************************************************************ +%* * +\subsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler} +%* * +%************************************************************************ + +Different parts of the compiler have their own @UniqueSupplies@, each +identified by their ``tag letter:'' +\begin{verbatim} + B builtin; for when the compiler conjures @Uniques@ out of + thin air + b a second builtin; we need two in mkWrapperUnfolding (False) + r renamer + t typechecker + d desugarer + p ``podizer'' (DPH only) + s core-to-core simplifier + S ``pod'' simplifier (DPH only) + c core-to-stg + T stg-to-stg simplifier + f flattener (of abstract~C) + L Assembly labels (for native-code generators) + u Printing out unfoldings (so don't have constant renaming) + P profiling (finalCCstg) + + v used in specialised TyVarUniques (see TyVar.lhs) + + 1-9 used for ``prelude Uniques'' (wired-in things; see below) + 1 = classes + 2 = tycons + 3 = data cons + 4 = tuple datacons + 5 = unboxed-primop ids + 6 = boxed-primop ids + 7 = misc ids +\end{verbatim} + +\begin{code} +uniqSupply_r = mkUniqueSupply 'r' +uniqSupply_t = mkUniqueSupply 't' +uniqSupply_d = mkUniqueSupply 'd' +uniqSupply_p = mkUniqueSupply 'p' +uniqSupply_s = mkUniqueSupply 's' +uniqSupply_S = mkUniqueSupply 'S' +uniqSupply_c = mkUniqueSupply 'c' +uniqSupply_T = mkUniqueSupply 'T' +uniqSupply_f = mkUniqueSupply 'f' +uniqSupply_L = mkUniqueSupply 'L' +uniqSupply_u = mkUniqueSupply 'u' +uniqSupply_P = mkUniqueSupply 'P' +\end{code} + +The ``builtin UniqueSupplies'' are more magical. You don't use the +supply, you ask for @Uniques@ directly from it. (They probably aren't +unique, but you know that!) + +\begin{code} +uniqSupply_B = mkUniqueSupply 'B' -- not exported! +uniqSupply_b = mkUniqueSupply 'b' -- not exported! +\end{code} + +\begin{code} +mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUnique1 i = mkUnique 'C' i -- used for getTheUnique on Regs +mkPseudoUnique2 i = mkUnique 'D' i -- ditto +mkPseudoUnique3 i = mkUnique 'E' i -- ditto + +getBuiltinUniques :: Int -> [Unique] +getBuiltinUniques n = map (mkUnique 'B') [1 .. n] +\end{code} + +The following runs a uniq monad expression, using builtin uniq values: +\begin{code} +runBuiltinUs :: UniqSM a -> a +runBuiltinUs m = snd (initUs uniqSupply_B m) +\end{code} + +%************************************************************************ +%* * +\subsection[Unique-monad]{Unique supply monad} +%* * +%************************************************************************ + +A very plain unique-supply monad. + +\begin{code} +type UniqSM result = UniqueSupply -> (UniqueSupply, result) + +-- the initUs function also returns the final UniqueSupply + +initUs :: UniqueSupply -> UniqSM a -> (UniqueSupply, a) + +initUs init_us m = m init_us + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenUs #-} +{-# INLINE returnUs #-} +#endif +\end{code} + +@thenUs@ is are where we split the @UniqueSupply@. +\begin{code} +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b + +thenUs expr cont us + = case (expr us) of + (us1, result) -> cont result us1 +\end{code} + +\begin{code} +returnUs :: a -> UniqSM a +returnUs result us = (us, result) + +mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] + +mapUs f [] = returnUs [] +mapUs f (x:xs) + = f x `thenUs` \ r -> + mapUs f xs `thenUs` \ rs -> + returnUs (r:rs) + +mapAndUnzipUs :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) + +mapAndUnzipUs f [] = returnUs ([],[]) +mapAndUnzipUs f (x:xs) + = f x `thenUs` \ (r1, r2) -> + mapAndUnzipUs f xs `thenUs` \ (rs1, rs2) -> + returnUs (r1:rs1, r2:rs2) +\end{code} diff --git a/ghc/compiler/basicTypes/basicTypes.lit b/ghc/compiler/basicTypes/basicTypes.lit new file mode 100644 index 0000000..6490447 --- /dev/null +++ b/ghc/compiler/basicTypes/basicTypes.lit @@ -0,0 +1,36 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Glasgow Haskell compiler: basicTypes} +\author{The GRASP team} +\date{August 1993} +\maketitle +\begin{rawlatex} +\tableofcontents +\pagebreak +\end{rawlatex} +\end{onlystandalone} + +\begin{onlypartofdoc} +\section[basicTypes]{Basic types in GHC (alphabetically)} +\downsection +\end{onlypartofdoc} + +\input{CLabelInfo.lhs} +\input{BasicLit.lhs} +\input{Id.lhs} +\input{IdInfo.lhs} +\input{Inst.lhs} +\input{NameTypes.lhs} +\input{ProtoName.lhs} +\input{SrcLoc.lhs} +\input{Unique.lhs} + +\upsection +\begin{onlypartofdoc} +\upsection +\end{onlypartofdoc} +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/codeGen/CgBindery.hi b/ghc/compiler/codeGen/CgBindery.hi new file mode 100644 index 0000000..7d11d51 --- /dev/null +++ b/ghc/compiler/codeGen/CgBindery.hi @@ -0,0 +1,88 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgBindery where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgMonad(CgInfoDownwards, CgState, StubFlag) +import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(IdInfo) +import Maybes(Labda) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import StgSyn(StgAtom) +import UniType(UniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data CLabel +type CgBindings = UniqFM CgIdInfo +data CgIdInfo = MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-} +data HeapOffset +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data StableLoc {-# GHC_PRAGMA NoStableLoc | VirAStkLoc Int | VirBStkLoc Int | LitLoc BasicLit | StableAmodeLoc CAddrMode #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data VolatileLoc {-# GHC_PRAGMA NoVolatileLoc | TempVarLoc Unique | RegLoc MagicId | VirHpLoc HeapOffset | VirNodeLoc HeapOffset #-} +bindArgsToRegs :: [Id] -> [MagicId] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _N_ _N_ #-} +bindNewPrimToAmode :: Id -> CAddrMode -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +bindNewToAStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 101 _N_ _S_ "U(LL)AU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +bindNewToBStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 101 _N_ _S_ "U(LL)AU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +bindNewToNode :: Id -> HeapOffset -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 22201 _N_ _S_ "LLLAU(LLL)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 22201 _N_ _S_ "LLLAU(LLL)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +bindNewToTemp :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 201 _N_ _N_ _N_ _N_ #-} +getAtomAmode :: StgAtom Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} +getAtomAmodes :: [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} +getCAddrMode :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getCAddrModeAndInfo :: Id -> CgInfoDownwards -> CgState -> ((CAddrMode, LambdaFormInfo), CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getCAddrModeIfVolatile :: Id -> CgInfoDownwards -> CgState -> (Labda CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getVolatileRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ([MagicId], CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _N_ _N_ _N_ #-} +heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +idInfoToAmode :: PrimKind -> CgIdInfo -> CgInfoDownwards -> CgState -> (CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LU(ASLA)" {_A_ 5 _U_ 21122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +letNoEscapeIdInfo :: Id -> Int -> Int -> LambdaFormInfo -> CgIdInfo + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +maybeAStkLoc :: StableLoc -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: StableLoc) -> case u0 of { _ALG_ _ORIG_ CgBindery VirAStkLoc (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; (u2 :: StableLoc) -> _!_ _ORIG_ Maybes Hamna [Int] [] } _N_ #-} +maybeBStkLoc :: StableLoc -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: StableLoc) -> case u0 of { _ALG_ _ORIG_ CgBindery VirBStkLoc (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; (u2 :: StableLoc) -> _!_ _ORIG_ Maybes Hamna [Int] [] } _N_ #-} +newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +nukeVolatileBinds :: UniqFM CgIdInfo -> UniqFM CgIdInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +rebindToAStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rebindToBStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs new file mode 100644 index 0000000..fbc2fc9 --- /dev/null +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -0,0 +1,416 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CgBindery]{Utility functions related to doing @CgBindings@} + +\begin{code} +#include "HsVersions.h" + +module CgBindery ( + CgBindings(..), CgIdInfo(..){-dubiously concrete-}, + StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-}, + + maybeAStkLoc, maybeBStkLoc, + + stableAmodeIdInfo, heapIdInfo, newTempAmodeAndIdInfo, + letNoEscapeIdInfo, idInfoToAmode, + + nukeVolatileBinds, + + bindNewToAStack, bindNewToBStack, + bindNewToNode, bindNewToReg, bindArgsToRegs, +--UNUSED: bindNewToSameAsOther, + bindNewToTemp, bindNewPrimToAmode, + getAtomAmode, getAtomAmodes, + getCAddrModeAndInfo, getCAddrMode, + getCAddrModeIfVolatile, getVolatileRegs, + rebindToAStack, rebindToBStack, +--UNUSED: rebindToTemp, + + -- and to make a self-sufficient interface... + AbstractC, CAddrMode, HeapOffset, MagicId, CLabel, CgState, + BasicLit, IdEnv(..), UniqFM, + Id, Maybe, Unique, StgAtom, UniqSet(..) + ) where + +IMPORT_Trace -- ToDo: rm (debugging only) +import Outputable +import Unpretty +import PprAbsC + +import AbsCSyn +import CgMonad + +import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) +import CLabelInfo ( mkClosureLabel, CLabel ) +import ClosureInfo +import Id ( getIdKind, toplevelishId, isDataCon, Id ) +import IdEnv -- used to build CgBindings +import Maybes ( catMaybes, Maybe(..) ) +import UniqSet -- ( setToList ) +import StgSyn +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection[Bindery-datatypes]{Data types} +%* * +%************************************************************************ + +@(CgBinding a b)@ is a type of finite maps from a to b. + +The assumption used to be that @lookupCgBind@ must get exactly one +match. This is {\em completely wrong} in the case of compiling +letrecs (where knot-tying is used). An initial binding is fed in (and +never evaluated); eventually, a correct binding is put into the +environment. So there can be two bindings for a given name. + +\begin{code} +type CgBindings = IdEnv CgIdInfo + +data CgIdInfo + = MkCgIdInfo Id -- Id that this is the info for + VolatileLoc + StableLoc + LambdaFormInfo + +data VolatileLoc + = NoVolatileLoc + | TempVarLoc Unique + + | RegLoc MagicId -- in one of the magic registers + -- (probably {Int,Float,Char,etc}Reg + + | VirHpLoc VirtualHeapOffset -- Hp+offset (address of closure) + + | VirNodeLoc VirtualHeapOffset -- Cts of offset indirect from Node + -- ie *(Node+offset) + +data StableLoc + = NoStableLoc + | VirAStkLoc VirtualSpAOffset + | VirBStkLoc VirtualSpBOffset + | LitLoc BasicLit + | StableAmodeLoc CAddrMode + +-- these are so StableLoc can be abstract: + +maybeAStkLoc (VirAStkLoc offset) = Just offset +maybeAStkLoc _ = Nothing + +maybeBStkLoc (VirBStkLoc offset) = Just offset +maybeBStkLoc _ = Nothing +\end{code} + +%************************************************************************ +%* * +\subsection[Bindery-idInfo]{Manipulating IdInfo} +%* * +%************************************************************************ + +\begin{code} +stableAmodeIdInfo i amode lf_info = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc amode) lf_info +heapIdInfo i offset lf_info = MkCgIdInfo i (VirHpLoc offset) NoStableLoc lf_info +tempIdInfo i uniq lf_info = MkCgIdInfo i (TempVarLoc uniq) NoStableLoc lf_info + +letNoEscapeIdInfo i spa spb lf_info + = MkCgIdInfo i NoVolatileLoc (StableAmodeLoc (CJoinPoint spa spb)) lf_info + +newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo) + +newTempAmodeAndIdInfo name lf_info + = (temp_amode, temp_idinfo) + where + uniq = getTheUnique name + temp_amode = CTemp uniq (getIdKind name) + temp_idinfo = tempIdInfo name uniq lf_info + +idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode +idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab + +idInfoPiecesToAmode :: PrimKind -> 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) + +idInfoPiecesToAmode kind NoVolatileLoc (LitLoc lit) = returnFC (CLit lit) +idInfoPiecesToAmode kind NoVolatileLoc (StableAmodeLoc amode) = returnFC amode + +idInfoPiecesToAmode kind (VirNodeLoc nd_off) stable_loc + = returnFC (CVal (NodeRel nd_off) kind) + -- Virtual offsets from Node increase into the closures, + -- and so do Node-relative offsets (which we want in the CVal), + -- so there is no mucking about to do to the offset. + +idInfoPiecesToAmode kind (VirHpLoc hp_off) stable_loc + = getHpRelOffset hp_off `thenFC` \ rel_hp -> + returnFC (CAddr rel_hp) + +idInfoPiecesToAmode kind NoVolatileLoc (VirAStkLoc i) + = getSpARelOffset i `thenFC` \ rel_spA -> + returnFC (CVal rel_spA kind) + +idInfoPiecesToAmode kind NoVolatileLoc (VirBStkLoc i) + = getSpBRelOffset i `thenFC` \ rel_spB -> + returnFC (CVal rel_spB kind) + +idInfoPiecesToAmode kind NoVolatileLoc NoStableLoc = panic "idInfoPiecesToAmode: no loc" +\end{code} + +%************************************************************************ +%* * +\subsection[Bindery-nuke-volatile]{Nuking volatile bindings} +%* * +%************************************************************************ + +We sometimes want to nuke all the volatile bindings; we must be sure +we don't leave any (NoVolatile, NoStable) binds around... + +\begin{code} +nukeVolatileBinds :: CgBindings -> CgBindings +nukeVolatileBinds binds + = mkIdEnv (foldr keep_if_stable [] (rngIdEnv binds)) + where + keep_if_stable (MkCgIdInfo i _ NoStableLoc entry_info) acc = acc + keep_if_stable (MkCgIdInfo i _ stable_loc entry_info) acc + = (i, MkCgIdInfo i NoVolatileLoc stable_loc entry_info) : acc +\end{code} + + +%************************************************************************ +%* * +\subsection[lookup-interface]{Interface functions to looking up bindings} +%* * +%************************************************************************ + +I {\em think} all looking-up is done through @getCAddrMode(s)@. + +\begin{code} +getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) + +getCAddrModeAndInfo name + | not (isLocallyDefined name) + = returnFC (global_amode, mkLFImported name) + + | isDataCon name + = returnFC (global_amode, mkConLFInfo name) + + | otherwise = -- *might* be a nested defn: in any case, it's something whose + -- definition we will know about... + lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> + idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode -> + returnFC (amode, lf_info) + where + global_amode = CLbl (mkClosureLabel name) kind + kind = getIdKind name + +getCAddrMode :: Id -> FCode CAddrMode +getCAddrMode name + = getCAddrModeAndInfo name `thenFC` \ (amode, _) -> + returnFC amode +\end{code} + +\begin{code} +getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode) +getCAddrModeIfVolatile name + | toplevelishId name = returnFC Nothing + | otherwise + = lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) -> + case stable_loc of + NoStableLoc -> -- Aha! So it is volatile! + idInfoPiecesToAmode (getIdKind name) volatile_loc NoStableLoc `thenFC` \ amode -> + returnFC (Just amode) + + a_stable_loc -> returnFC Nothing +\end{code} + +@getVolatileRegs@ gets a set of live variables, and returns a list of +all registers on which these variables depend. These are the regs +which must be saved and restored across any C calls. If a variable is +both in a volatile location (depending on a register) {\em and} a +stable one (notably, on the stack), we modify the current bindings to +forget the volatile one. + +\begin{code} +getVolatileRegs :: PlainStgLiveVars -> FCode [MagicId] + +getVolatileRegs vars + = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff -> + returnFC (catMaybes stuff) + where + snaffle_it var + = lookupBindC var `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> + let + -- commoned-up code... + consider_reg reg + = if not (isVolatileReg reg) then + -- Potentially dies across C calls + -- For now, that's everything; we leave + -- it to the save-macros to decide which + -- regs *really* need to be saved. + returnFC Nothing + else + case stable_loc of + NoStableLoc -> returnFC (Just reg) -- got one! + is_a_stable_loc -> + -- has both volatile & stable locations; + -- force it to rely on the stable location + modifyBindC var nuke_vol_bind `thenC` + returnFC Nothing + in + case volatile_loc of + RegLoc reg -> consider_reg reg + VirHpLoc _ -> consider_reg Hp + VirNodeLoc _ -> consider_reg node + non_reg_loc -> returnFC Nothing + + nuke_vol_bind (MkCgIdInfo i _ stable_loc lf_info) + = MkCgIdInfo i NoVolatileLoc stable_loc lf_info +\end{code} + +\begin{code} +getAtomAmodes :: [PlainStgAtom] -> FCode [CAddrMode] +getAtomAmodes [] = returnFC [] +getAtomAmodes (atom:atoms) + = getAtomAmode atom `thenFC` \ amode -> + getAtomAmodes atoms `thenFC` \ amodes -> + returnFC ( amode : amodes ) + +getAtomAmode :: PlainStgAtom -> FCode CAddrMode + +getAtomAmode (StgVarAtom var) = getCAddrMode var +getAtomAmode (StgLitAtom lit) = returnFC (CLit lit) +\end{code} + +%************************************************************************ +%* * +\subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names} +%* * +%************************************************************************ + +\begin{code} +bindNewToAStack :: (Id, VirtualSpAOffset) -> Code +bindNewToAStack (name, offset) + = addBindC name info + where + info = MkCgIdInfo name NoVolatileLoc (VirAStkLoc offset) mkLFArgument + +bindNewToBStack :: (Id, VirtualSpBOffset) -> Code +bindNewToBStack (name, offset) + = addBindC name info + where + info = MkCgIdInfo name NoVolatileLoc (VirBStkLoc offset) (panic "bindNewToBStack") + -- B-stack things shouldn't need lambda-form info! + +bindNewToNode :: Id -> VirtualHeapOffset -> LambdaFormInfo -> Code +bindNewToNode name offset lf_info + = addBindC name info + where + info = MkCgIdInfo name (VirNodeLoc offset) NoStableLoc lf_info + +-- Create a new temporary whose unique is that in the id, +-- bind the id to it, and return the addressing mode for the +-- temporary. +bindNewToTemp :: Id -> FCode CAddrMode +bindNewToTemp name + = let (temp_amode, id_info) = newTempAmodeAndIdInfo name mkLFArgument + -- This is used only for things we don't know + -- anything about; values returned by a case statement, + -- for example. + in + addBindC name id_info `thenC` + returnFC temp_amode + +bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> Code +bindNewToReg name magic_id lf_info + = addBindC name info + where + info = MkCgIdInfo name (RegLoc magic_id) NoStableLoc lf_info + +bindNewToLit name lit + = addBindC name info + where + info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (error "bindNewToLit") + +bindArgsToRegs :: [Id] -> [MagicId] -> Code +bindArgsToRegs args regs + = listCs (zipWith bind args regs) + where + arg `bind` reg = bindNewToReg arg reg mkLFArgument + +{- UNUSED: +bindNewToSameAsOther :: Id -> PlainStgAtom -> Code +bindNewToSameAsOther name (StgVarAtom old_name) +#ifdef DEBUG + | toplevelishId old_name = panic "bindNewToSameAsOther: global old name" + | otherwise +#endif + = lookupBindC old_name `thenFC` \ old_stuff -> + addBindC name old_stuff + +bindNewToSameAsOther name (StgLitAtom lit) + = addBindC name info + where + info = MkCgIdInfo name NoVolatileLoc (LitLoc lit) (panic "bindNewToSameAsOther") +-} +\end{code} + +@bindNewPrimToAmode@ works only for certain addressing modes, because +those are the only ones we've needed so far! + +\begin{code} +bindNewPrimToAmode :: Id -> CAddrMode -> Code +bindNewPrimToAmode name (CReg reg) = bindNewToReg name reg (panic "bindNewPrimToAmode") + -- was: mkLFArgument + -- LFinfo is irrelevant for primitives +bindNewPrimToAmode name (CTemp uniq kind) + = addBindC name (tempIdInfo name uniq (panic "bindNewPrimToAmode")) + -- LFinfo is irrelevant for primitives + +bindNewPrimToAmode name (CLit lit) = bindNewToLit name lit + +bindNewPrimToAmode name (CVal (SpBRel _ offset) _) + = bindNewToBStack (name, offset) + +bindNewPrimToAmode name (CVal (NodeRel offset) _) + = bindNewToNode name offset (panic "bindNewPrimToAmode node") + -- See comment on idInfoPiecesToAmode for VirNodeLoc + +#ifdef DEBUG +bindNewPrimToAmode name amode + = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug amode))) +#endif +\end{code} + +\begin{code} +rebindToAStack :: Id -> VirtualSpAOffset -> Code +rebindToAStack name offset + = modifyBindC name replace_stable_fn + where + replace_stable_fn (MkCgIdInfo i vol stab einfo) + = MkCgIdInfo i vol (VirAStkLoc offset) einfo + +rebindToBStack :: Id -> VirtualSpBOffset -> Code +rebindToBStack name offset + = modifyBindC name replace_stable_fn + where + replace_stable_fn (MkCgIdInfo i vol stab einfo) + = MkCgIdInfo i vol (VirBStkLoc offset) einfo + +{- UNUSED: +rebindToTemp :: Id -> FCode CAddrMode +rebindToTemp name + = let + (temp_amode, MkCgIdInfo _ new_vol _ _ {-LF info discarded-}) + = newTempAmodeAndIdInfo name (panic "rebindToTemp") + in + modifyBindC name (replace_volatile_fn new_vol) `thenC` + returnFC temp_amode + where + replace_volatile_fn new_vol (MkCgIdInfo i vol stab einfo) + = MkCgIdInfo i new_vol stab einfo +-} +\end{code} + diff --git a/ghc/compiler/codeGen/CgCase.hi b/ghc/compiler/codeGen/CgCase.hi new file mode 100644 index 0000000..9a2ce69 --- /dev/null +++ b/ghc/compiler/codeGen/CgCase.hi @@ -0,0 +1,25 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgCase where +import AbsCSyn(AbstractC) +import BasicLit(BasicLit) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo, StubFlag) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PrimOps(PrimOp) +import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data StgCaseAlternatives a b {-# GHC_PRAGMA StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +cgCase :: StgExpr Id Id -> UniqFM Id -> UniqFM Id -> Unique -> StgCaseAlternatives Id Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "SLLLL" _N_ _N_ #-} +saveVolatileVarsAndRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ((AbstractC, EndOfBlockInfo, Labda Int), CgState) + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs new file mode 100644 index 0000000..1cd7696 --- /dev/null +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -0,0 +1,1107 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%******************************************************** +%* * +\section[CgCase]{Converting @StgCase@ expressions} +%* * +%******************************************************** + +\begin{code} +#include "HsVersions.h" + +module CgCase ( + cgCase, + saveVolatileVarsAndRegs, + + -- and to make the interface self-sufficient... + StgExpr, Id, StgCaseAlternatives, CgState + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import StgSyn +import CgMonad +import AbsCSyn + +import AbsPrel ( PrimOp(..), primOpCanTriggerGC + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( kindFromType, getTyConDataCons, + getUniDataSpecTyCon, getUniDataSpecTyCon_maybe, + isEnumerationTyCon, + UniType + ) +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 CgTailCall ( tailCallBusiness, performReturn ) +import CgUsages -- and even more +import CLabelInfo -- bunches of things... +import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument, + layOutDynCon + )-} +import CmdLineOpts ( GlobalSwitch(..) ) +import CostCentre ( useCurrentCostCentre, CostCentre ) +import BasicLit ( kindOfBasicLit ) +import Id ( getDataConTag, getIdKind, fIRST_TAG, isDataCon, + toplevelishId, getInstantiatedDataConSig, + ConTag(..), DataCon(..) + ) +import Maybes ( catMaybes, Maybe(..) ) +import PrimKind ( getKindSize, isFollowableKind, retKindSize, PrimKind(..) ) +import UniqSet -- ( uniqSetToList, UniqSet(..) ) +import Util +\end{code} + +\begin{code} +data GCFlag + = GCMayHappen -- The scrutinee may involve GC, so everything must be + -- tidy before the code for the scrutinee. + + | NoGC -- The scrutinee is a primitive value, or a call to a + -- primitive op which does no GC. Hence the case can + -- be done inline, without tidying up first. +\end{code} + +It is quite interesting to decide whether to put a heap-check +at the start of each alternative. Of course we certainly have +to do so if the case forces an evaluation, or if there is a primitive +op which can trigger GC. + +A more interesting situation is this: + +\begin{verbatim} + !A!; + ...A... + case x# of + 0# -> !B!; ...B... + default -> !C!; ...C... +\end{verbatim} + +where \tr{!x!} indicates a possible heap-check point. The heap checks +in the alternatives {\em can} be omitted, in which case the topmost +heapcheck will take their worst case into account. + +In favour of omitting \tr{!B!}, \tr{!C!}: + +\begin{itemize} +\item +{\em May} save a heap overflow test, + if ...A... allocates anything. The other advantage + of this is that we can use relative addressing + from a single Hp to get at all the closures so allocated. +\item + No need to save volatile vars etc across the case +\end{itemize} + +Against: + +\begin{itemize} +\item + May do more allocation than reqd. This sometimes bites us + badly. For example, nfib (ha!) allocates about 30\% more space if the + worst-casing is done, because many many calls to nfib are leaf calls + which don't need to allocate anything. + + This never hurts us if there is only one alternative. +\end{itemize} + + +*** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need +to take account of what is live, and that includes all live volatile +variables, even if they also have stable analogues. Furthermore, the +stack pointers must be lined up properly so that GC sees tidy stacks. +If these things are done, then the heap checks can be done at \tr{!B!} and +\tr{!C!} without a full save-volatile-vars sequence. + +\begin{code} +cgCase :: PlainStgExpr + -> PlainStgLiveVars + -> PlainStgLiveVars + -> Unique + -> PlainStgCaseAlternatives + -> Code +\end{code} + +Several special cases for primitive operations. + +******* TO DO TO DO: fix what follows + +Special case for + + case (op x1 ... xn) of + y -> e + +where the type of the case scrutinee is a multi-constuctor algebraic type. +Then we simply compile code for + + let y = op x1 ... xn + in + e + +In this case: + + case (op x1 ... xn) of + C a b -> ... + y -> e + +where the type of the case scrutinee is a multi-constuctor algebraic type. +we just bomb out at the moment. It never happens in practice. + +**** END OF TO DO TO DO + +\begin{code} +cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq + (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs)) + = if not (null alts) then + panic "cgCase: case on PrimOp with default *and* alts\n" + -- For now, die if alts are non-empty + else +#if 0 + pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $ + -- See above TO DO TO DO +#endif + cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs) + where + scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars + Updatable [] scrut + scrut_free_vars = [ fv | StgVarAtom fv <- args, not (toplevelishId fv) ] + -- Hack, hack +\end{code} + + +\begin{code} +cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts + | not (primOpCanTriggerGC op) + = + -- Get amodes for the arguments and results + getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> + let + result_amodes = getPrimAppResultAmodes uniq alts + liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n" + in + -- Perform the operation + getVolatileRegs live_in_alts `thenFC` \ vol_regs -> + + profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind] `thenC` + + absC (COpStmt result_amodes op + arg_amodes -- note: no liveness arg + liveness_mask vol_regs) `thenC` + + profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind] `thenC` + + -- Scrutinise the result + cgInlineAlts NoGC uniq alts + + | otherwise -- *Can* trigger GC + = getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> + + -- 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 op + + op_result_amodes = map CReg op_result_regs + + (op_arg_amodes, liveness_mask, arg_assts) + = makePrimOpArgsRobust op arg_amodes + + liveness_arg = mkIntCLit liveness_mask + in + -- Tidy up in case GC happens... + + -- Nota Bene the use of live_in_whole_case in nukeDeadBindings. + -- Reason: the arg_assts computed above may refer to some stack slots + -- which are not live in the alts. So we mustn't use those slots + -- to save volatile vars in! + nukeDeadBindings live_in_whole_case `thenC` + saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts -> + + getEndOfBlockInfo `thenFC` \ eob_info -> + forkEval eob_info nopC + (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c -> + absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c)) + `thenC` + returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) + Nothing{-no semi-tagging-})) + `thenFC` \ new_eob_info -> + + -- Record the continuation info + setEndOfBlockInfo new_eob_info ( + + -- Now "return" to the inline alternatives; this will get + -- compiled to a fall-through. + let + simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts + + -- do_op_and_continue will be passed an amode for the continuation + do_op_and_continue sequel + = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind] `thenC` + + absC (COpStmt op_result_amodes + op + (pin_liveness op liveness_arg op_arg_amodes) + liveness_mask + [{-no vol_regs-}]) + `thenC` + + profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind] `thenC` + + sequelToAmode sequel `thenFC` \ dest_amode -> + absC (CReturn dest_amode DirectReturn) + + -- Note: we CJump even for algebraic data types, + -- because cgInlineAlts always generates code, never a + -- vector. + in + performReturn simultaneous_assts do_op_and_continue live_in_alts + ) + where + -- for all PrimOps except ccalls, we pin the liveness info + -- on as the first "argument" + -- ToDo: un-duplicate? + + pin_liveness (CCallOp _ _ _ _ _) _ args = args + pin_liveness other_op liveness_arg args + = liveness_arg :args + + vtbl_label = mkVecTblLabel uniq + return_label = mkReturnPtLabel uniq + +\end{code} + +Another special case: scrutinising a primitive-typed variable. No +evaluation required. We don't save volatile variables, nor do we do a +heap-check in the alternatives. Instead, the heap usage of the +alternatives is worst-cased and passed upstream. This can result in +allocating more heap than strictly necessary, but it will sometimes +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 -> + cgPrimAltsGivenScrutinee NoGC amode alts deflt +\end{code} + +Special case: scrutinising a non-primitive variable. +This can be done a little better than the general case, because +we can reuse/trim the stack slot holding the variable (if it is in one). + +\begin{code} +cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-}) + live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _) + = + getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) -> + getAtomAmodes args `thenFC` \ arg_amodes -> + + -- Squish the environment + nukeDeadBindings live_in_alts `thenC` + saveVolatileVarsAndRegs live_in_alts + `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> + + forkEval alts_eob_info + nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info -> + setEndOfBlockInfo scrut_eob_info ( + tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts + ) + +\end{code} + +Finally, here is the general case. + +\begin{code} +cgCase expr live_in_whole_case live_in_alts uniq alts + = -- Figure out what volatile variables to save + nukeDeadBindings live_in_whole_case `thenC` + saveVolatileVarsAndRegs live_in_alts + `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) -> + + -- Save those variables right now! + absC save_assts `thenC` + + forkEval alts_eob_info + (nukeDeadBindings live_in_alts) + (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info -> + + setEndOfBlockInfo scrut_eob_info (cgExpr expr) +\end{code} + +%************************************************************************ +%* * +\subsection[CgCase-primops]{Primitive applications} +%* * +%************************************************************************ + +Get result amodes for a primitive operation, in the case wher GC can't happen. +The amodes are returned in canonical order, ready for the prim-op! + + Alg case: temporaries named as in the alternatives, + plus (CTemp u) for the tag (if needed) + Prim case: (CTemp u) + +This is all disgusting, because these amodes must be consistent with those +invented by CgAlgAlts. + +\begin{code} +getPrimAppResultAmodes + :: Unique + -> PlainStgCaseAlternatives + -> [CAddrMode] +\end{code} + +\begin{code} +-- If there's an StgBindDefault which does use the bound +-- variable, then we can only handle it if the type involved is +-- an enumeration type. That's important in the case +-- of comparisions: +-- +-- case x ># y of +-- r -> f r +-- +-- The only reason for the restriction to *enumeration* types is our +-- inability to invent suitable temporaries to hold the results; +-- Elaborating the CTemp addr mode to have a second uniq field +-- (which would simply count from 1) would solve the problem. +-- Anyway, cgInlineAlts is now capable of handling all cases; +-- it's only this function which is being wimpish. + +getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _)) + | isEnumerationTyCon spec_tycon = [tag_amode] + | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" + where + -- A temporary variable to hold the tag; this is unaffected by GC because + -- the heap-checks in the branches occur after the switch + tag_amode = CTemp uniq IntKind + (spec_tycon, _, _) = getUniDataSpecTyCon ty + +getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) + -- Default is either StgNoDefault or StgBindDefault with unused binder + = case alts of + [_] -> arg_amodes -- No need for a tag + other -> tag_amode : arg_amodes + where + -- A temporary variable to hold the tag; this is unaffected by GC because + -- the heap-checks in the branches occur after the switch + tag_amode = CTemp uniq IntKind + + -- 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 + + arg_amodes :: [CAddrMode] + + -- Turn them into amodes + arg_amodes = concat (map mk_amodes sorted_alts) + mk_amodes (con, args, use_mask, rhs) + = [ CTemp (getTheUnique arg) (getIdKind arg) | arg <- args ] +\end{code} + +The situation is simpler for primitive +results, because there is only one! + +\begin{code} +getPrimAppResultAmodes uniq (StgPrimAlts ty _ _) + = [CTemp uniq kind] + where + kind = kindFromType ty +\end{code} + + +%************************************************************************ +%* * +\subsection[CgCase-alts]{Alternatives} +%* * +%************************************************************************ + +@cgEvalAlts@ returns an addressing mode for a continuation for the +alternatives of a @case@, used in a context when there +is some evaluation to be done. + +\begin{code} +cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any + -> Unique + -> PlainStgCaseAlternatives + -> FCode Sequel -- Any addr modes inside are guaranteed to be a label + -- so that we can duplicate it without risk of + -- duplicating code + +cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) + = -- Generate the instruction to restore cost centre, if any + restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> + + -- Generate sequel info for use downstream + -- At the moment, we only do it if the type is vector-returnable. + -- Reason: if not, then it costs extra to label the + -- alternatives, because we'd get return code like: + -- + -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc } + -- + -- which is worse than having the alt code in the switch statement + + let + (spec_tycon, _, _) = getUniDataSpecTyCon ty + + use_labelled_alts + = case ctrlReturnConvAlg spec_tycon of + VectoredReturn _ -> True + _ -> False + + semi_tagged_stuff + = if not use_labelled_alts then + Nothing -- no semi-tagging info + else + cgSemiTaggedAlts uniq alts deflt -- Just + in + cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt + `thenFC` \ (tagged_alt_absCs, deflt_absC) -> + + mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec -> + + returnFC (CaseAlts return_vec semi_tagged_stuff) + +cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt) + = -- Generate the instruction to restore cost centre, if any + restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore -> + + -- Generate the switch + getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c -> + + -- Generate the labelled block, starting with restore-cost-centre + absC (CRetUnVector vtbl_label + (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c))) + `thenC` + -- Return an amode for the block + returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-}) + where + vtbl_label = mkVecTblLabel uniq + return_label = mkReturnPtLabel uniq +\end{code} + + +\begin{code} +cgInlineAlts :: GCFlag -> Unique + -> PlainStgCaseAlternatives + -> Code +\end{code} + +First case: algebraic case, exactly one alternative, no default. +In this case the primitive op will not have set a temporary to the +tag, so we shouldn't generate a switch statment. Instead we just +do the right thing. + +\begin{code} +cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault) + = cgAlgAltRhs gc_flag con args use_mask rhs +\end{code} + +Second case: algebraic case, several alternatives. +Tag is held in a temporary. + +\begin{code} +cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt) + = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-} + ty alts deflt `thenFC` \ (tagged_alts, deflt_c) -> + + -- Do the switch + absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c) + where + -- A temporary variable to hold the tag; this is unaffected by GC because + -- the heap-checks in the branches occur after the switch + tag_amode = CTemp uniq IntKind +\end{code} + +=========== OLD: we *can* now handle this case ================ + +Next, a case we can't deal with: an algebraic case with no evaluation +required (so it is in-line), and a default case as well. In this case +we require all the alternatives written out, so that we can invent +suitable binders to pass to the PrimOp. A default case defeats this. +Could be fixed, but probably isn't worth it. + +\begin{code} +{- ============= OLD +cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default) + = panic "cgInlineAlts: alg alts with default" +================= END OF OLD -} +\end{code} + +Third (real) case: primitive result type. + +\begin{code} +cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt) + = cgPrimAlts gc_flag uniq ty alts deflt +\end{code} + + +%************************************************************************ +%* * +\subsection[CgCase-alg-alts]{Algebraic alternatives} +%* * +%************************************************************************ + +In @cgAlgAlts@, none of the binders in the alternatives are +assumed to be yet bound. + +\begin{code} +cgAlgAlts :: GCFlag + -> Unique + -> AbstractC -- Restore-cost-centre instruction + -> Bool -- True <=> branches must be labelled + -> UniType -- From the case statement + -> [(Id, [Id], [Bool], PlainStgExpr)] -- The alternatives + -> PlainStgCaseDefault -- The default + -> FCode ([(ConTag, AbstractC)], -- The branches + AbstractC -- The default case + ) +\end{code} + +The case with a default which has a binder is different. We need to +pick all the constructors which aren't handled explicitly by an +alternative, and which return their results in registers, allocate +them explicitly in the heap, and jump to a join point for the default +case. + +OLD: All of this only works if a heap-check is required anyway, because +otherwise it isn't safe to allocate. + +NEW (July 94): now false! It should work regardless of gc_flag, +because of the extra_branches argument now added to forkAlts. + +We put a heap-check at the join point, for the benefit of constructors +which don't need to do allocation. This means that ones which do need +to allocate may end up doing two heap-checks; but that's just too bad. +(We'd need two join labels otherwise. ToDo.) + +It's all pretty turgid anyway. + +\begin{code} +cgAlgAlts gc_flag uniq restore_cc semi_tagging + ty alts deflt@(StgBindDefault binder True{-used-} _) + = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts) + extra_branches + (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt) + where + extra_branches :: [FCode (ConTag, AbstractC)] + extra_branches = catMaybes (map mk_extra_branch default_cons) + + must_label_default = semi_tagging || not (null extra_branches) + + default_join_lbl = mkDefaultLabel uniq + jump_instruction = CJump (CLbl default_join_lbl CodePtrKind) + + (spec_tycon, _, spec_cons) + = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [ + -- ppr PprDebug uniq, + -- ppr PprDebug ty, + -- ppr PprShowAll binder + -- ]))) ( + getUniDataSpecTyCon ty + -- ) + + alt_cons = [ con | (con,_,_,_) <- alts ] + + default_cons = [ spec_con | spec_con <- spec_cons, -- In this type + spec_con `not_elem` alt_cons ] -- Not handled explicitly + where + not_elem = isn'tIn "cgAlgAlts" + + -- (mk_extra_branch con) returns the a maybe for the extra branch for con. + -- The "maybe" is because con may return in heap, in which case there is + -- 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 :: DataCon -> (Maybe (FCode (ConTag, AbstractC))) + + mk_extra_branch con + = ASSERT(isDataCon con) + 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 + closure_lbl = mkClosureLabel con + + -- alloc_code generates code to allocate constructor con, whose args are + -- in the arguments to alloc_code, assigning the result to Node. + alloc_code :: [MagicId] -> Code + + alloc_code regs + = possibleHeapCheck gc_flag regs False ( + buildDynCon binder useCurrentCostCentre con + (map CReg regs) (all zero_size regs) + `thenFC` \ idinfo -> + idInfoToAmode PtrKind idinfo `thenFC` \ amode -> + + absC (CAssign (CReg node) amode) `thenC` + absC jump_instruction + ) + where + zero_size reg = getKindSize (kindFromMagicId reg) == 0 +\end{code} + +Now comes the general case + +\begin{code} +cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt + {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -} + = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts) + [{- No "extra branches" -}] + (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt) +\end{code} + +\begin{code} +cgAlgDefault :: GCFlag + -> Unique -> AbstractC -> Bool -- turgid state... + -> PlainStgCaseDefault -- input + -> FCode AbstractC -- output + +cgAlgDefault gc_flag uniq restore_cc must_label_branch + StgNoDefault + = returnFC AbsCNop + +cgAlgDefault gc_flag uniq restore_cc must_label_branch + (StgBindDefault _ False{-binder not used-} rhs) + + = getAbsC (absC restore_cc `thenC` + possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c -> + let + final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c) + | otherwise = abs_c + in + returnFC final_abs_c + where + lbl = mkDefaultLabel uniq + + +cgAlgDefault gc_flag uniq restore_cc must_label_branch + (StgBindDefault binder True{-binder used-} rhs) + + = -- We have arranged that Node points to the thing, even + -- even if we return in registers + bindNewToReg binder node mkLFArgument `thenC` + getAbsC (absC restore_cc `thenC` + possibleHeapCheck gc_flag [node] False (cgExpr rhs) + -- Node is live, but doesn't need to point at the thing itself; + -- it's ok for Node to point to an indirection or FETCH_ME + -- Hence no need to re-enter Node. + ) `thenFC` \ abs_c -> + + let + final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c) + | otherwise = abs_c + in + returnFC final_abs_c + where + lbl = mkDefaultLabel uniq + + +cgAlgAlt :: GCFlag + -> Unique -> AbstractC -> Bool -- turgid state + -> (Id, [Id], [Bool], PlainStgExpr) + -> FCode (ConTag, AbstractC) + +cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs) + = getAbsC (absC restore_cc `thenC` + cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c -> + let + final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c) + | otherwise = abs_c + in + returnFC (tag, final_abs_c) + where + tag = getDataConTag con + lbl = mkAltLabel uniq tag + +cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code + +cgAlgAltRhs gc_flag con args use_mask rhs + = let + (live_regs, node_reqd) + = case (dataReturnConvAlg con) of + ReturnInHeap -> ([], True) + ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False) + -- Pick the live registers using the use_mask + -- Doing so is IMPORTANT, because with semi-tagging + -- enabled only the live registers will have valid + -- pointers in them. + in + possibleHeapCheck gc_flag live_regs node_reqd ( + (case gc_flag of + NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ -> + nopC + GCMayHappen -> bindConArgs con args + ) `thenC` + cgExpr rhs + ) +\end{code} + +%************************************************************************ +%* * +\subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging} +%* * +%************************************************************************ + +Turgid-but-non-monadic code to conjure up the required info from +algebraic case alternatives for semi-tagging. + +\begin{code} +cgSemiTaggedAlts :: Unique + -> [(Id, [Id], [Bool], PlainStgExpr)] + -> StgCaseDefault Id Id + -> SemiTaggingStuff + +cgSemiTaggedAlts uniq alts deflt + = Just (map st_alt alts, st_deflt deflt) + where + st_deflt StgNoDefault = Nothing + + st_deflt (StgBindDefault binder binder_used _) + = Just (if binder_used then Just binder else Nothing, + (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise? + mkDefaultLabel uniq) + ) + + st_alt (con, args, use_mask, _) + = case (dataReturnConvAlg con) of + + ReturnInHeap -> + -- Ha! Nothing to do; Node already points to the thing + (con_tag, + (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") [], -- ToDo: monadise? + join_label) + ) + + ReturnInRegs regs -> + -- We have to load the live registers from the constructor + -- pointed to by Node. + let + (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs + + used_regs = selectByMask use_mask regs + + used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets, + reg `is_elem` used_regs] + + is_elem = isIn "cgSemiTaggedAlts" + in + (con_tag, + (mkAbstractCs [ + CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") [], -- ToDo: macroise? + CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))], + join_label)) + where + con_tag = getDataConTag 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)) + +\end{code} + +%************************************************************************ +%* * +\subsection[CgCase-prim-alts]{Primitive alternatives} +%* * +%************************************************************************ + +@cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the +alternatives of a primitive @case@, given an addressing mode for the +thing to scrutinise. It also keeps track of the maximum stack depth +encountered down any branch. + +As usual, no binders in the alternatives are yet bound. + +\begin{code} +cgPrimAlts :: GCFlag + -> Unique + -> UniType + -> [(BasicLit, PlainStgExpr)] -- Alternatives + -> PlainStgCaseDefault -- Default + -> Code + +cgPrimAlts gc_flag uniq ty alts deflt + = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt + where + -- A temporary variable, or standard register, to hold the result + scrutinee = case gc_flag of + NoGC -> CTemp uniq kind + GCMayHappen -> CReg (dataReturnConvPrim kind) + + kind = kindFromType ty + + +cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt + = forkAlts (map (cgPrimAlt gc_flag) alts) + [{- No "extra branches" -}] + (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) -> + absC (CSwitch scrutinee alt_absCs deflt_absC) + -- CSwitch does sensible things with one or zero alternatives + + +cgPrimAlt :: GCFlag + -> (BasicLit, PlainStgExpr) -- The alternative + -> FCode (BasicLit, AbstractC) -- Its compiled form + +cgPrimAlt gc_flag (lit, rhs) + = getAbsC rhs_code `thenFC` \ absC -> + returnFC (lit,absC) + where + rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs ) + +cgPrimDefault :: GCFlag + -> CAddrMode -- Scrutinee + -> PlainStgCaseDefault + -> FCode AbstractC + +cgPrimDefault gc_flag scrutinee StgNoDefault + = panic "cgPrimDefault: No default in prim case" + +cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs) + = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs )) + +cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs) + = getAbsC (possibleHeapCheck gc_flag regs False rhs_code) + where + regs = if isFollowableKind (getAmodeKind scrutinee) then + [node] else [] + + rhs_code = bindNewPrimToAmode binder scrutinee `thenC` + cgExpr rhs +\end{code} + + +%************************************************************************ +%* * +\subsection[CgCase-tidy]{Code for tidying up prior to an eval} +%* * +%************************************************************************ + +\begin{code} +saveVolatileVarsAndRegs + :: PlainStgLiveVars -- Vars which should be made safe + -> FCode (AbstractC, -- Assignments to do the saves + EndOfBlockInfo, -- New sequel, recording where the return + -- address now is + Maybe VirtualSpBOffset) -- Slot for current cost centre + + +saveVolatileVarsAndRegs vars + = saveVolatileVars vars `thenFC` \ var_saves -> + saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) -> + saveReturnAddress `thenFC` \ (new_eob_info, ret_save) -> + returnFC (mkAbstractCs [var_saves, cc_save, ret_save], + new_eob_info, + maybe_cc_slot) + + +saveVolatileVars :: PlainStgLiveVars -- Vars which should be made safe + -> FCode AbstractC -- Assignments to to the saves + +saveVolatileVars vars + = save_em (uniqSetToList vars) + where + save_em [] = returnFC AbsCNop + + save_em (var:vars) + = getCAddrModeIfVolatile var `thenFC` \ v -> + case v of + Nothing -> save_em vars -- Non-volatile, so carry on + + + Just vol_amode -> -- Aha! It's volatile + save_var var vol_amode `thenFC` \ abs_c -> + save_em vars `thenFC` \ abs_cs -> + returnFC (abs_c `mkAbsCStmts` abs_cs) + + save_var var vol_amode + | isFollowableKind kind + = allocAStack `thenFC` \ a_slot -> + rebindToAStack var a_slot `thenC` + getSpARelOffset a_slot `thenFC` \ spa_rel -> + returnFC (CAssign (CVal spa_rel kind) vol_amode) + | otherwise + = allocBStack (getKindSize kind) `thenFC` \ b_slot -> + rebindToBStack var b_slot `thenC` + getSpBRelOffset b_slot `thenFC` \ spb_rel -> + returnFC (CAssign (CVal spb_rel kind) vol_amode) + where + kind = getAmodeKind vol_amode + +saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC) +saveReturnAddress + = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) -> + + -- See if it is volatile + case sequel of + InRetReg -> -- Yes, it's volatile + allocBStack retKindSize `thenFC` \ b_slot -> + getSpBRelOffset b_slot `thenFC` \ spb_rel -> + + returnFC (EndOfBlockInfo vA vB (OnStack b_slot), + CAssign (CVal spb_rel RetKind) (CReg RetReg)) + + UpdateCode _ -> -- It's non-volatile all right, but we still need + -- to allocate a B-stack slot for it, *solely* to make + -- sure that update frames for different values do not + -- appear adjacent on the B stack. This makes sure + -- that B-stack squeezing works ok. + -- See note below + allocBStack retKindSize `thenFC` \ b_slot -> + returnFC (eob_info, AbsCNop) + + other -> -- No, it's non-volatile, so do nothing + returnFC (eob_info, AbsCNop) +\end{code} + +Note about B-stack squeezing. Consider the following:` + + y = [...] \u [] -> ... + x = [y] \u [] -> case y of (a,b) -> a + +The code for x will push an update frame, and then enter y. The code +for y will push another update frame. If the B-stack-squeezer then +wakes up, it will see two update frames right on top of each other, +and will combine them. This is WRONG, of course, because x's value is +not the same as y's. + +The fix implemented above makes sure that we allocate an (unused) +B-stack slot before entering y. You can think of this as holding the +saved value of RetAddr, which (after pushing x's update frame will be +some update code ptr). The compiler is clever enough to load the +static update code ptr into RetAddr before entering ~a~, but the slot +is still there to separate the update frames. + +When we save the current cost centre (which is done for lexical +scoping), we allocate a free B-stack location, and return (a)~the +virtual offset of the location, to pass on to the alternatives, and +(b)~the assignment to do the save (just as for @saveVolatileVars@). + +\begin{code} +saveCurrentCostCentre :: + FCode (Maybe VirtualSpBOffset, -- Where we decide to store it + -- Nothing if not lexical CCs + AbstractC) -- Assignment to save it + -- AbsCNop if not lexical CCs + +saveCurrentCostCentre + = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling -> + if not doing_profiling then + returnFC (Nothing, AbsCNop) + else + allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot -> + getSpBRelOffset b_slot `thenFC` \ spb_rel -> + returnFC (Just b_slot, + CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre)) + +restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC + +restoreCurrentCostCentre Nothing + = returnFC AbsCNop +restoreCurrentCostCentre (Just b_slot) + = getSpBRelOffset b_slot `thenFC` \ spb_rel -> + freeBStkSlot b_slot `thenC` + returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind]) + -- we use the RESTORE_CCC macro, rather than just + -- assigning into CurCostCentre, in case RESTORE_CCC + -- has some sanity-checking in it. +\end{code} + + +%************************************************************************ +%* * +\subsection[CgCase-return-vec]{Building a return vector} +%* * +%************************************************************************ + +Build a return vector, and return a suitable label addressing +mode for it. + +\begin{code} +mkReturnVector :: Unique + -> UniType + -> [(ConTag, AbstractC)] -- Branch codes + -> AbstractC -- Default case + -> FCode CAddrMode + +mkReturnVector uniq ty tagged_alt_absCs deflt_absC + = let + (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of { + + UnvectoredReturn _ -> + (CUnVecLbl ret_label vtbl_label, + absC (CRetUnVector vtbl_label + (CLabelledCode ret_label + (mkAlgAltsCSwitch (CReg TagReg) + tagged_alt_absCs + deflt_absC)))); + VectoredReturn table_size -> + (CLbl vtbl_label DataPtrKind, + absC (CRetVector vtbl_label + -- must restore cc before each alt, if required + (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)]) + deflt_absC)) + +-- Leave nops and comments in for now; they are eliminated +-- lazily as it's printed. +-- (case (nonemptyAbsC deflt_absC) of +-- Nothing -> AbsCNop +-- Just def -> def) + + } in + vtbl_body `thenC` + returnFC return_vec_amode + -- ) + where + + (spec_tycon,_,_) = case (getUniDataSpecTyCon_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))) + + vtbl_label = mkVecTblLabel uniq + ret_label = mkReturnPtLabel uniq + + mk_vector_entry :: ConTag -> Maybe CAddrMode + mk_vector_entry tag + = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of + [] -> Nothing + [absC] -> Just (CCode absC) + _ -> panic "mkReturnVector: too many" +\end{code} + +%************************************************************************ +%* * +\subsection[CgCase-utils]{Utilities for handling case expressions} +%* * +%************************************************************************ + +@possibleHeapCheck@ tests a flag passed in to decide whether to +do a heap check or not. + +\begin{code} +possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code + +possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code +possibleHeapCheck NoGC _ _ code = code +\end{code} + +Select a restricted set of registers based on a usage mask. + +\begin{code} +selectByMask [] [] = [] +selectByMask (True:ms) (x:xs) = x : selectByMask ms xs +selectByMask (False:ms) (x:xs) = selectByMask ms xs +\end{code} diff --git a/ghc/compiler/codeGen/CgClosure.hi b/ghc/compiler/codeGen/CgClosure.hi new file mode 100644 index 0000000..fcdb52d --- /dev/null +++ b/ghc/compiler/codeGen/CgClosure.hi @@ -0,0 +1,32 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgClosure where +import AbsCSyn(AbstractC) +import CgBindery(CgIdInfo, StableLoc, VolatileLoc) +import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, StubFlag) +import ClosureInfo(LambdaFormInfo) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CgIdInfo {-# GHC_PRAGMA MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo #-} +data CgInfoDownwards {-# GHC_PRAGMA MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data CompilationInfo {-# GHC_PRAGMA MkCompInfo (GlobalSwitch -> Bool) _PackedString #-} +data HeapOffset +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-} +cgRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState) + {-# GHC_PRAGMA _A_ 7 _U_ 222222222 _N_ _S_ "LLLLLLS" _N_ _N_ #-} +cgTopRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState) + {-# GHC_PRAGMA _A_ 6 _U_ 22222222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs new file mode 100644 index 0000000..93aabe1 --- /dev/null +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -0,0 +1,1014 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CgClosure]{Code generation for closures} + +This module provides the support code for @StgToAbstractC@ to deal +with {\em closures} on the RHSs of let(rec)s. See also +@CgCon@, which deals with constructors. + +\begin{code} +#include "HsVersions.h" + +module CgClosure ( + cgTopRhsClosure, cgRhsClosure, + + -- and to make the interface self-sufficient... + StgExpr, Id, CgState, Maybe, HeapOffset, + CgInfoDownwards, CgIdInfo, CompilationInfo, + UpdateFlag + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty -- NB: see below + +import StgSyn +import CgMonad +import AbsCSyn + +import AbsPrel ( PrimOp(..), primOpNameInfo, Name + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( isPrimType, isPrimTyCon, + getTauType, showTypeCategory, getTyConDataCons + IF_ATTACK_PRAGMAS(COMMA splitType) + IF_ATTACK_PRAGMAS(COMMA splitTyArgs) + ) +import CgBindery ( getCAddrMode, getAtomAmodes, + getCAddrModeAndInfo, + bindNewToNode, bindNewToAStack, bindNewToBStack, + bindNewToReg, bindArgsToRegs + ) +import CgCompInfo ( spARelToInt, spBRelToInt ) +import CgExpr ( cgExpr, cgSccExpr ) +import CgUpdate ( pushUpdateFrame ) +import CgHeapery ( allocDynClosure, heapCheck +#ifdef GRAN + , heapCheckOnly, fetchAndReschedule -- HWL +#endif {- GRAN -} + ) +import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask, + CtrlReturnConvention(..), DataReturnConvention(..) + ) +import CgStackery ( getFinalStackHW, mkVirtStkOffsets, + adjustRealSps + ) +import CgUsages ( getVirtSps, setRealAndVirtualSps, + getSpARelOffset, getSpBRelOffset, + getHpRelOffset + ) +import CLabelInfo +import ClosureInfo -- lots and lots of stuff +import CmdLineOpts ( GlobalSwitch(..) ) +import CostCentre +import Id ( getIdUniType, getIdKind, isSysLocalId, myWrapperMaybe, + showId, getIdInfo, getIdStrictness, + getDataConTag + ) +import IdInfo +import ListSetOps ( minusList ) +import Maybes ( Maybe(..), maybeToBool ) +import PrimKind ( isFollowableKind ) +import UniqSet +import Unpretty +import Util +\end{code} + +%******************************************************** +%* * +\subsection[closures-no-free-vars]{Top-level closures} +%* * +%******************************************************** + +For closures bound at top level, allocate in static space. +They should have no free variables. + +\begin{code} +cgTopRhsClosure :: Id + -> CostCentre -- Optional cost centre annotation + -> StgBinderInfo + -> [Id] -- Args + -> PlainStgExpr + -> LambdaFormInfo + -> FCode (Id, CgIdInfo) +\end{code} + +\begin{code} +{- NOT USED: +cgTopRhsClosure name cc binder_info args body lf_info + | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK + = ( + -- LAY OUT THE OBJECT + getAtomAmodes std_thunk_payload `thenFC` \ amodes -> + let + (closure_info, amodes_w_offsets) = layOutStaticClosure name getAmodeKind amodes lf_info + in + + -- BUILD THE OBJECT + chooseStaticCostCentre cc lf_info `thenFC` \ cost_centre -> + absC (CStaticClosure + closure_label -- Labelled with the name on lhs of defn + closure_info + cost_centre + (map fst amodes_w_offsets)) -- They are in the correct order + ) `thenC` + + returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info) + where + maybe_std_thunk = getStandardFormThunkInfo lf_info + Just std_thunk_payload = maybe_std_thunk + + closure_label = mkClosureLabel name +-} +\end{code} + +The general case: +\begin{code} +cgTopRhsClosure name cc binder_info args body lf_info + = -- LAY OUT THE OBJECT + let + closure_info = layOutStaticNoFVClosure name lf_info + in + + -- GENERATE THE INFO TABLE (IF NECESSARY) + forkClosureBody (closureCodeBody binder_info closure_info + cc args body) + `thenC` + + -- BUILD VAP INFO TABLES IF NECESSARY + -- Don't build Vap info tables etc for + -- a function whose result is an unboxed type, + -- because we can never have thunks with such a type. + (if closureReturnsUnboxedType closure_info then + nopC + else + let + bind_the_fun = addBindC name cg_id_info -- It's global! + in + cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info + ) `thenC` + + -- BUILD THE OBJECT (IF NECESSARY) + (if staticClosureRequired name binder_info lf_info + then + let + cost_centre = mkCCostCentre cc + in + absC (CStaticClosure + closure_label -- Labelled with the name on lhs of defn + closure_info + cost_centre + []) -- No fields + else + nopC + ) `thenC` + + returnFC (name, cg_id_info) + where + closure_label = mkClosureLabel name + cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info +\end{code} + +%******************************************************** +%* * +\subsection[non-top-level-closures]{Non top-level closures} +%* * +%******************************************************** + +For closures with free vars, allocate in heap. + +===================== OLD PROBABLY OUT OF DATE COMMENTS ============= + +-- Closures which (a) have no fvs and (b) have some args (i.e. +-- combinator functions), are allocated statically, just as if they +-- were top-level closures. We can't get a space leak that way +-- (because they are HNFs) and it saves allocation. + +-- Lexical Scoping: Problem +-- These top level function closures will be inherited, possibly +-- to a different cost centre scope set before entering. + +-- Evaluation Scoping: ok as already in HNF + +-- Should rely on floating mechanism to achieve this floating to top level. +-- As let floating will avoid floating which breaks cost centre attribution +-- everything will be OK. + +-- Disabled: because it breaks lexical-scoped cost centre semantics. +-- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body +-- = cgTopRhsClosure binder cc bi upd_flag args body + +===================== END OF OLD PROBABLY OUT OF DATE COMMENTS ============= + +\begin{code} +cgRhsClosure :: Id + -> CostCentre -- Optional cost centre annotation + -> StgBinderInfo + -> [Id] -- Free vars + -> [Id] -- Args + -> PlainStgExpr + -> LambdaFormInfo + -> FCode (Id, CgIdInfo) + +cgRhsClosure binder cc binder_info fvs args body lf_info + | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK + -- ToDo: check non-primitiveness (ASSERT) + = ( + -- LAY OUT THE OBJECT + getAtomAmodes std_thunk_payload `thenFC` \ amodes -> + let + (closure_info, amodes_w_offsets) + = layOutDynClosure binder getAmodeKind amodes lf_info + + (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body + in + -- BUILD THE OBJECT + allocDynClosure closure_info use_cc blame_cc amodes_w_offsets + ) + `thenFC` \ heap_offset -> + + -- RETURN + returnFC (binder, heapIdInfo binder heap_offset lf_info) + + where + maybe_std_thunk = getStandardFormThunkInfo lf_info + Just std_thunk_payload = maybe_std_thunk +\end{code} + +Here's the general case. +\begin{code} +cgRhsClosure binder cc binder_info fvs args body lf_info + = ( + -- LAY OUT THE OBJECT + -- + -- If the binder is itself a free variable, then don't store + -- it in the closure. Instead, just bind it to Node on entry. + -- NB we can be sure that Node will point to it, because we + -- havn't told mkClosureLFInfo about this; so if the binder + -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is* + -- stored in the closure itself, so it will make sure that + -- Node points to it... + let + is_elem = isIn "cgRhsClosure" + + binder_is_a_fv = binder `is_elem` fvs + reduced_fvs = if binder_is_a_fv + then fvs `minusList` [binder] + else fvs + in + mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info -> + let + fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info + + closure_info :: ClosureInfo + bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)] + + (closure_info, bind_details) + = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info + + bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info + + amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details] + + get_kind (id, amode_and_info) = getIdKind id + in + -- BUILD ITS INFO TABLE AND CODE + forkClosureBody ( + -- Bind the fvs + mapCs bind_fv bind_details `thenC` + + -- Bind the binder itself, if it is a free var + (if binder_is_a_fv then + bindNewToReg binder node lf_info + else + nopC) `thenC` + + -- Compile the body + closureCodeBody binder_info closure_info cc args body + ) `thenC` + + -- BUILD VAP INFO TABLES IF NECESSARY + -- Don't build Vap info tables etc for + -- a function whose result is an unboxed type, + -- because we can never have thunks with such a type. + (if closureReturnsUnboxedType closure_info then + nopC + else + cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info + ) `thenC` + + -- BUILD THE OBJECT + let + (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body + in + allocDynClosure closure_info use_cc blame_cc amodes_w_offsets + ) `thenFC` \ heap_offset -> + + -- RETURN + returnFC (binder, heapIdInfo binder heap_offset lf_info) +\end{code} + +@cgVapInfoTables@ generates both Vap info tables, if they are required +at all. It calls @cgVapInfoTable@ to generate each Vap info table, +along with its entry code. + +\begin{code} +-- Don't generate Vap info tables for thunks; only for functions +cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info + = nopC + +cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info + = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY + (if stdVapRequired binder_info then + cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info + else + nopC + ) `thenC` + + -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY + (if noUpdVapRequired binder_info then + cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info + else + nopC + ) + + where + fun_in_payload = not top_level + +cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info + = let + -- The vap_entry_rhs is a manufactured STG expression which + -- looks like the RHS of any binding which is going to use the vap-entry + -- point of the function. Each of these bindings will look like: + -- + -- x = [a,b,c] \upd [] -> f a b c + -- + -- If f is not top-level, then f is one of the free variables too, + -- hence "payload_ids" isn't the same as "arg_ids". + -- + vap_entry_rhs = StgApp (StgVarAtom fun) (map StgVarAtom args) emptyUniqSet + -- Empty live vars + + arg_ids_w_info = [(name,mkLFArgument) | name <- args] + payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info + | otherwise = arg_ids_w_info + + payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo + | otherwise = args + + vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids + upd_flag [] vap_entry_rhs + -- It's not top level, even if we're currently compiling a top-level + -- function, because any VAP *use* of this function will be for a + -- local thunk, thus + -- let x = f p q -- x isn't top level! + -- in ... + + get_kind (id, info) = getIdKind id + + payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)] + (closure_info, payload_bind_details) = layOutDynClosure + fun + get_kind payload_ids_w_info + vap_lf_info + -- The dodgy thing is that we use the "fun" as the + -- Id to give to layOutDynClosure. This Id gets embedded in + -- the closure_info it returns. But of course, the function doesn't + -- have the right type to match the Vap closure. Never mind, + -- a hack in closureType spots the special case. Otherwise that + -- Id is just used for label construction, which is OK. + + bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info + in + + -- BUILD ITS INFO TABLE AND CODE + forkClosureBody ( + + -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells + -- how to bind it. If it is in payload it'll be bound by payload_bind_details. + perhaps_bind_the_fun `thenC` + mapCs bind_fv payload_bind_details `thenC` + + -- Generate the info table and code + closureCodeBody NoStgBinderInfo + closure_info + useCurrentCostCentre + [] -- No args; it's a thunk + vap_entry_rhs + ) +\end{code} +%************************************************************************ +%* * +\subsection[code-for-closures]{The code for closures} +%* * +%************************************************************************ + +\begin{code} +closureCodeBody :: StgBinderInfo + -> ClosureInfo -- Lots of information about this closure + -> CostCentre -- Optional cost centre attached to closure + -> [Id] + -> PlainStgExpr + -> Code +\end{code} + +There are two main cases for the code for closures. If there are {\em +no arguments}, then the closure is a thunk, and not in normal form. +So it should set up an update frame (if it is shared). Also, it has +no argument satisfaction check, so fast and slow entry-point labels +are the same. + +\begin{code} +closureCodeBody binder_info closure_info cc [] body + = -- thunks cannot have a primitive type! +#ifdef DEBUG + let + (has_tycon, tycon) + = case (closureType closure_info) of + Nothing -> (False, panic "debug") + Just (tc,_,_) -> (True, tc) + in + if has_tycon && isPrimTyCon tycon then + pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon) + else +#endif + getAbsC body_code `thenFC` \ body_absC -> +#ifndef DPH + moduleName `thenFC` \ mod_name -> + absC (CClosureInfoAndCode closure_info body_absC Nothing stdUpd (cl_descr mod_name)) +#else + -- Applying a similar scheme to Simon's placing info tables before code... + -- ToDo:DPH: update + absC (CNativeInfoTableAndCode closure_info + closure_description + (CCodeBlock entry_label body_absC)) +#endif {- Data Parallel Haskell -} + where + cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body + + body_addr = CLbl (entryLabelFromCI closure_info) CodePtrKind + body_code = profCtrC SLIT("ENT_THK") [] `thenC` + enterCostCentreCode closure_info cc IsThunk `thenC` + thunkWrapper closure_info (cgSccExpr body) + + stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind +\end{code} + +If there is {\em at least one argument}, then this closure is in +normal form, so there is no need to set up an update frame. On the +other hand, we do have to check that there are enough args, and +perform an update if not! + +The Macros for GrAnSim are produced at the beginning of the +argSatisfactionCheck (by calling fetchAndReschedule). There info if +Node points to closure is available. -- HWL + +\begin{code} +closureCodeBody binder_info closure_info cc all_args body + = getEntryConvention id lf_info + (map getIdKind all_args) `thenFC` \ entry_conv -> + + isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks -> + + isSwitchSetC ForConcurrent `thenFC` \ is_concurrent -> + + isStringSwitchSetC AsmTarget `thenFC` \ native_code -> + + let + 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 + getIdKind + all_args + + -- Arg mapping for the fast entry point; as many args as poss in + -- registers; the rest on the stack + -- arg_regs are the registers used for arg passing + -- stk_args are the args which are passed on the stack + -- + arg_regs = case entry_conv of + DirectEntry lbl arity regs -> regs + ViaNode | is_concurrent -> [] + other -> panic "closureCodeBody:arg_regs" + + stk_args = drop (length arg_regs) all_args + (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets) + = mkVirtStkOffsets + 0 0 -- Initial virtual SpA, SpB + getIdKind + stk_args + + -- HWL; Note: empty list of live regs in slow entry code + -- Old version (reschedule combined with heap check); + -- see argSatisfactionCheck for new version + --slow_entry_code = forceHeapCheck [node] True slow_entry_code' + -- where node = VanillaReg PtrKind 1 + --slow_entry_code = forceHeapCheck [] True slow_entry_code' + + slow_entry_code + = profCtrC SLIT("ENT_FUN_STD") [] `thenC` + + -- Bind args, and record expected position of stk ptrs + mapCs bindNewToAStack all_bxd_w_offsets `thenC` + mapCs bindNewToBStack all_ubxd_w_offsets `thenC` + setRealAndVirtualSps spA_all_args spB_all_args `thenC` + + argSatisfactionCheck closure_info all_args `thenC` + + -- OK, so there are enough args. Now we need to stuff as + -- many of them in registers as the fast-entry code expects + -- Note that the zipWith will give up when it hits the end of arg_regs + mapFCs getCAddrMode all_args `thenFC` \ stk_amodes -> + absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC` + + -- Now adjust real stack pointers + adjustRealSps spA_stk_args spB_stk_args `thenC` + + -- set the arity checker, if asked + absC ( + if do_arity_chks + then CMacroStmt SET_ARITY [mkIntCLit stg_arity] + else AbsCNop + ) `thenC` + +#ifndef DPH + absC (CFallThrough (CLbl fast_label CodePtrKind)) +#else + -- Fall through to the fast entry point + absC (AbsCNop) +#endif {- Data Parallel Haskell -} + + assign_to_reg reg_id amode = CAssign (CReg reg_id) amode + + -- HWL + -- Old version (reschedule combined with heap check); + -- see argSatisfactionCheck for new version + -- fast_entry_code = forceHeapCheck [] True fast_entry_code' + + fast_entry_code + = profCtrC SLIT("ENT_FUN_DIRECT") [ + CLbl (mkRednCountsLabel id) PtrKind, + CString (_PK_ (showId PprDebug id)), + mkIntCLit stg_arity, -- total # of args + mkIntCLit spA_stk_args, -- # passed on A stk + mkIntCLit spB_stk_args, -- B stk (rest in regs) + CString (_PK_ (map (showTypeCategory . getIdUniType) all_args)), + CString (_PK_ (show_wrapper_name wrapper_maybe)), + CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe)) + ] `thenC` + absC ( + if do_arity_chks + then CMacroStmt CHK_ARITY [mkIntCLit stg_arity] + else AbsCNop + ) `thenC` + + -- Bind args to regs/stack as appropriate, and + -- record expected position of sps + bindArgsToRegs all_args arg_regs `thenC` + mapCs bindNewToAStack stk_bxd_w_offsets `thenC` + mapCs bindNewToBStack stk_ubxd_w_offsets `thenC` + setRealAndVirtualSps spA_stk_args spB_stk_args `thenC` + + -- Enter the closures cc, if required + enterCostCentreCode closure_info cc IsFunction `thenC` + + -- Do the business + funWrapper closure_info arg_regs (cgExpr body) + in +#ifndef DPH + -- Make a labelled code-block for the slow and fast entry code + forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop) + `thenFC` \ slow_abs_c -> + forkAbsC fast_entry_code `thenFC` \ fast_abs_c -> + moduleName `thenFC` \ mod_name -> + -- Now either construct the info table, or put the fast code in alone + -- (We never have slow code without an info table) + absC ( + if info_table_needed + then + CClosureInfoAndCode closure_info slow_abs_c + (Just fast_abs_c) stdUpd (cl_descr mod_name) + else + CCodeBlock fast_label fast_abs_c + ) + + where +#else + -- The info table goes before the slow entry point. + forkAbsC slow_entry_code `thenFC` \ slow_abs_c -> + forkAbsC fast_entry_code `thenFC` \ fast_abs_c -> + moduleName `thenFC` \ mod_name -> + absC (CNativeInfoTableAndCode + closure_info + (closureDescription mod_name id all_args body) + (CCodeBlock slow_label + (AbsCStmts slow_abs_c + (CCodeBlock fast_label + fast_abs_c)))) + where + slow_label = if slow_code_needed then + mkStdEntryLabel id + else + mkErrorStdEntryLabel + -- We may need a pointer to stuff in the info table, + -- but if the slow entry code isn't needed, this code + -- will never be entered, so we can use a standard + -- panic routine. + +#endif {- Data Parallel Haskell -} + + lf_info = closureLFInfo closure_info + + cl_descr mod_name = closureDescription mod_name id all_args body + + -- Figure out what is needed and what isn't + slow_code_needed = slowFunEntryCodeRequired id binder_info + info_table_needed = funInfoTableRequired id binder_info lf_info + + -- Manufacture labels + id = closureId closure_info + + fast_label = fastLabelFromCI closure_info + + stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind + + wrapper_maybe = get_ultimate_wrapper Nothing id + where + get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain" + = case (myWrapperMaybe x) of + Nothing -> deflt + Just xx -> get_ultimate_wrapper (Just xx) xx + + show_wrapper_name Nothing = "" + show_wrapper_name (Just xx) = showId PprDebug xx + + show_wrapper_arg_kinds Nothing = "" + show_wrapper_arg_kinds (Just xx) + = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of + Nothing -> "" + Just str -> str +\end{code} + +For lexically scoped profiling we have to load the cost centre from +the closure entered, if the costs are not supposed to be inherited. +This is done immediately on entering the fast entry point. + +Load current cost centre from closure, if not inherited. +Node is guaranteed to point to it, if profiling and not inherited. + +\begin{code} +data IsThunk = IsThunk | IsFunction -- Bool-like, local + +enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code + +enterCostCentreCode closure_info cc is_thunk + = costCentresFlag `thenFC` \ profiling_on -> + if not profiling_on then + nopC + else -- down to business + ASSERT(not (noCostCentreAttached cc)) + + if costsAreSubsumed cc then + nopC + + else if is_current_CC cc then -- fish the CC out of the closure, + -- where we put it when we alloc'd; + -- NB: chk defn of "is_current_CC" + -- if you go to change this! (WDP 94/12) + costCentresC + (case is_thunk of + IsThunk -> SLIT("ENTER_CC_TCL") + IsFunction -> SLIT("ENTER_CC_FCL")) + [CReg node] + + else if isCafCC cc then + costCentresC + SLIT("ENTER_CC_CAF") + [mkCCostCentre cc] + + else -- we've got a "real" cost centre right here in our hands... + costCentresC + (case is_thunk of + IsThunk -> SLIT("ENTER_CC_T") + IsFunction -> SLIT("ENTER_CC_F")) + [mkCCostCentre cc] + where + is_current_CC cc + = currentOrSubsumedCosts cc + -- but we've already ruled out "subsumed", so it must be "current"! +\end{code} + +%************************************************************************ +%* * +\subsubsection[pre-closure-code-stuff]{Pre-closure-code code} +%* * +%************************************************************************ + +The argument-satisfaction check code is placed after binding +the arguments to their stack locations. Hence, the virtual stack +pointer is pointing after all the args, and virtual offset 1 means +the base of frame and hence most distant arg. Hence +virtual offset 0 is just beyond the most distant argument; the +relative offset of this word tells how many words of arguments +are expected. + +\begin{code} +argSatisfactionCheck :: ClosureInfo -> [Id] -> Code + +argSatisfactionCheck closure_info [] = nopC + +argSatisfactionCheck closure_info args + = -- safest way to determine which stack last arg will be on: + -- look up CAddrMode that last arg is bound to; + -- getAmodeKind; + -- check isFollowableKind. + + nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> + +#ifdef GRAN + -- HWL: + -- absC (CMacroStmt GRAN_FETCH []) `thenC` + -- forceHeapCheck [] node_points (absC AbsCNop) `thenC` + (if node_points + then fetchAndReschedule [] node_points + else absC AbsCNop) `thenC` +#endif {- GRAN -} + + getCAddrMode (last args) `thenFC` \ last_amode -> + + if (isFollowableKind (getAmodeKind last_amode)) then + getSpARelOffset 0 `thenFC` \ a_rel_offset -> + if node_points then + absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt a_rel_offset)]) + else + absC (CMacroStmt ARGS_CHK_A_LOAD_NODE + [mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this]) + else + getSpBRelOffset 0 `thenFC` \ b_rel_offset -> + if node_points then + absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)]) + else + absC (CMacroStmt ARGS_CHK_B_LOAD_NODE + [mkIntCLit (spBRelToInt b_rel_offset), 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 + -- the macro the (static) address of the closure. + + set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrKind +\end{code} + +%************************************************************************ +%* * +\subsubsection[closure-code-wrappers]{Wrappers around closure code} +%* * +%************************************************************************ + +\begin{code} +thunkWrapper:: ClosureInfo -> Code -> Code +thunkWrapper closure_info thunk_code + = -- Stack and heap overflow checks + nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> + +#ifdef GRAN + -- HWL insert macros for GrAnSim if node is live here + (if node_points + then fetchAndReschedule [] node_points + else absC AbsCNop) `thenC` +#endif {- GRAN -} + + stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest + + -- Must be after stackCheck: if stchk fails new stack + -- space has to be allocated from the heap + + heapCheck [] node_points ( + -- heapCheck *encloses* the rest + -- The "[]" says there are no live argument registers + + -- Overwrite with black hole if necessary + blackHoleIt closure_info `thenC` + + -- Push update frame if necessary + setupUpdate closure_info ( -- setupUpdate *encloses* the rest + + -- Evaluation scoping -- load current cost centre from closure + -- Must be done after the update frame is pushed + -- Node is guaranteed to point to it, if profiling +-- OLD: +-- (if isStaticClosure closure_info +-- then evalCostCentreC "SET_CAFCC_CL" [CReg node] +-- else evalCostCentreC "ENTER_CC_TCL" [CReg node]) `thenC` + + -- Finally, do the business + thunk_code + ))) + +funWrapper :: ClosureInfo -- Closure whose code body this is + -> [MagicId] -- List of argument registers (if any) + -> Code -- Body of function being compiled + -> Code +funWrapper closure_info arg_regs fun_body + = -- Stack overflow check + nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points -> + stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest + + -- Heap overflow check + heapCheck arg_regs node_points ( + -- heapCheck *encloses* the rest + + -- Finally, do the business + fun_body + )) +\end{code} + +%************************************************************************ +%* * +\subsubsubsection[overflow-checks]{Stack and heap overflow wrappers} +%* * +%************************************************************************ + +Assumption: virtual and real stack pointers are currently exactly aligned. + +\begin{code} +stackCheck :: ClosureInfo + -> [MagicId] -- Live registers + -> Bool -- Node required to point after check? + -> Code + -> Code + +stackCheck closure_info regs node_reqd code + = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets + + getVirtSps `thenFC` \ (vSpA, vSpB) -> + + let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers + b_headroom_reqd = bHw - vSpB + in + + absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then + AbsCNop + else + CMacroStmt STK_CHK [mkIntCLit liveness_mask, + mkIntCLit a_headroom_reqd, + mkIntCLit b_headroom_reqd, + mkIntCLit vSpA, + mkIntCLit vSpB, + mkIntCLit (if returns_prim_type then 1 else 0), + mkIntCLit (if node_reqd then 1 else 0)] + ) + -- The test is *inside* the absC, to avoid black holes! + + `thenC` code + ) + where + all_regs = if node_reqd then node:regs else regs + liveness_mask = mkLiveRegsBitMask all_regs + + returns_prim_type = closureReturnsUnboxedType closure_info +\end{code} + +%************************************************************************ +%* * +\subsubsubsection[update-and-BHs]{Update and black-hole wrappers} +%* * +%************************************************************************ + + +\begin{code} +blackHoleIt :: ClosureInfo -> Code -- Only called for thunks +blackHoleIt closure_info + = noBlackHolingFlag `thenFC` \ no_black_holing -> + + if (blackHoleOnEntry no_black_holing closure_info) + then + absC (if closureSingleEntry(closure_info) then + CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node] + else + CMacroStmt UPD_BH_UPDATABLE [CReg node]) + -- Node always points to it; see stg-details + else + nopC +\end{code} + +\begin{code} +setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks + -- Nota Bene: this function does not change Node (even if it's a CAF), + -- so that the cost centre in the original closure can still be + -- extracted by a subsequent ENTER_CC_TCL + +setupUpdate closure_info code + = if (closureUpdReqd closure_info) then + link_caf_if_needed `thenFC` \ update_closure -> + pushUpdateFrame update_closure vector code + else + -- Non-updatable thunks still need a resume-cost-centre "update" + -- frame to be pushed if we are doing evaluation profiling. + +--OLD: evalPushRCCFrame False {-never primitive-} ( + profCtrC SLIT("UPDF_OMITTED") [] + `thenC` + code +-- ) + where + link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated + link_caf_if_needed + = if not (isStaticClosure closure_info) then + returnFC (CReg node) + else + + -- First we must allocate a black hole, and link the + -- CAF onto the CAF list + + -- Alloc black hole specifying CC_HDR(Node) as the cost centre + -- Hack Warning: Using a CLitLit to get CAddrMode ! + let + use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrKind + blame_cc = use_cc + in + allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc [] + `thenFC` \ heap_offset -> + getHpRelOffset heap_offset `thenFC` \ hp_rel -> + let amode = CAddr hp_rel + in + absC (CMacroStmt UPD_CAF [CReg node, amode]) + `thenC` + returnFC amode + + closure_label = mkClosureLabel (closureId closure_info) + + vector = case (closureType closure_info) of + Nothing -> CReg StdUpdRetVecReg + Just (spec_tycon, _, spec_datacons) -> + case ctrlReturnConvAlg spec_tycon of + UnvectoredReturn 1 -> + let + spec_data_con = head spec_datacons + only_tag = getDataConTag spec_data_con + direct = case dataReturnConvAlg spec_data_con of + ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag + ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag + vectored = mkStdUpdVecTblLabel spec_tycon + in + CUnVecLbl direct vectored + + UnvectoredReturn _ -> CReg StdUpdRetVecReg + VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrKind +\end{code} + +%************************************************************************ +%* * +\subsection[CgClosure-Description]{Profiling Closure Description.} +%* * +%************************************************************************ + +For "global" data constructors the description is simply occurrence +name of the data constructor itself (see \ref{CgConTbls-info-tables}). + +Otherwise it is determind by @closureDescription@ from the let +binding information. + +\begin{code} +closureDescription :: FAST_STRING -- Module + -> Id -- Id of closure binding + -> [Id] -- Args + -> PlainStgExpr -- Body + -> String + + -- 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 ( + ppBesides [ppChar '<', + ppPStr mod_name, + ppChar '.', + ppr PprDebug name, + ppChar '>'])) +\end{code} + +\begin{code} +chooseDynCostCentres cc args fvs body + = let + use_cc -- cost-centre we record in the object + = if currentOrSubsumedCosts cc + then CReg CurCostCentre + else mkCCostCentre cc + + blame_cc -- cost-centre on whom we blame the allocation + = case (args, fvs, body) of + ([], [just1], StgApp (StgVarAtom fun) [{-no args-}] _) + | just1 == fun + -> mkCCostCentre overheadCostCentre + _ -> use_cc + -- if it's an utterly trivial RHS, then it must be + -- one introduced by boxHigherOrderArgs for profiling, + -- so we charge it to "OVERHEAD". + in + (use_cc, blame_cc) +\end{code} diff --git a/ghc/compiler/codeGen/CgCompInfo.hi b/ghc/compiler/codeGen/CgCompInfo.hi new file mode 100644 index 0000000..abf7a52 --- /dev/null +++ b/ghc/compiler/codeGen/CgCompInfo.hi @@ -0,0 +1,94 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgCompInfo where +import AbsCSyn(RegRelative) +import HeapOffs(HeapOffset) +data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-} +cON_UF_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-} +iND_TAG :: Integer + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +lIVENESS_R1 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-} +lIVENESS_R2 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-} +lIVENESS_R3 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-} +lIVENESS_R4 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-} +lIVENESS_R5 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [16#] _N_ #-} +lIVENESS_R6 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [32#] _N_ #-} +lIVENESS_R7 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [64#] _N_ #-} +lIVENESS_R8 :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [128#] _N_ #-} +mAX_Double_REG :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-} +mAX_FAMILY_SIZE_FOR_VEC_RETURNS :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-} +mAX_Float_REG :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-} +mAX_INTLIKE :: Integer + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _#_ int2Integer# [] [16#] _N_ #-} +mAX_SPEC_ALL_NONPTRS :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [5#] _N_ #-} +mAX_SPEC_ALL_PTRS :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [12#] _N_ #-} +mAX_SPEC_MIXED_FIELDS :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-} +mAX_SPEC_SELECTEE_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [12#] _N_ #-} +mAX_Vanilla_REG :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-} +mIN_BIG_TUPLE_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [16#] _N_ #-} +mIN_INTLIKE :: Integer + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mIN_MP_INT_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [16#] _N_ #-} +mIN_SIZE_NonUpdHeapObject :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-} +mIN_SIZE_NonUpdStaticHeapObject :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [0#] _N_ #-} +mIN_UPD_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-} +mP_STRUCT_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-} +oTHER_TAG :: Integer + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +sCC_CON_UF_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-} +sCC_STD_UF_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [5#] _N_ #-} +sTD_UF_SIZE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-} +spARelToInt :: RegRelative -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +spBRelToInt :: RegRelative -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uF_COST_CENTRE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-} +uF_RET :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [0#] _N_ #-} +uF_SUA :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-} +uF_SUB :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-} +uF_UPDATEE :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-} +uNFOLDING_CHEAP_OP_COST :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-} +uNFOLDING_CON_DISCOUNT_WEIGHT :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-} +uNFOLDING_CREATION_THRESHOLD :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [30#] _N_ #-} +uNFOLDING_DEAR_OP_COST :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-} +uNFOLDING_NOREP_LIT_COST :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-} +uNFOLDING_OVERRIDE_THRESHOLD :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-} +uNFOLDING_USE_THRESHOLD :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-} + diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs new file mode 100644 index 0000000..1ea5e04 --- /dev/null +++ b/ghc/compiler/codeGen/CgCompInfo.lhs @@ -0,0 +1,189 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[CgCompInfo]{Info about this compilation} + +!!!!! THIS CODE MUST AGREE WITH SMinterface.h !!!!!! + +*** This SHOULD BE the only module that is CPP'd with "stgdefs.h" stuff. + +\begin{code} +#include "HsVersions.h" + +module CgCompInfo ( + uNFOLDING_USE_THRESHOLD, + uNFOLDING_CREATION_THRESHOLD, + uNFOLDING_OVERRIDE_THRESHOLD, + uNFOLDING_CHEAP_OP_COST, + uNFOLDING_DEAR_OP_COST, + uNFOLDING_NOREP_LIT_COST, + uNFOLDING_CON_DISCOUNT_WEIGHT, + + mAX_SPEC_ALL_PTRS, + mAX_SPEC_ALL_NONPTRS, + mAX_SPEC_MIXED_FIELDS, + mAX_SPEC_SELECTEE_SIZE, + + mIN_UPD_SIZE, + mIN_SIZE_NonUpdHeapObject, + mIN_SIZE_NonUpdStaticHeapObject, + + mAX_FAMILY_SIZE_FOR_VEC_RETURNS, + + sTD_UF_SIZE, cON_UF_SIZE, + sCC_STD_UF_SIZE, sCC_CON_UF_SIZE, + uF_RET, + uF_SUB, + uF_SUA, + uF_UPDATEE, + uF_COST_CENTRE, + + mAX_Vanilla_REG, +#ifndef DPH + mAX_Float_REG, + mAX_Double_REG, +#else + mAX_Data_REG, +#endif {- Data Parallel Haskell -} + + mIN_BIG_TUPLE_SIZE, + + mIN_MP_INT_SIZE, + mP_STRUCT_SIZE, + + oTHER_TAG, iND_TAG, -- semi-tagging stuff + + lIVENESS_R1, + lIVENESS_R2, + lIVENESS_R3, + lIVENESS_R4, + lIVENESS_R5, + lIVENESS_R6, + lIVENESS_R7, + lIVENESS_R8, + + mAX_INTLIKE, mIN_INTLIKE, + + + spARelToInt, + spBRelToInt, + + -- and to make the interface self-sufficient... + RegRelative + ) where + +-- This magical #include brings in all the everybody-knows-these magic +-- constants unfortunately, we need to be *explicit* about which one +-- we want; if we just hope a -I... will get the right one, we could +-- be in trouble. + +#ifndef DPH +#include "../../includes/GhcConstants.h" +#else +#include "../dphsystem/imports/DphConstants.h" +#endif {- Data Parallel Haskell -} + +import AbsCSyn +import Util +\end{code} + +All pretty arbitrary: +\begin{code} +uNFOLDING_USE_THRESHOLD = ( 3 :: Int) +uNFOLDING_CREATION_THRESHOLD = (30 :: Int) +uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int) +uNFOLDING_CHEAP_OP_COST = ( 1 :: Int) +uNFOLDING_DEAR_OP_COST = ( 4 :: Int) +uNFOLDING_NOREP_LIT_COST = ( 4 :: Int) +uNFOLDING_CON_DISCOUNT_WEIGHT = ( 1 :: Int) +\end{code} + +\begin{code} +mAX_SPEC_ALL_PTRS = (MAX_SPEC_ALL_PTRS :: Int) +mAX_SPEC_ALL_NONPTRS = (MAX_SPEC_ALL_NONPTRS :: Int) +mAX_SPEC_MIXED_FIELDS = (MAX_SPEC_OTHER_SIZE :: Int) +mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int) + +-- closure sizes: these do NOT include the header +mIN_UPD_SIZE = (MIN_UPD_SIZE::Int) +mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int) +mIN_SIZE_NonUpdStaticHeapObject = (0::Int) +\end{code} + +A completely random number: +\begin{code} +mIN_BIG_TUPLE_SIZE = (16::Int) +\end{code} + +Sizes of gmp objects: +\begin{code} +mIN_MP_INT_SIZE = (MIN_MP_INT_SIZE :: Int) +mP_STRUCT_SIZE = (MP_STRUCT_SIZE :: Int) +\end{code} + +Constants for semi-tagging; the tags associated with the data +constructors will start at 0 and go up. +\begin{code} +oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably +iND_TAG = (INFO_IND_TAG :: Integer) -- (-1) NOT USED, REALLY +\end{code} + +Stuff for liveness masks: +\begin{code} +lIVENESS_R1 = (LIVENESS_R1 :: Int) +lIVENESS_R2 = (LIVENESS_R2 :: Int) +lIVENESS_R3 = (LIVENESS_R3 :: Int) +lIVENESS_R4 = (LIVENESS_R4 :: Int) +lIVENESS_R5 = (LIVENESS_R5 :: Int) +lIVENESS_R6 = (LIVENESS_R6 :: Int) +lIVENESS_R7 = (LIVENESS_R7 :: Int) +lIVENESS_R8 = (LIVENESS_R8 :: Int) +\end{code} + +\begin{code} +mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer) +mIN_INTLIKE = MIN_INTLIKE +mAX_INTLIKE = MAX_INTLIKE +\end{code} + +\begin{code} +-- THESE ARE DIRECTION SENSITIVE! +spARelToInt (SpARel spA off) = spA - off -- equiv to: AREL(spA - off) +spBRelToInt (SpBRel spB off) = off - spB -- equiv to: BREL(spB - off) +\end{code} + +A section of code-generator-related MAGIC CONSTANTS. +\begin{code} +mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary +-- If you change this, you may need to change runtimes/standard/Update.lhc + +-- The update frame sizes +sTD_UF_SIZE = (NOSCC_STD_UF_SIZE::Int) +cON_UF_SIZE = (NOSCC_CON_UF_SIZE::Int) + +-- Same again, with profiling +sCC_STD_UF_SIZE = (SCC_STD_UF_SIZE::Int) +sCC_CON_UF_SIZE = (SCC_CON_UF_SIZE::Int) + +-- Offsets in an update frame. They don't change with profiling! +uF_RET = (UF_RET::Int) +uF_SUB = (UF_SUB::Int) +uF_SUA = (UF_SUA::Int) +uF_UPDATEE = (UF_UPDATEE::Int) +uF_COST_CENTRE = (UF_COST_CENTRE::Int) +\end{code} + +\begin{code} +#ifndef DPH +mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int) +mAX_Float_REG = (MAX_FLOAT_REG :: Int) +mAX_Double_REG = (MAX_DOUBLE_REG :: Int) +#else +-- The DAP has only got 14 registers :-( After various heap and stack +-- pointers we dont have that many left over.. +mAX_Vanilla_REG = (4 :: Int) -- Ptr, Int, Char, Float +mAX_Data_REG = (4 :: Int) -- Int, Char, Float, Double +mAX_Float_REG = error "mAX_Float_REG : not used in DPH" +mAX_Double_REG = error "mAX_Double_REG: not used in DPH" +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/codeGen/CgCon.hi b/ghc/compiler/codeGen/CgCon.hi new file mode 100644 index 0000000..f90731d --- /dev/null +++ b/ghc/compiler/codeGen/CgCon.hi @@ -0,0 +1,35 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgCon where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, MagicId, RegRelative) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, StubFlag) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import StgSyn(StgAtom) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +bindConArgs :: Id -> [Id] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "U(LLLS)L" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +buildDynCon :: Id -> CostCentre -> Id -> [CAddrMode] -> Bool -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState) + {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLE" _N_ _N_ #-} +cgReturnDataCon :: Id -> [CAddrMode] -> Bool -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _S_ "LLLLU(LLU(LLS))L" _N_ _N_ #-} +cgTopRhsCon :: Id -> Id -> [StgAtom Id] -> Bool -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState) + {-# GHC_PRAGMA _A_ 4 _U_ 222022 _N_ _S_ "LLSA" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs new file mode 100644 index 0000000..05ef0e8 --- /dev/null +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -0,0 +1,515 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1995 +% +\section[CgCon]{Code generation for constructors} + +This module provides the support code for @StgToAbstractC@ to deal +with {\em constructors} on the RHSs of let(rec)s. See also +@CgClosure@, which deals with closures. + +\begin{code} +#include "HsVersions.h" + +module CgCon ( + -- it's all exported, actually... + cgTopRhsCon, buildDynCon, + bindConArgs, + cgReturnDataCon, + + -- and to make the interface self-sufficient... + Id, StgAtom, CgState, CAddrMode, + PrimKind, PrimOp, MagicId + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import StgSyn +import CgMonad +import AbsCSyn + +import AbsUniType ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar, + TyCon, Class, UniType + ) +import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode, + bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode + ) +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 CgTailCall ( performReturn, mkStaticAlgReturnCode ) +import CgUsages ( getHpRelOffset ) +import CLabelInfo ( CLabel, mkClosureLabel, mkInfoTableLabel, + mkPhantomInfoTableLabel, + mkConEntryLabel, mkStdEntryLabel + ) +import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas + {-( mkConLFInfo, mkLFArgument, closureLFInfo, + layOutDynCon, layOutDynClosure, + layOutStaticClosure, UpdateFlag(..), + mkClosureLFInfo, layOutStaticNoFVClosure + )-} +import Id ( getIdKind, getDataConTag, getDataConTyCon, + isDataCon, fIRST_TAG, DataCon(..), ConTag(..) + ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Maybes ( maybeToBool, Maybe(..) ) +import PrimKind ( PrimKind(..), isFloatingKind, getKindSize ) +import CostCentre +import UniqSet -- ( emptyUniqSet, UniqSet(..) ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[toplevel-constructors]{Top-level constructors} +%* * +%************************************************************************ + +\begin{code} +cgTopRhsCon :: Id -- Name of thing bound to this RHS + -> DataCon -- Id + -> [PlainStgAtom] -- Args + -> Bool -- All zero-size args (see buildDynCon) + -> FCode (Id, CgIdInfo) +\end{code} + +Special Case: +Constructors some of whose arguments are of \tr{Float#} or +\tr{Double#} type, {\em or} which are ``lit lits'' (which are given +\tr{Addr#} type). + +These ones have to be compiled as re-entrant thunks rather than closures, +because we can't figure out a way to persuade C to allow us to initialise a +static closure with Floats and Doubles! +Thus, for \tr{x = 2.0} (defaults to Double), we get: + +\begin{verbatim} +-- The STG syntax: + Main.x = MkDouble [2.0##] + +-- C Code: + +-- closure: + SET_STATIC_HDR(Main_x_closure,Main_x_static,CC_DATA,,EXTDATA_RO) + }; +-- its *own* info table: + STATIC_INFO_TABLE(Main_x,Main_x_entry,,,,EXTFUN,???,":MkDouble","Double"); +-- with its *own* entry code: + STGFUN(Main_x_entry) { + P_ u1701; + RetDouble1=2.0; + u1701=(P_)*SpB; + SpB=SpB-1; + JMP_(u1701[0]); + } +\end{verbatim} + +The above has the down side that each floating-point constant will end +up with its own info table (rather than sharing the MkFloat/MkDouble +ones). On the plus side, however, it does return a value (\tr{2.0}) +{\em straight away}. + +Here, then is the implementation: just pretend it's a non-updatable +thunk. That is, instead of + + x = F# 3.455# + +pretend we've seen + + x = [] \n [] -> F# 3.455# + +\begin{code} +top_cc = dontCareCostCentre -- out here to avoid a cgTopRhsCon CAF (sigh) +top_ccc = mkCCostCentre dontCareCostCentre -- because it's static data + +cgTopRhsCon name con args all_zero_size_args + | any (isFloatingKind . getAtomKind) args + || any isLitLitStgAtom args + = cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info + where + body = StgConApp con args emptyUniqSet{-emptyLiveVarSet-} + lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body +\end{code} + +OK, so now we have the general case. + +\begin{code} +cgTopRhsCon name con args all_zero_size_args + = ( + ASSERT(isDataCon con) + + -- LAY IT OUT + getAtomAmodes args `thenFC` \ amodes -> + + let + (closure_info, amodes_w_offsets) + = layOutStaticClosure name getAmodeKind amodes lf_info + in + -- HWL: In 0.22 there was a heap check in here that had to be changed. + -- CHECK if having no heap check is ok for GrAnSim here!!! + + -- BUILD THE OBJECT + absC (CStaticClosure + closure_label -- Labelled with the name on lhs of defn + closure_info -- Closure is static + top_ccc + (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs + + ) `thenC` + + -- RETURN + returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info) + where + con_tycon = getDataConTyCon con + lf_info = mkConLFInfo con + + closure_label = mkClosureLabel name + info_label = mkInfoTableLabel con + con_entry_label = mkConEntryLabel con + entry_label = mkStdEntryLabel name +\end{code} + +The general case is: +\begin{verbatim} +-- code: + data Foo = MkFoo + x = MkFoo + +-- STG code: +STG syntax: + Main.x = Main.MkFoo [] + +-- interesting parts of the C Code: + +-- closure for "x": + SET_STATIC_HDR(Main_x_closure,Main_MkFoo_static,CC_DATA,,EXTDATA_RO) + }; +-- entry code for "x": + STGFUN(Main_x_entry) { + Node=(W_)(Main_x_closure); + STGJUMP(Main_MkFoo_entry); + } +\end{verbatim} + +Observe: (1)~We create a static closure for \tr{x}, {\em reusing} the +regular \tr{MkFoo} info-table and entry code. (2)~However: the +\tr{MkFoo} code expects Node to be set, but the caller of \tr{x_entry} +will not have set it. Therefore, the whole point of \tr{x_entry} is +to set node (and then call the shared \tr{MkFoo} entry code). + + + +Special Case: +For top-level Int/Char constants. We get entry-code fragments of the form: + +\begin{verbatim} +-- code: + y = 1 + +-- entry code for "y": + STGFUN(Main_y_entry) { + Node=(W_)(Main_y_closure); + STGJUMP(I#_entry); + } +\end{verbatim} + +This is pretty tiresome: we {\em know} what the constant is---we'd +rather just return it. We end up with something that's a hybrid +between the Float/Double and general cases: (a)~like Floats/Doubles, +the entry-code returns the value immediately; (b)~like the general +case, we share the data-constructor's std info table. So, what we +want is: +\begin{verbatim} +-- code: + z = 1 + +-- STG code: +STG syntax: + Main.z = I# [1#] + +-- interesting parts of the C Code: + +-- closure for "z" (shares I# info table): + SET_STATIC_HDR(Main_z_closure,I#_static,CC_DATA,,EXTDATA_RO) + }; +-- entry code for "z" (do the business directly): + STGFUN(Main_z_entry) { + P_ u1702; + Ret1=1; + u1702=(P_)*SpB; + SpB=SpB-1; + JMP_(u1702[0]); + } +\end{verbatim} + +This blob used to be in cgTopRhsCon, but I don't see how we can +jump direct to the named code for a constructor; any external entries +will be via Node. Generating all this extra code is a real waste +for big static data structures. So I've nuked it. SLPJ Sept 94 + + +Further discourse on these entry-code fragments (NB this isn't done +yet [ToDo]): They're really pretty pointless, except for {\em +exported} top-level constants (the rare case). Consider: +\begin{verbatim} +y = p : ps -- y is not exported +f a b = y +g c = (y, c) +\end{verbatim} +Why have a \tr{y_entry} fragment at all? The code generator should +``know enough'' about \tr{y} not to need it. For the first case +above, with \tr{y} in ``head position,'' it should generate code just +as for an \tr{StgRhsCon} (possibly because the STG simplification +actually did the unfolding to make it so). At the least, it should +load up \tr{Node} and call \tr{Cons}'s entry code---not some special +\tr{y_entry} code. + +\begin{pseudocode} + -- WE NEED AN ENTRY PT, IN CASE SOMEONE JUMPS DIRECT TO name + -- FROM OUTSIDE. NB: this CCodeBlock precedes the + -- CStaticClosure for the same reason (fewer forward refs) as + -- we did in CgClosure. + + -- we either have ``in-line'' returning code (special case) + -- or we set Node and jump to the constructor's entry code + + (if maybeToBool (maybeCharLikeTyCon con_tycon) + || maybeToBool (maybeIntLikeTyCon con_tycon) + then -- special case + getAbsC (-- OLD: No, we don't fiddle cost-centres on + -- entry to data values any more (WDP 94/06) + -- lexCostCentreC "ENTER_CC_D" [top_ccc] + -- `thenC` + cgReturnDataCon con amodes all_zero_size_args emptyUniqSet{-no live vars-}) + else -- boring case + returnFC ( + mkAbstractCs [ + -- Node := this_closure + CAssign (CReg node) (CLbl closure_label PtrKind), + -- InfoPtr := info table for this_closure + CAssign (CReg infoptr) (CLbl info_label DataPtrKind), + -- Jump to std code for this constructor + CJump (CLbl con_entry_label CodePtrKind) + ]) + ) `thenFC` \ ret_absC -> + + absC (CCodeBlock entry_label ret_absC) `thenC` +\end{pseudocode} + +=========================== END OF OLD STUFF ============================== + + +%************************************************************************ +%* * +%* non-top-level constructors * +%* * +%************************************************************************ +\subsection[code-for-constructors]{The code for constructors} + +\begin{code} +buildDynCon :: Id -- Name of the thing to which this constr will + -- be bound + -> CostCentre -- Where to grab cost centre from; + -- current CC if currentOrSubsumedCosts + -> DataCon -- The data constructor + -> [CAddrMode] -- Its args + -> Bool -- True <=> all args (if any) are + -- of "zero size" (i.e., VoidKind); + -- The reason we don't just look at the + -- args is that we may be in a "knot", and + -- premature looking at the args will cause + -- the compiler to black-hole! + -> FCode CgIdInfo -- Return details about how to find it +\end{code} + +First we deal with the case of zero-arity constructors. Now, they +will probably be unfolded, so we don't expect to see this case +much, if at all, but it does no harm, and sets the scene for characters. + +In the case of zero-arity constructors, or, more accurately, +those which have exclusively size-zero (VoidKind) args, +we generate no code at all. + +\begin{code} +buildDynCon binder cc con args all_zero_size_args@True + = ASSERT(isDataCon con) + returnFC (stableAmodeIdInfo binder + (CLbl (mkClosureLabel con) PtrKind) + (mkConLFInfo con)) +\end{code} + +Now for @Char@-like closures. We generate an assignment of the +address of the closure to a temporary. It would be possible simply to +generate no code, and record the addressing mode in the environment, but +we'd have to be careful if the argument wasn't a constant --- so for simplicity +we just always asssign to a temporary. + +Last special case: @Int@-like closures. We only special-case the situation +in which the argument is a literal in the range @mIN_INTLIKE@..@mAX_INTLILKE@. +NB: for @Char@-like closures we can work with any old argument, but +for @Int@-like ones the argument has to be a literal. Reason: @Char@ like +closures have an argument type which is guaranteed in range. + +Because of this, we use can safely return an addressing mode. + +\begin{code} +buildDynCon binder cc con [arg_amode] all_zero_size_args@False + + | maybeToBool (maybeCharLikeTyCon tycon) + = ASSERT(isDataCon con) + absC (CAssign temp_amode (CCharLike arg_amode)) `thenC` + returnFC temp_id_info + + | maybeToBool (maybeIntLikeTyCon tycon) && in_range_int_lit arg_amode + = ASSERT(isDataCon con) + returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con)) + where + tycon = getDataConTyCon 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 other_amode = False +\end{code} + +Now the general case. + +\begin{code} +buildDynCon binder cc con args all_zero_size_args@False + = ASSERT(isDataCon con) + allocDynClosure closure_info use_cc blame_cc amodes_w_offsets `thenFC` \ hp_off -> + returnFC (heapIdInfo binder hp_off (mkConLFInfo con)) + where + (closure_info, amodes_w_offsets) + = layOutDynClosure binder getAmodeKind args (mkConLFInfo con) + + use_cc -- cost-centre to stick in the object + = if currentOrSubsumedCosts cc + then CReg CurCostCentre + else mkCCostCentre cc + + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) +\end{code} + + +%************************************************************************ +%* * +%* constructor-related utility function: * +%* bindConArgs is called from cgAlt of a case * +%* * +%************************************************************************ +\subsection[constructor-utilities]{@bindConArgs@: constructor-related utility} + +@bindConArgs@ $con args$ augments the environment with bindings for the +binders $args$, assuming that we have just returned from a @case@ which +found a $con$. + +\begin{code} +bindConArgs :: DataCon -> [Id] -> Code +bindConArgs con args + = ASSERT(isDataCon con) + case (dataReturnConvAlg con) of + ReturnInRegs rs -> bindArgsToRegs args rs + ReturnInHeap -> + let + (_, args_w_offsets) = layOutDynCon con getIdKind args + in + mapCs bind_arg args_w_offsets + where + bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument +\end{code} + + +%************************************************************************ +%* * +\subsubsection[CgRetConv-cgReturnDataCon]{Actually generate code for a constructor return} +%* * +%************************************************************************ + + +Note: it's the responsibility of the @cgReturnDataCon@ caller to be +sure the @amodes@ passed don't conflict with each other. +\begin{code} +cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> PlainStgLiveVars -> Code + +cgReturnDataCon con amodes all_zero_size_args live_vars + = ASSERT(isDataCon con) + 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) + -> + -- Special case! We're returning a constructor to the default case + -- of an enclosing case. For example: + -- + -- case (case e of (a,b) -> C a b) of + -- D x -> ... + -- y -> ...... + -- + -- In this case, + -- if the default is a non-bind-default (ie does not use y), + -- then we should simply jump to the default join point; + -- + -- if the default is a bind-default (ie does use y), we + -- should return the constructor IN THE HEAP, pointed to by Node, + -- **regardless** of the return convention of the constructor C. + + case maybe_deflt_binder of + Just binder -> + buildDynCon binder useCurrentCostCentre con amodes all_zero_size_args + `thenFC` \ idinfo -> + idInfoToAmode PtrKind idinfo `thenFC` \ amode -> + performReturn (move_to_reg amode node) jump_to_join_point live_vars + + Nothing -> + performReturn AbsCNop {- No reg assts -} jump_to_join_point live_vars + where + is_elem = isIn "cgReturnDataCon" + jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrKind)) + -- Ignore the sequel: we've already looked at it above + + other_sequel -> -- The usual case + case dataReturnConvAlg con of + + ReturnInHeap -> + -- BUILD THE OBJECT IN THE HEAP + -- The first "con" says that the name bound to this + -- closure is "con", which is a bit of a fudge, but it only + -- affects profiling (ToDo?) + buildDynCon con useCurrentCostCentre con amodes all_zero_size_args + `thenFC` \ idinfo -> + idInfoToAmode PtrKind idinfo `thenFC` \ amode -> + + -- MAKE NODE POINT TO IT + let reg_assts = move_to_reg amode node + info_lbl = mkInfoTableLabel con + in + + -- RETURN + profCtrC SLIT("RET_NEW_IN_HEAP") [] `thenC` + + performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars + + ReturnInRegs regs -> + let reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs) + info_lbl = mkPhantomInfoTableLabel con + in +--OLD:WDP:94/06 evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC` + profCtrC SLIT("RET_NEW_IN_REGS") [] `thenC` + + performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars + where + move_to_reg :: CAddrMode -> MagicId -> AbstractC + move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode +\end{code} diff --git a/ghc/compiler/codeGen/CgConTbls.hi b/ghc/compiler/codeGen/CgConTbls.hi new file mode 100644 index 0000000..9779b1d --- /dev/null +++ b/ghc/compiler/codeGen/CgConTbls.hi @@ -0,0 +1,24 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgConTbls where +import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgMonad(CompilationInfo) +import ClosureInfo(ClosureInfo) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CostCentre) +import FiniteMap(FiniteMap) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import TCE(TCE(..)) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CompilationInfo {-# GHC_PRAGMA MkCompInfo (GlobalSwitch -> Bool) _PackedString #-} +type TCE = UniqFM TyCon +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +genStaticConBits :: CompilationInfo -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> AbstractC + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs new file mode 100644 index 0000000..b37689f --- /dev/null +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -0,0 +1,430 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CgConTbls]{Info tables and update bits for constructors} + +\begin{code} +#include "HsVersions.h" + +module CgConTbls ( + genStaticConBits, + + -- and to complete the interface... + TCE(..), UniqFM, CompilationInfo, AbstractC + ) where + +import Pretty -- ToDo: rm (debugging) +import Outputable + +import AbsCSyn +import CgMonad + +import AbsUniType ( getTyConDataCons, kindFromType, + maybeIntLikeTyCon, + mkSpecTyCon, isLocalSpecTyCon, + TyVarTemplate, TyCon, Class, + TauType(..), UniType, ThetaType(..) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import CgHeapery ( heapCheck, allocDynClosure ) +import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg, + mkLiveRegsBitMask, + CtrlReturnConvention(..), + DataReturnConvention(..) + ) +import CgTailCall ( performReturn, mkStaticAlgReturnCode ) +import CgUsages ( getHpRelOffset ) +import CLabelInfo ( mkConEntryLabel, mkStaticConEntryLabel, + mkInfoTableLabel, + mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel, + mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel, + mkStdUpdVecTblLabel, CLabel + ) +import ClosureInfo ( layOutStaticClosure, layOutDynCon, + closureSizeWithoutFixedHdr, closurePtrsSize, + fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure, + infoTableLabelFromCI + ) +import CmdLineOpts ( GlobalSwitch(..) ) +import FiniteMap +import Id ( getDataConTag, getDataConSig, getDataConTyCon, + mkSameSpecCon, + getDataConArity, fIRST_TAG, ConTag(..), + DataCon(..) + ) +import CgCompInfo ( uF_UPDATEE ) +import Maybes ( maybeToBool, Maybe(..) ) +import PrimKind ( getKindSize, retKindSize ) +import CostCentre +import UniqSet -- ( emptyUniqSet, UniqSet(..) ) +import TCE ( rngTCE, TCE(..), UniqFM ) +import Util +\end{code} + +For every constructor we generate the following info tables: + A static info table, for static instances of the constructor, + + For constructors which return in registers (and only them), + an "inregs" info table. This info table is rather emaciated; + it only contains update code and tag. + + Plus: + +\begin{tabular}{lll} +Info tbls & Macro & Kind of constructor \\ +\hline +info & @CONST_INFO_TABLE@& Zero arity (no info -- compiler uses static closure)\\ +info & @CHARLIKE_INFO_TABLE@& Charlike (no info -- compiler indexes fixed array)\\ +info & @INTLIKE_INFO_TABLE@& Intlike; the one macro generates both info tbls\\ +info & @SPEC_INFO_TABLE@& SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\ +info & @GEN_INFO_TABLE@& GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\ +\end{tabular} + +Possible info tables for constructor con: + +\begin{description} +\item[@con_info@:] +Used for dynamically let(rec)-bound occurrences of +the constructor, and for updates. For constructors +which are int-like, char-like or nullary, when GC occurs, +the closure tries to get rid of itself. + +\item[@con_inregs_info@:] +Used when returning a new constructor in registers. +Only for return-in-regs constructors. +Macro: @INREGS_INFO_TABLE@. + +\item[@con_static_info@:] +Static occurrences of the constructor +macro: @STATIC_INFO_TABLE@. +\end{description} + +For zero-arity constructors, \tr{con}, we also generate a static closure: + +\begin{description} +\item[@con_closure@:] +A single static copy of the (zero-arity) constructor itself. +\end{description} + +For charlike and intlike closures there is a fixed array of static +closures predeclared. + +\begin{code} +genStaticConBits :: CompilationInfo -- global info about the compilation + -> [TyCon] -- tycons to generate + -> FiniteMap TyCon [[Maybe UniType]] + -- tycon specialisation info + -> AbstractC -- output + +genStaticConBits comp_info gen_tycons tycon_specs + = -- for each type constructor: + -- grab all its data constructors; + -- for each one, generate an info table + -- for each specialised type constructor + -- for each specialisation of the type constructor + -- grab data constructors, and generate info tables + + -- ToDo: for tycons and specialisations which are not + -- declared in this module we must ensure that the + -- C labels are local to this module i.e. static + + mkAbstractCs [ gen_for_tycon tc | tc <- gen_tycons ] + `mkAbsCStmts` + mkAbstractCs [ mkAbstractCs [ gen_for_spec_tycon tc spec + | spec <- specs ] + | (tc, specs) <- fmToList tycon_specs, + isLocalSpecTyCon (sw_chkr CompilingPrelude) tc + ] + where + gen_for_tycon :: TyCon -> AbstractC + gen_for_tycon tycon + = mkAbstractCs (map (genConInfo comp_info tycon) data_cons) + `mkAbsCStmts` maybe_tycon_vtbl + + where + data_cons = getTyConDataCons tycon + tycon_upd_label = mkStdUpdVecTblLabel tycon + + maybe_tycon_vtbl = + case ctrlReturnConvAlg tycon of + UnvectoredReturn 1 -> CRetUnVector tycon_upd_label + (mk_upd_label tycon (head data_cons)) + UnvectoredReturn _ -> AbsCNop + VectoredReturn _ -> CFlatRetVector tycon_upd_label + (map (mk_upd_label tycon) data_cons) + ------------------ + gen_for_spec_tycon :: TyCon -> [Maybe UniType] -> AbstractC + + gen_for_spec_tycon tycon ty_maybes + = mkAbstractCs (map (genConInfo comp_info tycon) spec_data_cons) + `mkAbsCStmts` + maybe_spec_tycon_vtbl + where + data_cons = getTyConDataCons tycon + + spec_tycon = mkSpecTyCon tycon ty_maybes + spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons + + spec_tycon_upd_label = mkStdUpdVecTblLabel spec_tycon + + maybe_spec_tycon_vtbl = + case ctrlReturnConvAlg spec_tycon of + UnvectoredReturn 1 -> CRetUnVector spec_tycon_upd_label + (mk_upd_label spec_tycon (head spec_data_cons)) + UnvectoredReturn _ -> AbsCNop + VectoredReturn _ -> CFlatRetVector spec_tycon_upd_label + (map (mk_upd_label spec_tycon) spec_data_cons) + ------------------ + mk_upd_label tycon con + = case dataReturnConvAlg con of + ReturnInRegs _ -> CLbl (mkConUpdCodePtrVecLabel tycon tag) CodePtrKind + ReturnInHeap -> CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind + where + tag = getDataConTag con + + ------------------ + (MkCompInfo sw_chkr _) = comp_info +\end{code} + +%************************************************************************ +%* * +\subsection[CgConTbls-info-tables]{Generating info tables for constructors} +%* * +%************************************************************************ + +Generate the entry code, info tables, and (for niladic constructor) the +static closure, for a constructor. + +\begin{code} +genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC + +genConInfo comp_info tycon data_con + = mkAbstractCs [ +#ifndef DPH + CSplitMarker, + inregs_upd_maybe, + closure_code, + static_code, +#else + info_table, + CSplitMarker, + static_info_table, +#endif {- Data Parallel Haskell -} + closure_maybe] + -- Order of things is to reduce forward references + where + (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 kindFromType arg_tys (mkConLFInfo data_con) + + body = (initC comp_info ( + profCtrC SLIT("ENT_CON") [CReg node] `thenC` + body_code)) + + entry_addr = CLbl entry_label CodePtrKind + con_descr = _UNPK_ (getOccurrenceName data_con) + +#ifndef DPH + closure_code = CClosureInfoAndCode closure_info body Nothing stdUpd con_descr + static_code = CClosureInfoAndCode static_ci body Nothing stdUpd con_descr + + inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con + + stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind + + tag = getDataConTag data_con + +#else + info_table + = CNativeInfoTableAndCode closure_info con_descr entry_code + static_info_table + = CNativeInfoTableAndCode static_ci con_descr (CJump entry_addr) +#endif {- Data Parallel Haskell -} + + cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs + + -- For zero-arity data constructors, or, more accurately, + -- those which only have VoidKind args (or none): + -- We make the closure too (not just info tbl), so that we can share + -- one copy throughout. + closure_maybe = -- OLD: if con_arity /= 0 then + if not (all zero_size arg_tys) then + AbsCNop + else + CStaticClosure closure_label -- Label for closure + static_ci -- Info table + cost_centre + [{-No args! A slight lie for constrs with VoidKind args-}] + + zero_size arg_ty = getKindSize (kindFromType arg_ty) == 0 + + (_,_,arg_tys,_) = getDataConSig data_con + con_arity = getDataConArity data_con + entry_label = mkConEntryLabel data_con + closure_label = mkClosureLabel data_con +\end{code} + +\begin{code} +mkConCodeAndInfo :: Id -- Data constructor + -> (ClosureInfo, Code) -- The info table + +mkConCodeAndInfo con + = case (dataReturnConvAlg con) of + + ReturnInRegs regs -> + let + (closure_info, regs_w_offsets) + = layOutDynCon con kindFromMagicId regs + + body_code + = -- OLD: We don't set CC when entering data any more (WDP 94/06) + -- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC` + -- evalCostCentreC "SET_RetCC_CL" [CReg node] `thenC` + profCtrC SLIT("RET_OLD_IN_REGS") [] `thenC` + + performReturn (mkAbstractCs (map move_to_reg regs_w_offsets)) + (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-}) + emptyUniqSet{-no live vars-} + in + (closure_info, body_code) + + ReturnInHeap -> + let + (_, _, arg_tys, _) = getDataConSig con + + (closure_info, _) + = layOutDynCon con kindFromType arg_tys + + body_code + = -- OLD: We don't set CC when entering data any more (WDP 94/06) + -- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC` + profCtrC SLIT("RET_OLD_IN_HEAP") [] `thenC` + + performReturn AbsCNop -- Ptr to thing already in Node + (mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-}) + emptyUniqSet{-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)) +\end{code} + +%************************************************************************ +%* * +\subsection[CgConTbls-updates]{Generating update bits for constructors} +%* * +%************************************************************************ + +Generate the "phantom" info table and update code, iff the constructor returns in regs + +\begin{code} + +genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC +genPhantomUpdInfo comp_info tycon data_con + = case dataReturnConvAlg data_con of + + ReturnInHeap -> AbsCNop -- No need for a phantom update + + ReturnInRegs regs -> + + let + phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing upd_code con_descr + phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con) + + con_descr = _UNPK_ (getOccurrenceName data_con) + + con_arity = getDataConArity data_con + + upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return) + upd_label = mkConUpdCodePtrVecLabel tycon tag + tag = getDataConTag data_con + + updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrKind + + perform_return = mkAbstractCs + [ + CMacroStmt POP_STD_UPD_FRAME [], + CReturn (CReg RetReg) return_info + ] + + return_info = + -- OLD: pprTrace "ctrlReturn6:" (ppr PprDebug tycon) ( + case (ctrlReturnConvAlg tycon) of + UnvectoredReturn _ -> DirectReturn + VectoredReturn _ -> StaticVectoredReturn (tag - fIRST_TAG) + -- ) + + -- Determine cost centre for the updated closures CC (and allocation) + -- CCC for lexical (now your only choice) + use_cc = CReg CurCostCentre -- what to put in the closure + blame_cc = use_cc -- who to blame for allocation + + do_move (reg, virt_offset) = + CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg) + + + -- Code for building a new constructor in place over the updatee + overwrite_code = profCtrC SLIT("UPD_CON_IN_PLACE") [] `thenC` + absC (mkAbstractCs + [ + CAssign (CReg node) updatee, + + -- Tell the storage mgr that we intend to update in place + -- This may (in complicated mgrs eg generational) cause gc, + -- and it may modify Node to point to another place to + -- actually update into. + CMacroStmt upd_inplace_macro [liveness_mask], + + -- Initialise the closure pointed to by node + CInitHdr closure_info (NodeRel zeroOff) use_cc True, + mkAbstractCs (map do_move regs_w_offsets), + if con_arity /= 0 then + CAssign (CReg infoptr) (CLbl info_label DataPtrKind) + else + AbsCNop + ]) + + upd_inplace_macro = if closurePtrsSize closure_info == 0 + then UPD_INPLACE_NOPTRS + else UPD_INPLACE_PTRS + + -- Code for allocating a new constructor in the heap + alloc_code = + let amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ] + in + -- Allocate and build closure specifying upd_new_w_regs + allocDynClosure closure_info use_cc blame_cc amodes_w_offsets + `thenFC` \ hp_offset -> + getHpRelOffset hp_offset `thenFC` \ hp_rel -> + let + amode = CAddr hp_rel + in + profCtrC SLIT("UPD_CON_IN_NEW") [] `thenC` + absC (mkAbstractCs + [ + CMacroStmt UPD_IND [updatee, amode], + CAssign (CReg node) amode, + CAssign (CReg infoptr) (CLbl info_label DataPtrKind) + ]) + + (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs + info_label = infoTableLabelFromCI closure_info + liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs)) + + build_closure = + if fitsMinUpdSize closure_info then + initC comp_info overwrite_code + else + initC comp_info (heapCheck regs False alloc_code) + + in CClosureUpdInfo phantom_itbl + +\end{code} + diff --git a/ghc/compiler/codeGen/CgExpr.hi b/ghc/compiler/codeGen/CgExpr.hi new file mode 100644 index 0000000..6d21c17 --- /dev/null +++ b/ghc/compiler/codeGen/CgExpr.hi @@ -0,0 +1,24 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgExpr where +import AbsCSyn(AbstractC, CAddrMode) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, StubFlag) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PrimOps(PrimOp) +import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgExpr) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +cgExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +cgSccExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +getPrimOpArgAmodes :: PrimOp -> [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "SL" _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs new file mode 100644 index 0000000..5974df6 --- /dev/null +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -0,0 +1,414 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%******************************************************** +%* * +\section[CgExpr]{Converting @StgExpr@s} +%* * +%******************************************************** + +\begin{code} +#include "HsVersions.h" + +module CgExpr ( + cgExpr, cgSccExpr, getPrimOpArgAmodes, + + -- and to make the interface self-sufficient... + StgExpr, Id, CgState + ) where + +IMPORT_Trace -- NB: not just for debugging +import Outputable -- ToDo: rm (just for debugging) +import Pretty -- ToDo: rm (just for debugging) + +import StgSyn +import CgMonad +import AbsCSyn + +import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..), + primOpHeapReq, getPrimOpResultInfo, PrimKind, + primOpCanTriggerGC + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( isPrimType, getTyConDataCons ) +import CLabelInfo ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) +import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo ) +import CgBindery ( getAtomAmodes ) +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 CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre ) +import Maybes ( Maybe(..) ) +import PrimKind ( getKindSize ) +import UniqSet +import Util +\end{code} + +This module provides the support code for @StgToAbstractC@ to deal +with STG {\em expressions}. See also @CgClosure@, which deals +with closures, and @CgCon@, which deals with constructors. + +\begin{code} +cgExpr :: PlainStgExpr -- input + -> Code -- output +\end{code} + +%******************************************************** +%* * +%* Tail calls * +%* * +%******************************************************** + +``Applications'' mean {\em tail calls}, a service provided by module +@CgTailCall@. This includes literals, which show up as +@(STGApp (StgLitAtom 42) [])@. + +\begin{code} +cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars +\end{code} + +%******************************************************** +%* * +%* STG ConApps (for inline versions) * +%* * +%******************************************************** + +\begin{code} +cgExpr (StgConApp con args live_vars) + = getAtomAmodes args `thenFC` \ amodes -> + cgReturnDataCon con amodes (all zero_size args) live_vars + where + zero_size atom = getKindSize (getAtomKind atom) == 0 +\end{code} + +%******************************************************** +%* * +%* STG PrimApps (unboxed primitive ops) * +%* * +%******************************************************** + +Here is where we insert real live machine instructions. + +\begin{code} +cgExpr x@(StgPrimApp op args live_vars) + = -- trace ("cgExpr:PrimApp:"++(ppShow 80 (ppr PprDebug x))) ( + getPrimOpArgAmodes op args `thenFC` \ arg_amodes -> + let + result_regs = assignPrimOpResultRegs op + result_amodes = map CReg result_regs + may_gc = primOpCanTriggerGC op + dyn_tag = head result_amodes + -- The tag from a primitive op returning an algebraic data type + -- is returned in the first result_reg_amode + in + (if may_gc then + -- Use registers for args, and assign args to the regs + -- (Can-trigger-gc primops guarantee to have their args in regs) + let + (arg_robust_amodes, liveness_mask, arg_assts) + = makePrimOpArgsRobust op arg_amodes + + liveness_arg = mkIntCLit liveness_mask + in + returnFC ( + arg_assts, + mkAbstractCs [ + spat_prim_macro, + COpStmt result_amodes op + (pin_liveness op liveness_arg arg_robust_amodes) + liveness_mask + [{-no vol_regs-}], + spat_prim_stop_macro ] + ) + else + -- Use args from their current amodes. + let + liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n" + in + returnFC ( +-- DO NOT want CCallProfMacros in CSimultaneous stuff. Yurgh. (WDP 95/01) +-- Arises in compiling PreludeGlaST (and elsewhere??) +-- mkAbstractCs [ +-- spat_prim_macro, + COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}], +-- spat_prim_stop_macro ], + AbsCNop + ) + ) `thenFC` \ (do_before_stack_cleanup, + do_just_before_jump) -> + + case (getPrimOpResultInfo op) of + + ReturnsPrim kind -> + performReturn do_before_stack_cleanup + (\ sequel -> robustifySequel may_gc sequel + `thenFC` \ (ret_asst, sequel') -> + absC (ret_asst `mkAbsCStmts` do_just_before_jump) + `thenC` + mkPrimReturnCode sequel') + live_vars + + ReturnsAlg tycon -> +--OLD: evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC` + profCtrC SLIT("RET_NEW_IN_REGS") [] `thenC` + + performReturn do_before_stack_cleanup + (\ sequel -> robustifySequel may_gc sequel + `thenFC` \ (ret_asst, sequel') -> + absC (mkAbstractCs [ret_asst, + do_just_before_jump, + info_ptr_assign]) + -- Must load info ptr here, not in do_just_before_stack_cleanup, + -- because the info-ptr reg clashes with argument registers + -- for the primop + `thenC` + mkDynamicAlgReturnCode tycon dyn_tag sequel') + live_vars + where + + -- Here, the destination _can_ be an update frame, so we need to make sure that + -- infoptr (R2) is loaded with the constructor's info ptr. + + info_ptr_assign = CAssign (CReg infoptr) info_lbl + + info_lbl + = -- OLD: pprTrace "ctrlReturn7:" (ppr PprDebug tycon) ( + case (ctrlReturnConvAlg tycon) of + VectoredReturn _ -> vec_lbl + UnvectoredReturn _ -> dir_lbl + -- ) + + vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrKind) + dyn_tag DataPtrKind + + data_con = head (getTyConDataCons tycon) + dir_lbl = case dataReturnConvAlg data_con of + ReturnInRegs _ -> CLbl (mkPhantomInfoTableLabel data_con) + DataPtrKind + ReturnInHeap -> panic "CgExpr: can't return prim in heap" + -- Never used, and no point in generating + -- the code for it! + where + -- for all PrimOps except ccalls, we pin the liveness info + -- on as the first "argument" + -- ToDo: un-duplicate? + + pin_liveness (CCallOp _ _ _ _ _) _ args = args + pin_liveness other_op liveness_arg args + = liveness_arg :args + + -- We only need to worry about the sequel when we may GC and the + -- sequel is OnStack. If that's the case, arrange to pull the + -- sequel out into RetReg before performing the primOp. + + robustifySequel True sequel@(OnStack _) = + sequelToAmode sequel `thenFC` \ amode -> + returnFC (CAssign (CReg RetReg) amode, InRetReg) + robustifySequel _ sequel = returnFC (AbsCNop, sequel) + + spat_prim_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind] + spat_prim_stop_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind] + +\end{code} + +%******************************************************** +%* * +%* Case expressions * +%* * +%******************************************************** +Case-expression conversion is complicated enough to have its own +module, @CgCase@. +\begin{code} + +cgExpr (StgCase expr live_vars save_vars uniq alts) + = cgCase expr live_vars save_vars uniq alts +\end{code} + + +%******************************************************** +%* * +%* Let and letrec * +%* * +%******************************************************** +\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@} + +\begin{code} +cgExpr (StgLet (StgNonRec name rhs) expr) + = cgRhs name rhs `thenFC` \ (name, info) -> + addBindC name info `thenC` + cgExpr expr + +cgExpr (StgLet (StgRec pairs) expr) + = fixC (\ new_bindings -> addBindsC new_bindings `thenC` + listFCs [ cgRhs b e | (b,e) <- pairs ] + ) `thenFC` \ new_bindings -> + + addBindsC new_bindings `thenC` + cgExpr expr +\end{code} + +\begin{code} +cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) + = -- Figure out what volatile variables to save + nukeDeadBindings live_in_whole_let `thenC` + saveVolatileVarsAndRegs live_in_rhss + `thenFC` \ (save_assts, rhs_eob_info, maybe_cc_slot) -> + + -- ToDo: cost centre??? + + -- Save those variables right now! + absC save_assts `thenC` + + -- Produce code for the rhss + -- and add suitable bindings to the environment + cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot bindings `thenC` + + -- Do the body + setEndOfBlockInfo rhs_eob_info (cgExpr body) +\end{code} + + +%******************************************************** +%* * +%* SCC Expressions * +%* * +%******************************************************** +\subsection[scc-codegen]{Converting StgSCC} + +SCC expressions are treated specially. They set the current cost +centre. + +For evaluation scoping we also need to save the cost centre in an +``restore CC frame''. We only need to do this once before setting all +nested SCCs. + +\begin{code} +cgExpr scc_expr@(StgSCC ty cc expr) +--OLD:WDP:94/06 = evalPushRCCFrame (isPrimType ty) (cgSccExpr scc_expr) + = cgSccExpr scc_expr +\end{code} + +@cgSccExpr@ (also used in \tr{CgClosure}): +We *don't* set the cost centre for CAF/Dict cost centres +[Likewise Subsumed and NoCostCentre, but they probably +don't exist in an StgSCC expression.] +\begin{code} +cgSccExpr (StgSCC ty cc expr) + = (if setToAbleCostCentre cc then + costCentresC SLIT("SET_CCC") + [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)] + else + nopC) `thenC` + cgSccExpr expr +cgSccExpr other + = cgExpr other +\end{code} + +%******************************************************** +%* * +%* Non-top-level bindings * +%* * +%******************************************************** +\subsection[non-top-level-bindings]{Converting non-top-level bindings} + +@cgBinding@ is only used for let/letrec, not for unboxed bindings. +So the kind should always be @PtrKind@. + +We rely on the support code in @CgCon@ (to do constructors) and +in @CgClosure@ (to do closures). + +\begin{code} +cgRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo) + -- the Id is passed along so a binding can be set up + +cgRhs name (StgRhsCon maybe_cc con args) + = getAtomAmodes args `thenFC` \ amodes -> + buildDynCon name maybe_cc con amodes (all zero_size args) + `thenFC` \ idinfo -> + returnFC (name, idinfo) + where + zero_size atom = getKindSize (getAtomKind atom) == 0 + +cgRhs name (StgRhsClosure cc bi fvs upd_flag args body) + = cgRhsClosure name cc bi fvs args body lf_info + where + lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body +\end{code} + +\begin{code} +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs) + = cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs + `thenFC` \ (binder, info) -> + addBindC binder info + +cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs) + = fixC (\ new_bindings -> + addBindsC new_bindings `thenC` + listFCs [ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info + maybe_cc_slot b e | (b,e) <- pairs ] + ) `thenFC` \ new_bindings -> + + addBindsC new_bindings + 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]) + +cgLetNoEscapeRhs + :: PlainStgLiveVars -- Live in rhss + -> EndOfBlockInfo + -> Maybe VirtualSpBOffset + -> Id + -> PlainStgRhs + -> FCode (Id, CgIdInfo) + +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder + (StgRhsClosure cc bi _ upd_flag args body) + = -- We could check the update flag, but currently we don't switch it off + -- for let-no-escaped things, so we omit the check too! + -- case upd_flag of + -- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update! + -- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body + cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body + +-- For a constructor RHS we want to generate a single chunk of code which +-- can be jumped to from many places, which will return the constructor. +-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside! +cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot binder + (StgRhsCon cc con args) + = cgLetNoEscapeClosure binder cc stgArgOcc{-safe-} full_live_in_rhss rhs_eob_info maybe_cc_slot + [] --No args; the binder is data structure, not a function + (StgConApp con args full_live_in_rhss) +\end{code} + +Some PrimOps require a {\em fixed} amount of heap allocation. Rather +than tidy away ready for GC and do a full heap check, we simply +allocate a completely uninitialised block in-line, just like any other +thunk/constructor allocation, and pass it to the PrimOp as its first +argument. Remember! The PrimOp is entirely responsible for +initialising the object. In particular, the PrimOp had better not +trigger GC before it has filled it in, and even then it had better +make sure that the GC can find the object somehow. + +Main current use: allocating SynchVars. + +\begin{code} +getPrimOpArgAmodes op args + = getAtomAmodes args `thenFC` \ arg_amodes -> + + case primOpHeapReq op of + + FixedHeapRequired size -> allocHeap size `thenFC` \ amode -> + returnFC (amode : arg_amodes) + + _ -> returnFC arg_amodes +\end{code} + + diff --git a/ghc/compiler/codeGen/CgHeapery.hi b/ghc/compiler/codeGen/CgHeapery.hi new file mode 100644 index 0000000..43aa7cb --- /dev/null +++ b/ghc/compiler/codeGen/CgHeapery.hi @@ -0,0 +1,33 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgHeapery where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, StubFlag) +import ClosureInfo(ClosureInfo, LambdaFormInfo) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-} +data HeapOffset +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +allocDynClosure :: ClosureInfo -> CAddrMode -> CAddrMode -> [(CAddrMode, HeapOffset)] -> CgInfoDownwards -> CgState -> (HeapOffset, CgState) + {-# GHC_PRAGMA _A_ 4 _U_ 222111 _N_ _N_ _N_ _N_ #-} +allocHeap :: HeapOffset -> CgInfoDownwards -> CgState -> (CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LLU(LLU(LLU(LL)))" {_A_ 5 _U_ 21222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +heapCheck :: [MagicId] -> Bool -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLU(LLU(LLL))" _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs new file mode 100644 index 0000000..226ff6b --- /dev/null +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -0,0 +1,278 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[CgHeapery]{Heap management functions} + +\begin{code} +#include "HsVersions.h" + +module CgHeapery ( + heapCheck, + allocHeap, allocDynClosure, + +#ifdef GRAN + -- new for GrAnSim HWL + heapCheckOnly, fetchAndReschedule, +#endif {- GRAN -} + + -- and to make the interface self-sufficient... + AbstractC, CAddrMode, HeapOffset, + CgState, ClosureInfo, Id + ) where + +import AbsCSyn +import CgMonad + +import CgRetConv ( mkLiveRegsBitMask ) +import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp, + initHeapUsage + ) +import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize, + layOutDynClosure, + allocProfilingMsg, closureKind + ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[CgHeapery-heap-overflow]{Heap overflow checking} +%* * +%************************************************************************ + +This is std code we replaced by the bits below for GrAnSim. -- HWL + +\begin{code} +#ifndef GRAN + +heapCheck :: [MagicId] -- Live registers + -> Bool -- Node reqd after GC? + -> Code + -> Code + +heapCheck regs node_reqd code + = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code) + where + + do_heap_chk :: HeapOffset -> Code + do_heap_chk words_required + = absC (if isZeroOff(words_required) then AbsCNop else checking_code) `thenC` + -- The test is *inside* the absC, to avoid black holes! + + -- Now we have set up the real heap pointer and checked there is + -- enough space. It remains only to reflect this in the environment + + setRealHp words_required + + -- The "word_required" here is a fudge. + -- *** IT DEPENDS ON THE DIRECTION ***, and on + -- whether the Hp is moved the whole way all + -- at once or not. + where + all_regs = if node_reqd then node:regs else regs + liveness_mask = mkLiveRegsBitMask all_regs + + checking_code = CMacroStmt HEAP_CHK [ + mkIntCLit liveness_mask, + COffset words_required, + mkIntCLit (if node_reqd then 1 else 0)] +#endif {- GRAN -} +\end{code} + +The GrAnSim code for heapChecks. The code for doing a heap check and +doing a context switch has been separated. Especially, the HEAP_CHK +macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used +for doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at +the beginning of every slow entry code in order to simulate the +fetching of closures. If fetching is necessary (i.e. current closure +is not local) then an automatic context switch is done. + +\begin{code} +#ifdef GRAN + +heapCheck :: [MagicId] -- Live registers + -> Bool -- Node reqd after GC? + -> Code + -> Code + +heapCheck = heapCheck' False + +heapCheckOnly :: [MagicId] -- Live registers + -> Bool -- Node reqd after GC? + -> Code + -> Code + +heapCheckOnly = heapCheck' False + +-- May be emit context switch and emit heap check macro + +heapCheck' :: Bool -- context switch here? + -> [MagicId] -- Live registers + -> Bool -- Node reqd after GC? + -> Code + -> Code + +heapCheck' do_context_switch regs node_reqd code + = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code) + where + + do_heap_chk :: HeapOffset -> Code + do_heap_chk words_required + = + -- HWL:: absC (CComment "Forced heap check --- HWL") `thenC` + --absC (if do_context_switch + -- then context_switch_code + -- else AbsCNop) `thenC` + + absC (if do_context_switch && not (isZeroOff words_required) + then context_switch_code + else AbsCNop) `thenC` + absC (if isZeroOff(words_required) + then AbsCNop + else checking_code) `thenC` + + -- HWL was here: + -- For GrAnSim we want heap checks even if no heap is allocated in + -- the basic block to make context switches possible. + -- So, the if construct has been replaced by its else branch. + + -- The test is *inside* the absC, to avoid black holes! + + -- Now we have set up the real heap pointer and checked there is + -- enough space. It remains only to reflect this in the environment + + setRealHp words_required + + -- The "word_required" here is a fudge. + -- *** IT DEPENDS ON THE DIRECTION ***, and on + -- whether the Hp is moved the whole way all + -- at once or not. + where + all_regs = if node_reqd then node:regs else regs + liveness_mask = mkLiveRegsBitMask all_regs + + maybe_context_switch = if do_context_switch + then context_switch_code + else AbsCNop + + context_switch_code = CMacroStmt THREAD_CONTEXT_SWITCH [ + mkIntCLit liveness_mask, + mkIntCLit (if node_reqd then 1 else 0)] + + -- Good old heap check (excluding context switch) + checking_code = CMacroStmt HEAP_CHK [ + mkIntCLit liveness_mask, + COffset words_required, + mkIntCLit (if node_reqd then 1 else 0)] + +-- Emit macro for simulating a fetch and then reschedule + +fetchAndReschedule :: [MagicId] -- Live registers + -> Bool -- Node reqd + -> Code + +fetchAndReschedule regs node_reqd = + if (node `elem` regs || node_reqd) + then fetch_code `thenC` reschedule_code + else absC AbsCNop + where + all_regs = if node_reqd then node:regs else regs + liveness_mask = mkLiveRegsBitMask all_regs + + reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [ + mkIntCLit liveness_mask, + mkIntCLit (if node_reqd then 1 else 0)]) + + --HWL: generate GRAN_FETCH macro for GrAnSim + -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai + fetch_code = absC (CMacroStmt GRAN_FETCH []) + +#endif {- GRAN -} +\end{code} + +%************************************************************************ +%* * +\subsection[initClosure]{Initialise a dynamic closure} +%* * +%************************************************************************ + +@allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp +to account for this. + +\begin{code} +allocDynClosure + :: ClosureInfo + -> CAddrMode -- Cost Centre to stick in the object + -> CAddrMode -- Cost Centre to blame for this alloc + -- (usually the same; sometimes "OVERHEAD") + + -> [(CAddrMode, VirtualHeapOffset)] -- Offsets from start of the object + -- ie Info ptr has offset zero. + -> FCode VirtualHeapOffset -- Returns virt offset of object + +allocDynClosure closure_info use_cc blame_cc amodes_with_offsets + = getVirtAndRealHp `thenFC` \ (virtHp, realHp) -> + + -- FIND THE OFFSET OF THE INFO-PTR WORD + -- virtHp points to last allocated word, ie 1 *before* the + -- info-ptr word of new object. + let info_offset = addOff virtHp (intOff 1) + + -- do_move IS THE ASSIGNMENT FUNCTION + do_move (amode, offset_from_start) + = CAssign (CVal (HpRel realHp + (info_offset `addOff` offset_from_start)) + (getAmodeKind amode)) + amode + in + -- SAY WHAT WE ARE ABOUT TO DO + profCtrC (allocProfilingMsg closure_info) + [COffset (closureHdrSize closure_info), + mkIntCLit (closureGoodStuffSize closure_info), + mkIntCLit slop_size, + COffset closure_size] `thenC` + + -- GENERATE THE CODE + absC ( mkAbstractCs ( + [ CInitHdr closure_info (HpRel realHp info_offset) use_cc False ] + ++ (map do_move amodes_with_offsets))) `thenC` + + -- GENERATE CC PROFILING MESSAGES + costCentresC SLIT("CC_ALLOC") [blame_cc, + COffset closure_size, + CLitLit (_PK_ (closureKind closure_info)) IntKind] + `thenC` + + -- BUMP THE VIRTUAL HEAP POINTER + setVirtHp (virtHp `addOff` closure_size) `thenC` + + -- RETURN PTR TO START OF OBJECT + returnFC info_offset + where + closure_size = closureSize closure_info + slop_size = slopSize closure_info +\end{code} + +%************************************************************************ +%* * +\subsection{Allocate uninitialized heap space} +%* * +%************************************************************************ + +\begin{code} +allocHeap :: HeapOffset -- Size of the space required + -> FCode CAddrMode -- Addr mode for first word of object + +allocHeap space + = getVirtAndRealHp `thenFC` \ (virtHp, realHp) -> + let block_start = addOff virtHp (intOff 1) + in + -- We charge the allocation to "PRIM" (which is probably right) + profCtrC SLIT("ALLOC_PRIM2") [COffset space] `thenC` + + -- BUMP THE VIRTUAL HEAP POINTER + setVirtHp (virtHp `addOff` space) `thenC` + + -- RETURN PTR TO START OF OBJECT + returnFC (CAddr (HpRel realHp block_start)) +\end{code} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.hi b/ghc/compiler/codeGen/CgLetNoEscape.hi new file mode 100644 index 0000000..8f5b0c4 --- /dev/null +++ b/ghc/compiler/codeGen/CgLetNoEscape.hi @@ -0,0 +1,12 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgLetNoEscape where +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo) +import CostCentre(CostCentre) +import Id(Id) +import Maybes(Labda) +import StgSyn(StgBinderInfo, StgExpr) +import UniqFM(UniqFM) +cgLetNoEscapeClosure :: Id -> CostCentre -> StgBinderInfo -> UniqFM Id -> EndOfBlockInfo -> Labda Int -> [Id] -> StgExpr Id Id -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState) + {-# GHC_PRAGMA _A_ 8 _U_ 2002202212 _N_ _S_ "LAALLALL" {_A_ 5 _U_ 2222212 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs new file mode 100644 index 0000000..abc1e11 --- /dev/null +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -0,0 +1,202 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994 +% +%******************************************************** +%* * +\section[CgLetNoEscape]{Handling ``let-no-escapes''} +%* * +%******************************************************** + +\begin{code} +#include "HsVersions.h" + +module CgLetNoEscape ( cgLetNoEscapeClosure ) where + +import StgSyn +import CgMonad +import AbsCSyn + +import CgBindery -- various things +import CgExpr ( cgExpr ) +import CgHeapery ( heapCheck ) +import CgRetConv ( assignRegs ) +import CgStackery ( mkVirtStkOffsets ) +import CgUsages ( setRealAndVirtualSps, getVirtSps ) +import CLabelInfo ( mkFastEntryLabel ) +import ClosureInfo ( mkLFLetNoEscape ) +import Id ( getIdKind ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[what-is-non-escaping]{What {\em is} a ``non-escaping let''?} +%* * +%************************************************************************ + +[The {\em code} that detects these things is elsewhere.] + +Consider: +\begin{verbatim} + let x = fvs \ args -> e + in + if ... then x else + if ... then x else ... +\end{verbatim} +@x@ is used twice (so we probably can't unfold it), but when it is +entered, the stack is deeper than it was then the definition of @x@ +happened. Specifically, if instead of allocating a closure for @x@, +we saved all @x@'s fvs on the stack, and remembered the stack depth at +that moment, then whenever we enter @x@ we can simply set the stack +pointer(s) to these remembered (compile-time-fixed) values, and jump +to the code for @x@. + +All of this is provided x is: +\begin{enumerate} +\item +non-updatable; +\item +guaranteed to be entered before the stack retreats -- ie x is not +buried in a heap-allocated closure, or passed as an argument to something; +\item +all the enters have exactly the right number of arguments, +no more no less; +\item +all the enters are tail calls; that is, they return to the +caller enclosing the definition of @x@. +\end{enumerate} + +Under these circumstances we say that @x@ is {\em non-escaping}. + +An example of when (4) does {\em not} hold: +\begin{verbatim} + let x = ... + in case x of ...alts... +\end{verbatim} + +Here, @x@ is certainly entered only when the stack is deeper than when +@x@ is defined, but here it must return to \tr{...alts...} So we can't +just adjust the stack down to @x@'s recalled points, because that +would lost @alts@' context. + +Things can get a little more complicated. Consider: +\begin{verbatim} + let y = ... + in let x = fvs \ args -> ...y... + in ...x... +\end{verbatim} + +Now, if @x@ is used in a non-escaping way in \tr{...x...}, {\em and} +@y@ is used in a non-escaping way in \tr{...y...}, {\em then} @y@ is +non-escaping. + +@x@ can even be recursive! Eg: +\begin{verbatim} + letrec x = [y] \ [v] -> if v then x True else ... + in + ...(x b)... +\end{verbatim} + + +%************************************************************************ +%* * +\subsection[codeGen-for-non-escaping]{Generating code for a ``non-escaping let''} +%* * +%************************************************************************ + + +Generating code for this is fun. It is all very very similar to what +we do for a case expression. The duality is between +\begin{verbatim} + let-no-escape x = b + in e +\end{verbatim} +and +\begin{verbatim} + case e of ... -> b +\end{verbatim} + +That is, the RHS of @x@ (ie @b@) will execute {\em later}, just like +the alternative of the case; it needs to be compiled in an environment +in which all volatile bindings are forgotten, and the free vars are +bound only to stable things like stack locations.. The @e@ part will +execute {\em next}, just like the scrutinee of a case. + +First, we need to save all @x@'s free vars +on the stack, if they aren't there already. + +\begin{code} +cgLetNoEscapeClosure + :: Id -- binder + -> CostCentre -- NB: *** NOT USED *** ToDo (WDP 94/06) + -> StgBinderInfo -- NB: ditto + -> PlainStgLiveVars -- variables live in RHS, including the binders + -- themselves in the case of a recursive group + -> EndOfBlockInfo -- where are we going to? + -> Maybe VirtualSpBOffset -- Slot for current cost centre + -> [Id] -- args (as in \ args -> body) + -> PlainStgExpr -- body (as in above) + -> FCode (Id, CgIdInfo) + +-- ToDo: deal with the cost-centre issues + +cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body + = let + arity = length args + lf_info = mkLFLetNoEscape arity full_live_in_rhss{-used???-} + in + forkEvalHelp + rhs_eob_info + (nukeDeadBindings full_live_in_rhss) + (forkAbsC (cgLetNoEscapeBody args body)) + `thenFC` \ (vA, vB, code) -> + let + label = mkFastEntryLabel binder arity + in + absC (CCodeBlock label code) `thenC` + returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info) +\end{code} + +\begin{code} +cgLetNoEscapeBody :: [Id] -- Args + -> PlainStgExpr -- Body + -> Code + +cgLetNoEscapeBody all_args rhs + = getVirtSps `thenFC` \ (vA, vB) -> + let + arg_kinds = map getIdKind 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 + -- Using them, we define the stack layout + (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets) + = mkVirtStkOffsets + vA vB -- Initial virtual SpA, SpB + getIdKind + stk_args + in + + -- Bind args to appropriate regs/stk locns + bindArgsToRegs all_args arg_regs `thenC` + mapCs bindNewToAStack stk_bxd_w_offsets `thenC` + mapCs bindNewToBStack stk_ubxd_w_offsets `thenC` + setRealAndVirtualSps spA_stk_args spB_stk_args `thenC` + +{- ToDo: NOT SURE ABOUT COST CENTRES! + -- Enter the closures cc, if required + lexEnterCCcode closure_info maybe_cc `thenC` +-} + + -- [No need for stack check; forkEvalHelp dealt with that] + + -- Do heap check [ToDo: omit for non-recursive case by recording in + -- in envt and absorbing at call site] + heapCheck arg_regs False {- Node doesn't point to it -} ( + -- heapCheck *encloses* the rest + + -- Compile the body + cgExpr rhs + ) +\end{code} diff --git a/ghc/compiler/codeGen/CgMonad.hi b/ghc/compiler/codeGen/CgMonad.hi new file mode 100644 index 0000000..73a974e --- /dev/null +++ b/ghc/compiler/codeGen/CgMonad.hi @@ -0,0 +1,209 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgMonad where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgBindery(CgBindings(..), CgIdInfo, StableLoc, VolatileLoc, heapIdInfo, stableAmodeIdInfo) +import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import HeapOffs(HeapOffset, VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..)) +import Id(DataCon(..), Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(IdInfo) +import Maybes(Labda) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import StgSyn(PlainStgLiveVars(..)) +import UniType(UniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +infixr 9 `thenC` +infixr 9 `thenFC` +type AStackUsage = (Int, [(Int, StubFlag)], Int, Int) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +type BStackUsage = (Int, [Int], Int, Int) +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CLabel +type CgBindings = UniqFM CgIdInfo +data CgIdInfo {-# GHC_PRAGMA MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo #-} +data CgInfoDownwards = MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo +data CgState = MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) +type Code = CgInfoDownwards -> CgState -> CgState +data CompilationInfo = MkCompInfo (GlobalSwitch -> Bool) _PackedString +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data EndOfBlockInfo = EndOfBlockInfo Int Int Sequel +type FCode a = CgInfoDownwards -> CgState -> (a, CgState) +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data HeapOffset +type HeapUsage = (HeapOffset, HeapOffset) +data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-} +data IsCafCC {-# GHC_PRAGMA IsCafCC | IsNotCafCC #-} +type SemiTaggingStuff = Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel))) +data Sequel = InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))) +data StubFlag {-# GHC_PRAGMA Stubbed | NotStubbed #-} +type VirtualHeapOffset = HeapOffset +type VirtualSpAOffset = Int +type VirtualSpBOffset = Int +type DataCon = Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type PlainStgLiveVars = UniqFM Id +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +absC :: AbstractC -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addBindC :: Id -> CgIdInfo -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 1201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addBindsC :: [(Id, CgIdInfo)] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 101 _N_ _S_ "LAU(LLL)" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addFreeBSlots :: [Int] -> [Int] -> [Int] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +costCentresC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(U(SA)AA)U(LLL)" {_A_ 4 _U_ 2211 _N_ _N_ _N_ _N_} _N_ _N_ #-} +costCentresFlag :: CgInfoDownwards -> CgState -> (Bool, CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(LA)AA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fixC :: (a -> CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-} +forkAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +forkAlts :: [CgInfoDownwards -> CgState -> (a, CgState)] -> [CgInfoDownwards -> CgState -> (a, CgState)] -> (CgInfoDownwards -> CgState -> (b, CgState)) -> CgInfoDownwards -> CgState -> (([a], b), CgState) + {-# GHC_PRAGMA _A_ 5 _U_ 11122 _N_ _N_ _N_ _N_ #-} +forkClosureBody :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(LLA)U(LLL)" {_A_ 4 _U_ 1221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +forkEval :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (Sequel, CgState)) -> CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 21112 _N_ _N_ _N_ _N_ #-} +forkEvalHelp :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> ((Int, Int, a), CgState) + {-# GHC_PRAGMA _A_ 5 _U_ 21112 _N_ _S_ "LLLU(LLA)L" _N_ _N_ #-} +forkStatics :: (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(LAA)U(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getEndOfBlockInfo :: CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAL)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: EndOfBlockInfo) (u1 :: CgState) -> _!_ _TUP_2 [EndOfBlockInfo, CgState] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> case u0 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u2 :: CompilationInfo) (u3 :: UniqFM CgIdInfo) (u4 :: EndOfBlockInfo) -> _!_ _TUP_2 [EndOfBlockInfo, CgState] [u4, u1]; _NO_DEFLT_ } _N_ #-} +getUnstubbedAStackSlots :: Int -> CgInfoDownwards -> CgState -> ([Int], CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(U(LLLL)LL))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +initC :: CompilationInfo -> (CgInfoDownwards -> CgState -> CgState) -> AbstractC + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +isStringSwitchSetC :: ([Char] -> GlobalSwitch) -> CgInfoDownwards -> CgState -> (Bool, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LU(U(LA)AA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isStubbed :: StubFlag -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: StubFlag) -> case u0 of { _ALG_ _ORIG_ CgMonad Stubbed -> _!_ True [] []; _ORIG_ CgMonad NotStubbed -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +isSwitchSetC :: GlobalSwitch -> CgInfoDownwards -> CgState -> (Bool, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LU(U(LA)AA)L" {_A_ 3 _U_ 212 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 6 \ (u0 :: GlobalSwitch) (u1 :: GlobalSwitch -> Bool) (u2 :: CgState) -> let {(u3 :: Bool) = _APP_ u1 [ u0 ]} in _!_ _TUP_2 [Bool, CgState] [u3, u2] _N_} _F_ _ALWAYS_ \ (u0 :: GlobalSwitch) (u1 :: CgInfoDownwards) (u2 :: CgState) -> case u1 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u3 :: CompilationInfo) (u4 :: UniqFM CgIdInfo) (u5 :: EndOfBlockInfo) -> case u3 of { _ALG_ _ORIG_ CgMonad MkCompInfo (u6 :: GlobalSwitch -> Bool) (u7 :: _PackedString) -> let {(u8 :: Bool) = _APP_ u6 [ u0 ]} in _!_ _TUP_2 [Bool, CgState] [u8, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +listCs :: [CgInfoDownwards -> CgState -> CgState] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +listFCs :: [CgInfoDownwards -> CgState -> (a, CgState)] -> CgInfoDownwards -> CgState -> ([a], CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +lookupBindC :: Id -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(ALA)U(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mapCs :: (a -> CgInfoDownwards -> CgState -> CgState) -> [a] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLL" _N_ _N_ #-} +mapFCs :: (a -> CgInfoDownwards -> CgState -> (b, CgState)) -> [a] -> CgInfoDownwards -> CgState -> ([b], CgState) + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLL" _N_ _N_ #-} +modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 1201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +moduleName :: CgInfoDownwards -> CgState -> (_PackedString, CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(AL)AA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: CgState) -> _!_ _TUP_2 [_PackedString, CgState] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 5 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> case u0 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u2 :: CompilationInfo) (u3 :: UniqFM CgIdInfo) (u4 :: EndOfBlockInfo) -> case u2 of { _ALG_ _ORIG_ CgMonad MkCompInfo (u5 :: GlobalSwitch -> Bool) (u6 :: _PackedString) -> _!_ _TUP_2 [_PackedString, CgState] [u6, u1]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +noBlackHolingFlag :: CgInfoDownwards -> CgState -> (Bool, CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(LA)AA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +nopC :: CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLL)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: AbstractC) (u1 :: UniqFM CgIdInfo) (u2 :: ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))) -> _!_ _ORIG_ CgMonad MkCgState [] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> u1 _N_ #-} +nukeDeadBindings :: UniqFM Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(U(LLLL)U(LLLL)L))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +profCtrC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(U(SA)AA)U(LLL)" {_A_ 4 _U_ 2211 _N_ _N_ _N_ _N_} _N_ _N_ #-} +returnFC :: a -> CgInfoDownwards -> CgState -> (a, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: CgInfoDownwards) (u3 :: CgState) -> _!_ _TUP_2 [u0, CgState] [u1, u3] _N_ #-} +sequelToAmode :: Sequel -> CgInfoDownwards -> CgState -> (CAddrMode, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "SAL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +setEndOfBlockInfo :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2112 _N_ _S_ "LSU(LLA)L" {_A_ 5 _U_ 21222 _N_ _N_ _F_ _IF_ARGS_ 0 5 XXXXX 8 \ (u0 :: EndOfBlockInfo) (u1 :: CgInfoDownwards -> CgState -> CgState) (u2 :: CompilationInfo) (u3 :: UniqFM CgIdInfo) (u4 :: CgState) -> let {(u5 :: CgInfoDownwards) = _!_ _ORIG_ CgMonad MkCgInfoDown [] [u2, u3, u0]} in _APP_ u1 [ u5, u4 ] _N_} _F_ _ALWAYS_ \ (u0 :: EndOfBlockInfo) (u1 :: CgInfoDownwards -> CgState -> CgState) (u2 :: CgInfoDownwards) (u3 :: CgState) -> case u2 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u4 :: CompilationInfo) (u5 :: UniqFM CgIdInfo) (u6 :: EndOfBlockInfo) -> let {(u7 :: CgInfoDownwards) = _!_ _ORIG_ CgMonad MkCgInfoDown [] [u4, u5, u0]} in _APP_ u1 [ u7, u3 ]; _NO_DEFLT_ } _N_ #-} +stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +thenC :: (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> a) -> CgInfoDownwards -> CgState -> a + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "LSLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: CgInfoDownwards -> CgState -> CgState) (u2 :: CgInfoDownwards -> CgState -> u0) (u3 :: CgInfoDownwards) (u4 :: CgState) -> let {(u5 :: CgState) = _APP_ u1 [ u3, u4 ]} in _APP_ u2 [ u3, u5 ] _N_ #-} +thenFC :: (CgInfoDownwards -> CgState -> (a, CgState)) -> (a -> CgInfoDownwards -> CgState -> b) -> CgInfoDownwards -> CgState -> b + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "LSLL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: CgInfoDownwards -> CgState -> (u0, CgState)) (u3 :: u0 -> CgInfoDownwards -> CgState -> u1) (u4 :: CgInfoDownwards) (u5 :: CgState) -> let {(u6 :: (u0, CgState)) = _APP_ u2 [ u4, u5 ]} in let {(u9 :: u0) = case u6 of { _ALG_ _TUP_2 (u7 :: u0) (u8 :: CgState) -> u7; _NO_DEFLT_ }} in let {(uc :: CgState) = case u6 of { _ALG_ _TUP_2 (ua :: u0) (ub :: CgState) -> ub; _NO_DEFLT_ }} in _APP_ u3 [ u9, u4, uc ] _N_ #-} +instance Eq CLabel + {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool)] [_CONSTM_ Eq (==) (CLabel), _CONSTM_ Eq (/=) (CLabel)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord CLabel + {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq CLabel}}, (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> _CMP_TAG)] [_DFUN_ Eq (CLabel), _CONSTM_ Ord (<) (CLabel), _CONSTM_ Ord (<=) (CLabel), _CONSTM_ Ord (>=) (CLabel), _CONSTM_ Ord (>) (CLabel), _CONSTM_ Ord max (CLabel), _CONSTM_ Ord min (CLabel), _CONSTM_ Ord _tagCmp (CLabel)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs new file mode 100644 index 0000000..ce063c8 --- /dev/null +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -0,0 +1,914 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CgMonad]{The code generation monad} + +See the beginning of the top-level @CodeGen@ module, to see how this +monadic stuff fits into the Big Picture. + +\begin{code} +#include "HsVersions.h" + +module CgMonad ( + Code(..), -- type + FCode(..), -- type + + initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, + returnFC, fixC, absC, nopC, getAbsC, + + forkClosureBody, forkStatics, forkAlts, forkEval, + forkEvalHelp, forkAbsC, + SemiTaggingStuff(..), + + addBindC, addBindsC, modifyBindC, lookupBindC, +--UNUSED: grabBindsC, + + EndOfBlockInfo(..), + setEndOfBlockInfo, getEndOfBlockInfo, + + AStackUsage(..), BStackUsage(..), HeapUsage(..), + StubFlag, + isStubbed, +--UNUSED: grabStackSizeC, + + nukeDeadBindings, getUnstubbedAStackSlots, + +-- addFreeASlots, -- no need to export it + addFreeBSlots, -- ToDo: Belong elsewhere + + isSwitchSetC, isStringSwitchSetC, + + noBlackHolingFlag, + profCtrC, --UNUSED: concurrentC, + + costCentresC, costCentresFlag, moduleName, + + Sequel(..), -- ToDo: unabstract? + sequelToAmode, + + -- out of general friendliness, we also export ... + CgBindings(..), + CgInfoDownwards(..), CgState(..), -- non-abstract + CgIdInfo, -- abstract + CompilationInfo(..), + GlobalSwitch, -- abstract + + stableAmodeIdInfo, heapIdInfo, + + -- and to make the interface self-sufficient... + AbstractC, CAddrMode, CLabel, LambdaFormInfo, IdEnv(..), + Unique, HeapOffset, CostCentre, IsCafCC, + Id, UniqSet(..), UniqFM, + VirtualSpAOffset(..), VirtualSpBOffset(..), + VirtualHeapOffset(..), DataCon(..), PlainStgLiveVars(..), + Maybe + ) where + +import AbsCSyn +import AbsUniType ( kindFromType, UniType + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import CgBindery +import CgUsages ( getSpBRelOffset ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Id ( getIdUniType, ConTag(..), DataCon(..) ) +import IdEnv -- ops on CgBindings use these +import Maybes ( catMaybes, maybeToBool, Maybe(..) ) +import Pretty -- debugging only? +import PrimKind ( getKindSize, retKindSize ) +import UniqSet -- ( elementOfUniqSet, UniqSet(..) ) +import CostCentre -- profiling stuff +import StgSyn ( PlainStgAtom(..), PlainStgLiveVars(..) ) +import Unique ( UniqueSupply ) +import Util + +infixr 9 `thenC` -- Right-associative! +infixr 9 `thenFC` +\end{code} + +%************************************************************************ +%* * +\subsection[CgMonad-environment]{Stuff for manipulating environments} +%* * +%************************************************************************ + +This monadery has some information that it only passes {\em +downwards}, as well as some ``state'' which is modified as we go +along. + +\begin{code} +data CgInfoDownwards -- information only passed *downwards* by the monad + = MkCgInfoDown + CompilationInfo -- COMPLETELY STATIC info about this compilation + -- (e.g., what flags were passed to the compiler) + + CgBindings -- [Id -> info] : static environment + + EndOfBlockInfo -- Info for stuff to do at end of basic block: + + +data CompilationInfo + = MkCompInfo + (GlobalSwitch -> Bool) + -- use it to look up whatever we like in command-line flags + FAST_STRING -- the module name + + +data CgState + = MkCgState + AbstractC -- code accumulated so far + CgBindings -- [Id -> info] : *local* bindings environment + -- Bindings for top-level things are given in the info-down part + 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. + +\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. + + Sequel + + +initEobInfo = EndOfBlockInfo 0 0 InRetReg + + +\end{code} + +Any addressing modes inside @Sequel@ must be ``robust,'' in the sense +that it must survive stack pointer adjustments at the end of the +block. + +\begin{code} +data Sequel + = InRetReg -- The continuation is in RetReg + + | OnStack VirtualSpBOffset + -- Continuation is on the stack, at the + -- specified location + + +--UNUSED: | RestoreCostCentre + + | UpdateCode CAddrMode -- May be standard update code, or might be + -- the data-type-specific one. + + | 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... + ([(ConTag, JoinDetails)], -- Alternatives + Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one) + -- Maybe[3] the default is a + -- bind-default (Just b); that is, + -- it expects a ptr to the thing + -- in Node, bound to b + ) + +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. + + +-- 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. + +sequelToAmode :: Sequel -> FCode CAddrMode + +sequelToAmode (OnStack virt_spb_offset) + = getSpBRelOffset virt_spb_offset `thenFC` \ spb_rel -> + returnFC (CVal spb_rel RetKind) + +sequelToAmode InRetReg = returnFC (CReg RetReg) +--UNUSED:sequelToAmode RestoreCostCentre = returnFC mkRestoreCostCentreLbl +--Andy/Simon's patch: +--WAS: sequelToAmode (UpdateCode amode) = returnFC amode +sequelToAmode (UpdateCode amode) = returnFC (CReg StdUpdRetVecReg) +sequelToAmode (CaseAlts amode _) = returnFC amode + +-- ToDo: move/do something +--UNUSED:mkRestoreCostCentreLbl = panic "mkRestoreCostCentreLbl" +\end{code} + +See the NOTES about the details of stack/heap usage tracking. + +\begin{code} +type CgStksAndHeapUsage -- stacks and heap usage information + = (AStackUsage, -- A-stack usage + BStackUsage, -- B-stack usage + HeapUsage) + +type AStackUsage = + (Int, -- virtSpA: Virtual offset of topmost allocated slot + [(Int,StubFlag)], -- freeA: List of free slots, in increasing order + Int, -- realSpA: Virtual offset of real stack pointer + Int) -- hwSpA: Highest value ever taken by virtSp + +data StubFlag = Stubbed | NotStubbed + +isStubbed Stubbed = True -- so the type can be abstract +isStubbed NotStubbed = False + +type BStackUsage = + (Int, -- virtSpB: Virtual offset of topmost allocated slot + [Int], -- freeB: List of free slots, in increasing order + Int, -- realSpB: Virtual offset of real stack pointer + Int) -- hwSpB: Highest value ever taken by virtSp + +type HeapUsage = + (HeapOffset, -- virtHp: Virtual offset of highest-numbered allocated word + HeapOffset) -- realHp: Virtual offset of real heap ptr +\end{code} +NB: absolutely every one of the above Ints is really +a VirtualOffset of some description (the code generator +works entirely in terms of VirtualOffsets; see NOTES). + +Initialisation. + +\begin{code} +initialStateC = MkCgState AbsCNop nullIdEnv initUsage + +initUsage :: CgStksAndHeapUsage +initUsage = ((0,[],0,0), (0,[],0,0), (initVirtHp, initRealHp)) +initVirtHp = panic "Uninitialised virtual Hp" +initRealHp = panic "Uninitialised real Hp" +\end{code} + +@envInitForAlternatives@ initialises the environment for a case alternative, +assuming that the alternative is entered after an evaluation. +This involves: +\begin{itemize} +\item +zapping any volatile bindings, which aren't valid. +\item +zapping the heap usage. It should be restored by a heap check. +\item +setting the virtual AND real stack pointer fields to the given virtual stack offsets. +this doesn't represent any {\em code}; it is a prediction of where the +real stack pointer will be when we come back from the case analysis. +\item +BUT LEAVING the rest of the stack-usage info because it is all valid. +In particular, we leave the tail stack pointers unchanged, becuase the +alternative has to de-allocate the original @case@ expression's stack. +\end{itemize} + +@stateIncUsage@$~e_1~e_2$ incorporates in $e_1$ the stack and heap high water +marks found in $e_2$. + +\begin{code} +stateIncUsage :: CgState -> CgState -> CgState + +stateIncUsage (MkCgState abs_c bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),(vH1,rH1))) + (MkCgState _ _ (( _, _, _,hA2),( _, _, _,hB2),(vH2, _))) + = MkCgState abs_c + bs + ((vA,fA,rA,hA1 `max` hA2), + (vB,fB,rB,hB1 `max` hB2), + (vH1 `maxOff` vH2, rH1)) +\end{code} + +%************************************************************************ +%* * +\subsection[CgMonad-basics]{Basic code-generation monad magic} +%* * +%************************************************************************ + +\begin{code} +type FCode a = CgInfoDownwards -> CgState -> (a, CgState) +type Code = CgInfoDownwards -> CgState -> CgState + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenC #-} +{-# INLINE thenFC #-} +{-# INLINE returnFC #-} +#endif +\end{code} +The Abstract~C is not in the environment so as to improve strictness. + +\begin{code} +initC :: CompilationInfo -> Code -> AbstractC + +initC cg_info code + = case (code (MkCgInfoDown cg_info (error "initC: statics") initEobInfo) + initialStateC) of + MkCgState abc _ _ -> abc + +returnFC :: a -> FCode a + +returnFC val info_down state = (val, state) +\end{code} + +\begin{code} +thenC :: Code + -> (CgInfoDownwards -> CgState -> a) + -> CgInfoDownwards -> CgState -> a + +-- thenC has both of the following types: +-- thenC :: Code -> Code -> Code +-- thenC :: Code -> FCode a -> FCode a + +(m `thenC` k) info_down state + = k info_down new_state + where + new_state = m info_down state + +listCs :: [Code] -> Code + +listCs [] info_down state = state +listCs (c:cs) info_down state = stateN + where + state1 = c info_down state + stateN = listCs cs info_down state1 + +mapCs :: (a -> Code) -> [a] -> Code + +mapCs f [] info_down state = state +mapCs f (c:cs) info_down state = stateN + where + state1 = (f c) info_down state + stateN = mapCs f cs info_down state1 +\end{code} + +\begin{code} +thenFC :: FCode a + -> (a -> CgInfoDownwards -> CgState -> c) + -> CgInfoDownwards -> CgState -> c + +-- thenFC :: FCode a -> (a -> FCode b) -> FCode b +-- thenFC :: FCode a -> (a -> Code) -> Code + +(m `thenFC` k) info_down state + = k m_result info_down new_state + where + (m_result, new_state) = m info_down state + +listFCs :: [FCode a] -> FCode [a] + +listFCs [] info_down state = ([], state) +listFCs (fc:fcs) info_down state = (thing : things, stateN) + where + (thing, state1) = fc info_down state + (things, stateN) = listFCs fcs info_down state1 + +mapFCs :: (a -> FCode b) -> [a] -> FCode [b] + +mapFCs f [] info_down state = ([], state) +mapFCs f (fc:fcs) info_down state = (thing : things, stateN) + where + (thing, state1) = (f fc) info_down state + (things, stateN) = mapFCs f fcs info_down state1 +\end{code} + +And the knot-tying combinator: +\begin{code} +fixC :: (a -> FCode a) -> FCode a +fixC fcode info_down state = result + where + result@(v, _) = fcode v info_down state + -- ^-------------^ +\end{code} + +@forkClosureBody@ takes a code, $c$, and compiles it in a completely +fresh environment, except that: + - compilation info and statics are passed in unchanged. +The current environment is passed on completely unaltered, except that +abstract C from the fork is incorporated. + +@forkAbsC@ takes a code and compiles it in the current environment, +returning the abstract C thus constructed. The current environment +is passed on completely unchanged. It is pretty similar to @getAbsC@, +except that the latter does affect the environment. ToDo: combine? + +@forkStatics@ $fc$ compiles $fc$ in an environment whose statics come +from the current bindings, but which is otherwise freshly initialised. +The Abstract~C returned is attached to the current state, but the +bindings and usage information is otherwise unchanged. + +\begin{code} +forkClosureBody :: Code -> Code + +forkClosureBody code + (MkCgInfoDown cg_info statics _) + (MkCgState absC_in binds un_usage) + = MkCgState (AbsCStmts absC_in absC_fork) binds un_usage + where + fork_state = code body_info_down initialStateC + MkCgState absC_fork _ _ = fork_state + body_info_down = MkCgInfoDown cg_info statics initEobInfo + +forkStatics :: FCode a -> FCode a + +forkStatics fcode (MkCgInfoDown cg_info _ _) + (MkCgState absC_in statics un_usage) + = (result, MkCgState (AbsCStmts absC_in absC_fork) statics un_usage) + where + (result, state) = fcode rhs_info_down initialStateC + MkCgState absC_fork _ _ = state -- Don't merge these this line with the one + -- above or it becomes too strict! + rhs_info_down = MkCgInfoDown cg_info statics initEobInfo + +forkAbsC :: Code -> FCode AbstractC +forkAbsC code info_down (MkCgState absC1 bs usage) + = (absC2, new_state) + where + MkCgState absC2 _ ((_, _, _,hA2),(_, _, _,hB2), _) = + code info_down (MkCgState AbsCNop bs usage) + ((vA, fA, rA, hA1), (vB, fB, rB, hB1), heap_usage) = usage + + new_usage = ((vA, fA, rA, hA1 `max` hA2), (vB, fB, rB, hB1 `max` hB2), heap_usage) + new_state = MkCgState absC1 bs new_usage +\end{code} + +@forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and +an fcode for the default case $d$, and compiles each in the current +environment. The current environment is passed on unmodified, except +that + - the worst stack high-water mark is incorporated + - the virtual Hp is moved on to the worst virtual Hp for the branches + +The "extra branches" arise from handling the default case: + + case f x of + C1 a b -> e1 + z -> e2 + +Here we in effect expand to + + case f x of + C1 a b -> e1 + C2 c -> let z = C2 c in JUMP(default) + C3 d e f -> let z = C2 d e f in JUMP(default) + + default: e2 + +The stuff for C2 and C3 are the extra branches. They are +handled differently by forkAlts, because their +heap usage is joined onto that for the default case. + +\begin{code} +forkAlts :: [FCode a] -> [FCode a] -> FCode b -> FCode ([a],b) + +forkAlts branch_fcodes extra_branch_fcodes deflt_fcode info_down in_state + = ((extra_branch_results ++ branch_results , deflt_result), out_state) + where + compile fc = fc info_down in_state + + (branch_results, branch_out_states) = unzip (map compile branch_fcodes) + (extra_branch_results, extra_branch_out_states) = unzip (map compile extra_branch_fcodes) + + -- The "in_state" for the default branch is got by worst-casing the + -- heap usages etc from the "extra_branches" + default_in_state = foldl stateIncUsage in_state extra_branch_out_states + (deflt_result, deflt_out_state) = deflt_fcode info_down default_in_state + + out_state = foldl stateIncUsage default_in_state (deflt_out_state:branch_out_states) + -- NB foldl. in_state is the *left* argument to stateIncUsage +\end{code} + +@forkEval@ takes two blocks of code. +\begin{itemize} +\item The first meddles with the environment to set it up as expected by + the alternatives of a @case@ which does an eval (or gc-possible primop). +\item The second block is the code for the alternatives. + (plus info for semi-tagging purposes) +\end{itemize} +@forkEval@ picks up the virtual stack pointers and stubbed stack slots +as set up by the first block, and returns a suitable @EndOfBlockInfo@ for +the caller to use, together with whatever value is returned by the second block. + +It uses @initEnvForAlternatives@ to initialise the environment, and +@stateIncUsageAlt@ to incorporate usage; the latter ignores the heap +usage. + +\begin{code} +forkEval :: EndOfBlockInfo -- For the body + -> Code -- Code to set environment + -> FCode Sequel -- Semi-tagging info to store + -> FCode EndOfBlockInfo -- The new end of block info + +forkEval body_eob_info env_code body_code + = forkEvalHelp body_eob_info env_code body_code `thenFC` \ (vA, vB, sequel) -> + returnFC (EndOfBlockInfo vA vB sequel) + +forkEvalHelp :: EndOfBlockInfo -- For the body + -> Code -- Code to set environment + -> FCode a -- The code to do after the eval + -> FCode (Int, -- SpA + Int, -- SpB + a) -- Result of the FCode + +forkEvalHelp body_eob_info env_code body_code + info_down@(MkCgInfoDown cg_info statics _) state + = ((vA,vB,value_returned), state `stateIncUsageEval` state_at_end_return) + where + info_down_for_body = MkCgInfoDown cg_info statics body_eob_info + + (MkCgState _ binds ((vA,fA,_,_), (vB,fB,_,_), _)) = env_code info_down_for_body state + -- These vA and fA things are now set up as the body code expects them + + state_at_end_return :: CgState + + (value_returned, state_at_end_return) = body_code info_down_for_body state_for_body + + state_for_body :: CgState + + state_for_body = MkCgState AbsCNop + (nukeVolatileBinds binds) + ((vA,stubbed_fA,vA,vA), -- Set real and hwms + (vB,fB,vB,vB), -- to virtual ones + (initVirtHp, initRealHp)) + + stubbed_fA = [ (offset, Stubbed) | (offset,_) <- fA ] + -- In the branch, all free locations will have been stubbed + + +stateIncUsageEval :: CgState -> CgState -> CgState +stateIncUsageEval (MkCgState absC1 bs ((vA,fA,rA,hA1),(vB,fB,rB,hB1),heap_usage)) + (MkCgState absC2 _ (( _, _, _,hA2),( _, _, _,hB2), _)) + = MkCgState (absC1 `AbsCStmts` absC2) + -- The AbsC coming back should consist only of nested declarations, + -- notably of the return vector! + bs + ((vA,fA,rA,hA1 `max` hA2), + (vB,fB,rB,hB1 `max` hB2), + heap_usage) + -- We don't max the heap high-watermark because stateIncUsageEval is + -- used only in forkEval, which in turn is only used for blocks of code + -- which do their own heap-check. +\end{code} + +%************************************************************************ +%* * +\subsection[CgMonad-spitting-AbstractC]{Spitting out @AbstractC@} +%* * +%************************************************************************ + +@nopC@ is the no-op for the @Code@ monad; it adds no Abstract~C to the +environment; @absC@ glues @ab_C@ onto the Abstract~C collected so far. +\begin{code} +nopC :: Code +nopC info_down state = state + +absC :: AbstractC -> Code +absC more_absC info_down state@(MkCgState absC binds usage) + = MkCgState (mkAbsCStmts absC more_absC) binds usage +\end{code} + +These two are just like @absC@, except they examine the compilation +info (whether SCC profiling or profiling-ctrs going) and possibly emit +nothing. + +\begin{code} +isSwitchSetC :: GlobalSwitch -> FCode Bool + +isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state + = (sw_chkr switch, state) + +isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool + +isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state + = (sw_chkr (switch (panic "isStringSwitchSetC")), state) + +costCentresC :: FAST_STRING -> [CAddrMode] -> Code + +costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) + state@(MkCgState absC binds usage) + = if sw_chkr 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) + then state + else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage + +{- Try to avoid adding too many special compilation strategies here. + It's better to modify the header files as necessary for particular targets, + so that we can get away with as few variants of .hc files as possible. + 'ForConcurrent' is somewhat special anyway, as it changes entry conventions + pretty significantly. +-} + +-- if compiling for concurrency... + +{- UNUSED, as it happens: +concurrentC :: AbstractC -> Code + +concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) + state@(MkCgState absC binds usage) + = if not (sw_chkr ForConcurrent) + then state + else MkCgState (mkAbsCStmts absC more_absC) binds usage +-} +\end{code} + +@getAbsC@ compiles the code in the current environment, and returns +the abstract C thus constructed (leaving the abstract C being carried +around in the state untouched). @getAbsC@ does not generate any +in-line Abstract~C itself, but the environment it returns is that +obtained from the compilation. + +\begin{code} +getAbsC :: Code -> FCode AbstractC + +getAbsC code info_down (MkCgState absC binds usage) + = (absC2, MkCgState absC binds2 usage2) + where + (MkCgState absC2 binds2 usage2) = code info_down (MkCgState AbsCNop binds usage) +\end{code} + +\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) +\end{code} + +\begin{code} + +moduleName :: FCode FAST_STRING +moduleName (MkCgInfoDown (MkCompInfo _ mod_name) _ _) state + = (mod_name, state) + +\end{code} + +\begin{code} +setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code +setEndOfBlockInfo eob_info code (MkCgInfoDown c_info statics _) state + = code (MkCgInfoDown c_info statics eob_info) state + +getEndOfBlockInfo :: FCode EndOfBlockInfo +getEndOfBlockInfo (MkCgInfoDown c_info statics eob_info) state + = (eob_info, state) +\end{code} + +%************************************************************************ +%* * +\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} +%* * +%************************************************************************ + +There are three basic routines, for adding (@addBindC@), modifying +(@modifyBindC@) and looking up (@lookupBindC@) bindings. Each routine +is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C} +on the end of each function name). + +A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. +The name should not already be bound. +\begin{code} +addBindC :: Id -> CgIdInfo -> Code +addBindC name stuff_to_bind info_down (MkCgState absC binds usage) + = MkCgState absC (addOneToIdEnv binds name stuff_to_bind) usage +\end{code} + +\begin{code} +addBindsC :: [(Id, CgIdInfo)] -> Code +addBindsC new_bindings info_down (MkCgState absC binds usage) + = MkCgState absC new_binds usage + where + new_binds = foldl (\ binds (name,info) -> addOneToIdEnv binds name info) + binds + new_bindings +\end{code} + +\begin{code} +modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code +modifyBindC name mangle_fn info_down (MkCgState absC binds usage) + = MkCgState absC (modifyIdEnv binds mangle_fn name) usage +\end{code} + +Lookup is expected to find a binding for the @Id@. +\begin{code} +lookupBindC :: Id -> FCode CgIdInfo +lookupBindC name info_down@(MkCgInfoDown _ static_binds _) + state@(MkCgState absC local_binds usage) + = (val, state) + where + val = case (lookupIdEnv local_binds name) of + Nothing -> try_static + Just this -> this + + try_static = case (lookupIdEnv static_binds name) of + Just this -> this + Nothing + -> pprPanic "lookupBindC:no info!\n" + (ppAboves [ + ppCat [ppStr "for:", ppr PprShowAll name], + ppStr "(probably: data dependencies broken by an optimisation pass)", + ppStr "static binds for:", + ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv static_binds ], + ppStr "local binds for:", + ppAboves [ ppr PprDebug i | (MkCgIdInfo i _ _ _) <- rngIdEnv local_binds ] + ]) +\end{code} + +For dumping debug information, we also have the ability to grab the +local bindings environment. + +ToDo: Maybe do the pretty-printing here to restrict what people do +with the environment. + +\begin{code} +{- UNUSED: +grabBindsC :: FCode CgBindings +grabBindsC info_down state@(MkCgState absC binds usage) + = (binds, state) +-} +\end{code} + +\begin{code} +{- UNUSED: +grabStackSizeC :: FCode (Int, Int) +grabStackSizeC info_down state -- @(MkCgState absC binds ((vA,_,_,_), (vB,_,_,_), _)) + = panic "grabStackSizeC" -- (vA, vB) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[CgStackery-deadslots]{Finding dead stack slots} +%* * +%************************************************************************ + +@nukeDeadBindings@ does the following: +\begin{itemize} +\item Removes all bindings from the environment other than those + for variables in the argument to @nukeDeadBindings@. +\item Collects any stack slots so freed, and returns them to the appropriate + stack free list. +\item Moves the virtual stack pointers to point to the topmost used + stack locations. +\end{itemize} + +Find dead slots on the stacks *and* remove bindings for dead variables +from the bindings. + +You can have multi-word slots on the B stack; if dead, such a slot +will be reported as {\em several} offsets (one per word). + +NOT YET: It returns empty lists if the -fno-stack-stubbing flag is +set, so that no stack-stubbing will take place. + +Probably *naughty* to look inside monad... + +\begin{code} +nukeDeadBindings :: PlainStgLiveVars -- All the *live* variables + -> Code +nukeDeadBindings + live_vars + info_down + state@(MkCgState abs_c binds ((vsp_a, free_a, real_a, hw_a), + (vsp_b, free_b, real_b, hw_b), + heap_usage)) + = MkCgState abs_c (mkIdEnv bs') new_usage + where + new_usage = ((new_vsp_a, new_free_a, real_a, hw_a), + (new_vsp_b, new_free_b, real_b, hw_b), + heap_usage) + + (dead_a_slots, dead_b_slots, bs') + = dead_slots live_vars + [] [] [] + [ (i, b) | b@(MkCgIdInfo i _ _ _) <- rngIdEnv binds ] + --OLD: (getIdEnvMapping binds) + + extra_free_a = (sortLt (<) dead_a_slots) `zip` (repeat NotStubbed) + extra_free_b = sortLt (<) dead_b_slots + + (new_vsp_a, new_free_a) = trim fst vsp_a (addFreeASlots free_a extra_free_a) + (new_vsp_b, new_free_b) = trim id vsp_b (addFreeBSlots free_b extra_free_b) + +getUnstubbedAStackSlots + :: VirtualSpAOffset -- Ignore slots bigger than this + -> FCode [VirtualSpAOffset] -- Return the list of slots found + +getUnstubbedAStackSlots tail_spa + info_down state@(MkCgState _ _ ((_, free_a, _, _), _, _)) + = ([ slot | (slot, NotStubbed) <- free_a, slot <= tail_spa ], state) +\end{code} + +Several boring auxiliary functions to do the dirty work. + +\begin{code} +dead_slots :: PlainStgLiveVars + -> [(Id,CgIdInfo)] -> [VirtualSpAOffset] -> [VirtualSpBOffset] + -> [(Id,CgIdInfo)] + -> ([VirtualSpAOffset], [VirtualSpBOffset], [(Id,CgIdInfo)]) + +-- dead_slots carries accumulating parameters for +-- filtered bindings, dead a and b slots +dead_slots live_vars fbs das dbs [] + = (nub das, nub dbs, reverse fbs) -- Finished; rm the dups, if any + +dead_slots live_vars fbs das dbs ((v,i):bs) + | v `elementOfUniqSet` live_vars + = dead_slots live_vars ((v,i):fbs) das dbs bs + -- Live, so don't record it in dead slots + -- Instead keep it in the filtered bindings + + | otherwise + = case i of + MkCgIdInfo _ _ stable_loc _ + | is_Astk_loc -> + dead_slots live_vars fbs (offsetA : das) dbs bs + + | is_Bstk_loc -> + dead_slots live_vars fbs das ([offsetB .. (offsetB + size - 1)] ++ dbs) bs + where + maybe_Astk_loc = maybeAStkLoc stable_loc + is_Astk_loc = maybeToBool maybe_Astk_loc + (Just offsetA) = maybe_Astk_loc + + maybe_Bstk_loc = maybeBStkLoc stable_loc + is_Bstk_loc = maybeToBool maybe_Bstk_loc + (Just offsetB) = maybe_Bstk_loc + + _ -> dead_slots live_vars fbs das dbs bs + where + size :: Int + size = (getKindSize . kindFromType . getIdUniType) v + +-- addFreeSlots expects *both* args to be in increasing order +addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)] +addFreeASlots = addFreeSlots fst + +addFreeBSlots :: [Int] -> [Int] -> [Int] +addFreeBSlots = addFreeSlots id + +addFreeSlots :: (slot -> Int{-offset-}) -> [slot] -> [slot] -> [slot] + +addFreeSlots get_offset cs [] = cs +addFreeSlots get_offset [] ns = ns +addFreeSlots get_offset (c:cs) (n:ns) + = if off_c < off_n then + (c : addFreeSlots get_offset cs (n:ns)) + else if off_c > off_n then + (n : addFreeSlots get_offset (c:cs) ns) + else + panic ("addFreeSlots: equal slots: ")-- ++ show (c:cs) ++ show (n:ns)) + where + off_c = get_offset c + off_n = get_offset n + +trim :: (slot -> Int{-offset-}) -> Int{-offset-} -> [slot] -> (Int{-offset-}, [slot]) + +trim get_offset current_sp free_slots + = try current_sp (reverse free_slots) + where + try csp [] = (csp, []) + try csp (slot:slots) + = if csp < slot_off then + try csp slots -- Free slot off top of stk; ignore + + else if csp == slot_off then + try (csp-1) slots -- Free slot at top of stk; trim + + else + (csp, reverse (slot:slots)) -- Otherwise gap; give up + where + slot_off = get_offset slot +\end{code} diff --git a/ghc/compiler/codeGen/CgRetConv.hi b/ghc/compiler/codeGen/CgRetConv.hi new file mode 100644 index 0000000..f722d30 --- /dev/null +++ b/ghc/compiler/codeGen/CgRetConv.hi @@ -0,0 +1,39 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgRetConv where +import AbsCSyn(AbstractC, CAddrMode, MagicId) +import CLabelInfo(CLabel) +import Class(Class) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data CLabel +data CtrlReturnConvention = VectoredReturn Int | UnvectoredReturn Int +data DataReturnConvention = ReturnInHeap | ReturnInRegs [MagicId] +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +assignPrimOpResultRegs :: PrimOp -> [MagicId] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +assignRegs :: [MagicId] -> [PrimKind] -> ([MagicId], [PrimKind]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +dataReturnConvAlg :: Id -> DataReturnConvention + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +dataReturnConvPrim :: PrimKind -> MagicId + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "E" _N_ _N_ #-} +makePrimOpArgsRobust :: PrimOp -> [CAddrMode] -> ([CAddrMode], Int, AbstractC) + {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkLiveRegsBitMask :: [MagicId] -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +noLiveRegsMask :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [0#] _N_ #-} + diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs new file mode 100644 index 0000000..9b6a130 --- /dev/null +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -0,0 +1,436 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1995 +% +\section[CgRetConv]{Return conventions for the code generator} + +The datatypes and functions here encapsulate what there is to know +about return conventions. + +\begin{code} +#include "HsVersions.h" + +module CgRetConv ( + CtrlReturnConvention(..), DataReturnConvention(..), + + ctrlReturnConvAlg, + dataReturnConvAlg, + + mkLiveRegsBitMask, noLiveRegsMask, + + dataReturnConvPrim, + + assignPrimOpResultRegs, + makePrimOpArgsRobust, + assignRegs, + + -- and to make the interface self-sufficient... + MagicId, PrimKind, Id, CLabel, TyCon + ) where + +import AbsCSyn + +import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC, + getPrimOpResultInfo, PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( getTyConFamilySize, kindFromType, getTyConDataCons, + TyVarTemplate, TyCon, Class, + TauType(..), ThetaType(..), UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import CgCompInfo -- various things + +import Id ( Id, getDataConSig, fIRST_TAG, isDataCon, + DataCon(..), ConTag(..) + ) +import Maybes ( catMaybes, Maybe(..) ) +import PrimKind +import Util +import Pretty +\end{code} + +%************************************************************************ +%* * +\subsection[CgRetConv-possibilities]{Data types that encode possible return conventions} +%* * +%************************************************************************ + +A @CtrlReturnConvention@ says how {\em control} is returned. +\begin{code} +data CtrlReturnConvention + = VectoredReturn Int -- size of the vector table (family size) + | UnvectoredReturn Int -- family size +\end{code} + +A @DataReturnConvention@ says how the data for a particular +data-constructor is returned. +\begin{code} +data DataReturnConvention + = ReturnInHeap + | ReturnInRegs [MagicId] +\end{code} +The register assignment given by a @ReturnInRegs@ obeys three rules: +\begin{itemize} +\item R1 is dead. +\item R2 points to the info table for the phantom constructor +\item The list of @MagicId@ is in the same order as the arguments + to the constructor. +\end{itemize} + + +%************************************************************************ +%* * +\subsection[CgRetConv-algebraic]{Return conventions for algebraic datatypes} +%* * +%************************************************************************ + +\begin{code} +ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention +ctrlReturnConvAlg tycon + = case (getTyConFamilySize tycon) of + Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon) + UnvectoredReturn 0 -- e.g., w/ "data Bin" + + Just size -> -- we're supposed to know... + if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then + VectoredReturn size + else + UnvectoredReturn size +\end{code} + +@dataReturnConvAlg@ determines the return conventions from the +(possibly specialised) data constructor. + +(See also @getDataConReturnConv@ (in @Id@).) We grab the types +of the data constructor's arguments. We feed them and a list of +available registers into @assign_reg@, which sequentially assigns +registers of the appropriate types to the arguments, based on the +types. If @assign_reg@ runs out of a particular kind of register, +then it gives up, returning @ReturnInHeap@. + +\begin{code} +dataReturnConvAlg :: DataCon -> DataReturnConvention + +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 + (reg_assignment, leftover_kinds) = assignRegs [node,infoptr] + (map kindFromType arg_tys) +\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) + | isFollowableKind 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) + | isFollowableKind 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} +%* * +%************************************************************************ + +WARNING! If you add a return convention which can return a pointer, +make sure you alter CgCase (cgPrimDefault) to generate the right sort +of heap check! +\begin{code} +dataReturnConvPrim :: PrimKind -> MagicId + +#ifndef DPH +dataReturnConvPrim IntKind = VanillaReg IntKind ILIT(1) +dataReturnConvPrim WordKind = VanillaReg WordKind ILIT(1) +dataReturnConvPrim AddrKind = VanillaReg AddrKind ILIT(1) +dataReturnConvPrim CharKind = VanillaReg CharKind ILIT(1) +dataReturnConvPrim FloatKind = FloatReg ILIT(1) +dataReturnConvPrim DoubleKind = DoubleReg ILIT(1) +dataReturnConvPrim VoidKind = VoidReg + +-- Return a primitive-array pointer in the usual register: +dataReturnConvPrim ArrayKind = VanillaReg ArrayKind ILIT(1) +dataReturnConvPrim ByteArrayKind = VanillaReg ByteArrayKind ILIT(1) + +dataReturnConvPrim StablePtrKind = VanillaReg StablePtrKind ILIT(1) +dataReturnConvPrim MallocPtrKind = VanillaReg MallocPtrKind ILIT(1) + +dataReturnConvPrim PtrKind = panic "dataReturnConvPrim: PtrKind" +dataReturnConvPrim _ = panic "dataReturnConvPrim: other" + +#else +dataReturnConvPrim VoidKind = VoidReg +dataReturnConvPrim PtrKind = panic "dataReturnConvPrim: PtrKind" +dataReturnConvPrim kind = DataReg kind 2 -- Don't Hog a Modifier reg. +#endif {- Data Parallel Haskell -} +\end{code} + + +%******************************************************** +%* * +\subsection[primop-stuff]{Argument and return conventions for Prim Ops} +%* * +%******************************************************** + +\begin{code} +assignPrimOpResultRegs + :: PrimOp -- The constructors in canonical order + -> [MagicId] -- The return regs all concatenated to together, + -- (*including* one for the tag if necy) + +assignPrimOpResultRegs op + = case (getPrimOpResultInfo op) of + + ReturnsPrim kind -> [dataReturnConvPrim kind] + + ReturnsAlg tycon -> let cons = getTyConDataCons tycon + result_regs = concat (map get_return_regs cons) + in + -- Since R1 is dead, it can hold the tag if necessary + case cons of + [_] -> result_regs + other -> (VanillaReg IntKind ILIT(1)) : result_regs + + where + get_return_regs con = case (dataReturnConvAlg con) of + ReturnInHeap -> panic "getPrimOpAlgResultRegs" + ReturnInRegs regs -> regs +\end{code} + +@assignPrimOpArgsRobust@ is used only for primitive ops which may +trigger GC. [MAYBE (WDP 94/05)] For these, we pass all (nonRobust) +arguments in registers. This function assigns them and tells us which +of those registers are now live (because we've shoved a followable +argument into it). + +Bug: it is assumed that robust amodes cannot contain pointers. This +seems reasonable but isn't true. For example, \tr{Array#}'s +\tr{MallocPtr#}'s are pointers. (This is only known to bite on +\tr{_ccall_GC_} with a MallocPtr argument.) + +See after for some ADR comments... + +\begin{code} +makePrimOpArgsRobust + :: PrimOp + -> [CAddrMode] -- Arguments + -> ([CAddrMode], -- Arg registers + Int, -- Liveness mask + AbstractC) -- Simultaneous assignments to assign args to regs + +makePrimOpArgsRobust op arg_amodes + = ASSERT (primOpCanTriggerGC op) + let + non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes + arg_kinds = map getAmodeKind non_robust_amodes + + (arg_regs, extra_args) = 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)) + + arg_assts = mkAbstractCs (zipWith assign_to_reg arg_regs non_robust_amodes) + assign_to_reg reg_id amode = CAssign (CReg reg_id) amode + + safe_arg regs arg + | amodeCanSurviveGC arg = (regs, arg) + | otherwise = (tail regs, CReg (head regs)) + safe_amodes = snd (mapAccumL safe_arg arg_regs arg_amodes) + + liveness_mask = mkLiveRegsBitMask arg_regs + in + (safe_amodes, liveness_mask, arg_assts) +\end{code} + +%************************************************************************ +%* * +\subsubsection[CgRetConv-regs]{Register assignment} +%* * +%************************************************************************ + +How to assign registers. +Registers are assigned in order. + +If we run out, we don't attempt to assign +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 :: [MagicId] -- Unavailable registers + -> [PrimKind] -- Arg or result kinds to assign + -> ([MagicId], -- Register assignment in same order + -- for *initial segment of* input list + [PrimKind])-- leftover kinds + +#ifndef DPH +assignRegs regs_in_use kinds + = assign_reg kinds [] (mkRegTbl regs_in_use) + where + + assign_reg :: [PrimKind] -- arg kinds being scrutinized + -> [MagicId] -- accum. regs assigned so far (reversed) + -> ([Int], [Int], [Int]) + -- regs still avail: Vanilla, Float, Double + -> ([MagicId], [PrimKind]) + + assign_reg (VoidKind:ks) acc supply + = assign_reg ks (VoidReg:acc) supply -- one VoidReg is enough for everybody! + + assign_reg (FloatKind:ks) acc (vanilla_rs, IBOX(f):float_rs, double_rs) + = assign_reg ks (FloatReg f:acc) (vanilla_rs, float_rs, double_rs) + + assign_reg (DoubleKind:ks) acc (vanilla_rs, float_rs, IBOX(d):double_rs) + = assign_reg ks (DoubleReg d:acc) (vanilla_rs, float_rs, double_rs) + + assign_reg (k:ks) acc (IBOX(v):vanilla_rs, float_rs, double_rs) + | not (isFloatingKind k) + = assign_reg ks (VanillaReg k v:acc) (vanilla_rs, float_rs, double_rs) + + -- The catch-all. It can happen because either + -- (a) we've assigned all the regs so leftover_ks is [] + -- (b) we couldn't find a spare register in the appropriate supply + -- or, I suppose, + -- (c) we came across a Kind we couldn't handle (this one shouldn't happen) + assign_reg leftover_ks acc _ = (reverse acc, leftover_ks) +#else +assignRegs node_using_Ret1 kinds + = if node_using_Ret1 + then assign_reg kinds [] (tail vanillaRegNos) (tail datRegNos) + else assign_reg kinds [] vanillaRegNos (tail datRegNos) + where + assign_reg:: [PrimKind] -- arg kinds being scrutinized + -> [MagicId] -- accum. regs assigned so far (reversed) + -> [Int] -- Vanilla Regs (ptr, int, char, float or double) + -> [Int] -- Data Regs ( int, char, float or double) + -> ([MagicId], [PrimKind]) + + assign_reg (k:ks) acc (IBOX(p):ptr_regs) dat_regs + | isFollowableKind k + = assign_reg ks (VanillaReg k p:acc) ptr_regs dat_regs + + assign_reg (CharKind:ks) acc ptr_regs (d:dat_regs) + = assign_reg ks (DataReg CharKind d:acc) ptr_regs dat_regs + + assign_reg (IntKind:ks) acc ptr_regs (d:dat_regs) + = assign_reg ks (DataReg IntKind d:acc) ptr_regs dat_regs + + assign_reg (WordKind:ks) acc ptr_regs (d:dat_regs) + = assign_reg ks (DataReg WordKind d:acc) ptr_regs dat_regs + + assign_reg (AddrKind:ks) acc ptr_regs (d:dat_regs) + = assign_reg ks (DataReg AddrKind d:acc) ptr_regs dat_regs + + assign_reg (FloatKind:ks) acc ptr_regs (d:dat_regs) + = assign_reg ks (DataReg FloatKind d:acc) ptr_regs dat_regs + + -- Notice how doubles take up two data registers.... + assign_reg (DoubleKind:ks) acc ptr_regs (IBOX(d1):d2:dat_regs) + = assign_reg ks (DoubleReg d1:acc) ptr_regs dat_regs + + assign_reg (VoidKind:ks) acc ptr_regs dat_regs + = assign_reg ks (VoidReg:acc) ptr_regs dat_regs + + -- The catch-all. It can happen because either + -- (a) we've assigned all the regs so leftover_ks is [] + -- (b) we couldn't find a spare register in the appropriate supply + -- or, I suppose, + -- (c) we came across a Kind we couldn't handle (this one shouldn't happen) + -- ToDo Maybe when dataReg becomes empty, we can start using the + -- vanilla registers ???? + assign_reg leftover_ks acc _ _ = (reverse acc, leftover_ks) +#endif {- Data Parallel Haskell -} +\end{code} + +Register supplies. Vanilla registers can contain pointers, Ints, Chars. + +\begin{code} +vanillaRegNos :: [Int] +vanillaRegNos = [1 .. mAX_Vanilla_REG] +\end{code} + +Only a subset of the registers on the DAP can be used to hold pointers (and most +of these are taken up with things like the heap pointer and stack pointers). +However the resulting registers can hold integers, floats or chars. We therefore +allocate pointer like things into the @vanillaRegNos@ (and Ints Chars or Floats +if the remaining registers are empty). See NOTE.regsiterMap for an outline of +the global and local register allocation scheme. + +\begin{code} +#ifdef DPH +datRegNos ::[Int] +datRegNos = [1..mAX_Data_REG] -- For Ints, Floats, Doubles or Chars +#endif {- Data Parallel Haskell -} +\end{code} + +Floats and doubles have separate register supplies. + +\begin{code} +#ifndef DPH +floatRegNos, doubleRegNos :: [Int] +floatRegNos = [1 .. mAX_Float_REG] +doubleRegNos = [1 .. mAX_Double_REG] + +mkRegTbl :: [MagicId] -> ([Int], [Int], [Int]) +mkRegTbl regs_in_use = (ok_vanilla, ok_float, ok_double) + where + ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) vanillaRegNos) + ok_float = catMaybes (map (select FloatReg) floatRegNos) + ok_double = catMaybes (map (select DoubleReg) doubleRegNos) + + select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int + -- one we've unboxed the Int, we make a MagicId + -- and see if it is already in use; if not, return its number. + + select mk_reg_fun cand@IBOX(i) + = let + reg = mk_reg_fun i + in + if reg `not_elem` regs_in_use + then Just cand + else Nothing + where + not_elem = isn'tIn "mkRegTbl" + +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/codeGen/CgStackery.hi b/ghc/compiler/codeGen/CgStackery.hi new file mode 100644 index 0000000..25448fd --- /dev/null +++ b/ghc/compiler/codeGen/CgStackery.hi @@ -0,0 +1,35 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgStackery where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, StubFlag) +import ClosureInfo(ClosureInfo) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import UniqFM(UniqFM) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +adjustRealSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLU(U(LLLL)U(LLLL)L))" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +allocAStack :: CgInfoDownwards -> CgState -> (Int, CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLU(U(LLLL)LL))" {_A_ 5 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +allocBStack :: Int -> CgInfoDownwards -> CgState -> (Int, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LU(LLLL)L))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +allocUpdateFrame :: Int -> CAddrMode -> ((Int, Int, Int) -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 12111 _N_ _S_ "LLSU(LLU(LLS))U(LLU(LU(LLLL)L))" _N_ _N_ #-} +getFinalStackHW :: (Int -> Int -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkStkAmodes :: Int -> Int -> [CAddrMode] -> CgInfoDownwards -> CgState -> ((Int, Int, AbstractC), CgState) + {-# GHC_PRAGMA _A_ 5 _U_ 22201 _N_ _S_ "LLLAU(LLL)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkVirtStkOffsets :: Int -> Int -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, Int)], [(a, Int)]) + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs new file mode 100644 index 0000000..3ec30f0 --- /dev/null +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -0,0 +1,264 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CgStackery]{Stack management functions} + +Stack-twiddling operations, which are pretty low-down and grimy. +(This is the module that knows all about stack layouts, etc.) + +\begin{code} +#include "HsVersions.h" + +module CgStackery ( + allocAStack, allocBStack, allocUpdateFrame, + adjustRealSps, getFinalStackHW, + mkVirtStkOffsets, mkStkAmodes, + + -- and to make the interface self-sufficient... + AbstractC, CAddrMode, CgState, PrimKind + ) where + +import StgSyn +import CgMonad +import AbsCSyn + +import CgUsages ( getSpBRelOffset ) +import Maybes ( Maybe(..) ) +import PrimKind ( getKindSize, retKindSize, separateByPtrFollowness ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[CgStackery-layout]{Laying out a stack frame} +%* * +%************************************************************************ + +@mkVirtStkOffsets@ is given a list of arguments. The first argument +gets the {\em largest} virtual stack offset (remember, virtual offsets +increase towards the top of stack). + +\begin{code} +mkVirtStkOffsets :: VirtualSpAOffset -- Offset of the last allocated thing + -> VirtualSpBOffset -- ditto + -> (a -> PrimKind) -- to be able to grab kinds + -> [a] -- things to make offsets for + -> (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word + VirtualSpBOffset, -- ditto + [(a, VirtualSpAOffset)], -- boxed things with offsets + [(a, VirtualSpBOffset)]) -- unboxed things with offsets + +mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things + = let (boxeds, unboxeds) + = separateByPtrFollowness kind_fun things + (last_SpA_offset, boxd_w_offsets) + = mapAccumR computeOffset init_SpA_offset boxeds + (last_SpB_offset, ubxd_w_offsets) + = mapAccumR computeOffset init_SpB_offset unboxeds + in + (last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets) + where + computeOffset offset thing + = (offset + (getKindSize . kind_fun) thing, (thing, offset+(1::Int))) +\end{code} + +@mkStackAmodes@ is a higher-level version of @mkStackOffsets@. +It starts from the tail-call locations. +It returns a single list of addressing modes for the stack locations, +and therefore is in the monad. + +It also adjusts the high water mark if necessary. + +\begin{code} +mkStkAmodes :: VirtualSpAOffset -- Tail call positions + -> VirtualSpBOffset + -> [CAddrMode] -- things to make offsets for + -> FCode (VirtualSpAOffset, -- OUTPUTS: Topmost allocated word + VirtualSpBOffset, -- ditto + AbstractC) -- Assignments to appropriate stk slots + +mkStkAmodes tail_spa tail_spb things + info_down (MkCgState absC binds usage) + = (result, MkCgState absC binds new_usage) + where + result = (last_SpA_offset, last_SpB_offset, mkAbstractCs abs_cs) + + (last_SpA_offset, last_SpB_offset, ptrs_w_offsets, non_ptrs_w_offsets) + = mkVirtStkOffsets tail_spa tail_spb getAmodeKind things + + abs_cs + = [ CAssign (CVal (SpARel realSpA offset) PtrKind) thing + | (thing, offset) <- ptrs_w_offsets + ] + ++ + [ CAssign (CVal (SpBRel realSpB offset) (getAmodeKind thing)) thing + | (thing, offset) <- non_ptrs_w_offsets + ] + + ((vspA,fspA,realSpA,hwSpA), (vspB,fspB,realSpB,hwSpB), h_usage) = usage + + new_usage = ((vspA,fspA,realSpA,max last_SpA_offset hwSpA), + (vspB,fspB,realSpB,max last_SpB_offset hwSpB), + h_usage) + -- No need to fiddle with virtual SpA etc because this call is + -- only done just before the end of a block + + +\end{code} + +%************************************************************************ +%* * +\subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation} +%* * +%************************************************************************ + +Allocate a virtual offset for something. +\begin{code} +allocAStack :: FCode VirtualSpAOffset + +allocAStack info_down (MkCgState absC binds + ((virt_a, free_a, real_a, hw_a), b_usage, h_usage)) + = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage)) + where + push_virt_a = virt_a + 1 + + (chosen_slot, new_a_usage) + = if null free_a then + -- No free slots, so push a new one + -- We need to adjust the high-water mark + (push_virt_a, (push_virt_a, [], real_a, hw_a `max` push_virt_a)) + else + -- Free slots available, so use one + (free_slot, (virt_a, new_free_a, real_a, hw_a)) + + (free_slot, _) = head ([f | f@(slot, st) <- free_a, not (isStubbed st)] ++ free_a) + -- Try to find an un-stubbed location; + -- if none, return the first in the free list + -- We'll only try this if free_a is known to be non-empty + + -- Free list with the free_slot deleted + new_free_a = [ f | f@(s,_) <- free_a, s /= free_slot ] + +allocBStack :: Int -> FCode VirtualSpBOffset +allocBStack size info_down (MkCgState absC binds + (a_usage, (virt_b, free_b, real_b, hw_b), h_usage)) + = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage)) + where + push_virt_b = virt_b + size + + (chosen_slot, new_b_usage) + = case find_block free_b of + Nothing -> (virt_b+1, (push_virt_b, free_b, real_b, + hw_b `max` push_virt_b)) + -- Adjust high water mark + + Just slot -> (slot, (virt_b, delete_block free_b slot, real_b, hw_b)) + + -- find_block looks for a contiguous chunk of free slots + find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset + find_block [] = Nothing + find_block (slot:slots) + | take size (slot:slots) == take size (repeat slot) + = Just slot + | otherwise + = find_block slots + + delete_block free_b slot = [s | s <- free_b, (s=slot+size)] + -- Retain slots which are not in the range + -- slot..slot+size-1 +\end{code} + +@allocUpdateFrame@ allocates enough space for an update frame +on the B stack, records the fact in the end-of-block info (in the ``args'' +fields), and passes on the old ``args'' fields to the enclosed code. + +This is all a bit disgusting. + +\begin{code} +allocUpdateFrame :: Int -- Size of frame + -> CAddrMode -- Return address which is to be the + -- top word of frame + -> ((VirtualSpAOffset, VirtualSpBOffset, VirtualSpBOffset) -> Code) + -- Scope of update + -> Code + +allocUpdateFrame size update_amode code + (MkCgInfoDown c_info statics (EndOfBlockInfo args_spa args_spb sequel)) + (MkCgState absc binds (a_usage, (vB,rr,qq,hwB),h_usage)) + = case sequel of + + InRetReg -> code (args_spa, args_spb, vB) + (MkCgInfoDown c_info statics new_eob_info) + (MkCgState absc binds new_usage) + + other -> panic "allocUpdateFrame" + + where + new_vB = vB + size + new_eob_info = EndOfBlockInfo args_spa new_vB (UpdateCode update_amode) + new_usage = (a_usage, (new_vB,rr,qq,hwB `max` new_vB), h_usage) +\end{code} + + +A knot-tying beast. + +\begin{code} +getFinalStackHW :: (VirtualSpAOffset -> VirtualSpBOffset -> Code) -> Code +getFinalStackHW fcode info_down (MkCgState absC binds usages) = state1 + where + state1 = fcode hwSpA hwSpB info_down (MkCgState absC binds usages) + (MkCgState _ _ ((_,_,_, hwSpA), (_,_,_, hwSpB), _)) = state1 +\end{code} + + +%************************************************************************ +%* * +\subsection[CgStackery-adjust]{Adjusting the stack pointers} +%* * +%************************************************************************ + +@adjustRealSpX@ generates code to alter the actual stack pointer, and +adjusts the environment accordingly. We are careful to push the +conditional inside the abstract C code to avoid black holes. +ToDo: combine together? + +These functions {\em do not} deal with high-water-mark adjustment. +That's done by functions which allocate stack space. + +\begin{code} +adjustRealSpA :: VirtualSpAOffset -- New offset for Arg stack ptr + -> Code +adjustRealSpA newRealSpA info_down (MkCgState absC binds + ((vspA,fA,realSpA,hwspA), + b_usage, h_usage)) + = MkCgState (mkAbsCStmts absC move_instrA) binds new_usage + where + move_instrA = if (newRealSpA == realSpA) then AbsCNop + else (CAssign + (CReg SpA) + (CAddr (SpARel realSpA newRealSpA))) + new_usage = ((vspA, fA, newRealSpA, hwspA), + b_usage, h_usage) + +adjustRealSpB :: VirtualSpBOffset -- New offset for Basic/Control stack ptr + -> Code +adjustRealSpB newRealSpB info_down (MkCgState absC binds + (a_usage, + (vspB,fB,realSpB,hwspB), + h_usage)) + = MkCgState (mkAbsCStmts absC move_instrB) binds new_usage + where + move_instrB = if (newRealSpB == realSpB) then AbsCNop + else (CAssign {-PtrKind-} + (CReg SpB) + (CAddr (SpBRel realSpB newRealSpB))) + new_usage = (a_usage, + (vspB, fB, newRealSpB, hwspB), + h_usage) + +adjustRealSps :: VirtualSpAOffset -- New offset for Arg stack ptr + -> VirtualSpBOffset -- Ditto B stack + -> Code +adjustRealSps newRealSpA newRealSpB + = adjustRealSpA newRealSpA `thenC` adjustRealSpB newRealSpB +\end{code} diff --git a/ghc/compiler/codeGen/CgTailCall.hi b/ghc/compiler/codeGen/CgTailCall.hi new file mode 100644 index 0000000..fe77b1f --- /dev/null +++ b/ghc/compiler/codeGen/CgTailCall.hi @@ -0,0 +1,44 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgTailCall where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, MagicId, RegRelative) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, Sequel, StubFlag) +import Class(Class) +import ClosureInfo(LambdaFormInfo) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import StgSyn(StgAtom) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CgInfoDownwards {-# GHC_PRAGMA MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data HeapOffset +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +cgTailCall :: StgAtom Id -> [StgAtom Id] -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SSL" _N_ _N_ #-} +mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SLS" _N_ _N_ #-} +mkPrimReturnCode :: Sequel -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-} +mkStaticAlgReturnCode :: Id -> Labda CLabel -> Sequel -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LLS" _N_ _N_ #-} +performReturn :: AbstractC -> (Sequel -> CgInfoDownwards -> CgState -> CgState) -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 21221 _N_ _S_ "LSLU(LLU(LLL))L" _N_ _N_ #-} +tailCallBusiness :: Id -> CAddrMode -> LambdaFormInfo -> [CAddrMode] -> UniqFM Id -> AbstractC -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 6 _U_ 22222222 _N_ _S_ "LSLLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs new file mode 100644 index 0000000..a292b04 --- /dev/null +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -0,0 +1,548 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%******************************************************** +%* * +\section[CgTailCall]{Tail calls: converting @StgApps@} +%* * +%******************************************************** + +\begin{code} +#include "HsVersions.h" + +module CgTailCall ( + cgTailCall, + performReturn, + mkStaticAlgReturnCode, mkDynamicAlgReturnCode, + mkPrimReturnCode, + + tailCallBusiness, + + -- and to make the interface self-sufficient... + StgAtom, Id, CgState, CAddrMode, TyCon, + CgInfoDownwards, HeapOffset, Maybe + ) where + +IMPORT_Trace +import Pretty -- Pretty/Outputable: rm (debugging only) ToDo +import Outputable + +import StgSyn +import CgMonad +import AbsCSyn + +import AbsUniType ( isPrimType, UniType ) +import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo ) +import CgCompInfo ( oTHER_TAG, iND_TAG ) +import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg, + mkLiveRegsBitMask, + CtrlReturnConvention(..), DataReturnConvention(..) + ) +import CgStackery ( adjustRealSps, mkStkAmodes ) +import CgUsages ( getSpARelOffset, getSpBRelOffset ) +import CLabelInfo ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) +import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Id ( getDataConTyCon, getDataConTag, + getIdUniType, getIdKind, fIRST_TAG, Id, + ConTag(..) + ) +import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) +import PrimKind ( retKindSize ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[tailcall-doc]{Documentation} +%* * +%************************************************************************ + +\begin{code} +cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code +\end{code} + +Here's the code we generate for a tail call. (NB there may be no +arguments, in which case this boils down to just entering a variable.) + +\begin{itemize} +\item Adjust the stack ptr to \tr{tailSp + #args}. +\item Put args in the top locations of the resulting stack. +\item Make Node point to the function closure. +\item Enter the function closure. +\end{itemize} + +Things to be careful about: +\begin{itemize} +\item Don't overwrite stack locations before you have finished with + them (remember you need the function and the as-yet-unmoved + arguments). +\item Preferably, generate no code to replace x by x on the stack (a + common situation in tail-recursion). +\item Adjust the stack high water mark appropriately. +\end{itemize} + +Literals are similar to constructors; they return by putting +themselves in an appropriate register and returning to the address on +top of the B stack. + +\begin{code} +cgTailCall (StgLitAtom lit) [] live_vars + = performPrimReturn (CLit lit) live_vars +\end{code} + +Treat unboxed locals exactly like literals (above) except use the addr +mode for the local instead of (CLit lit) in the assignment. + +Case for unboxed @Ids@ first: +\begin{code} +cgTailCall atom@(StgVarAtom fun) [] live_vars + | isPrimType (getIdUniType fun) + = getCAddrMode fun `thenFC` \ amode -> + performPrimReturn amode live_vars +\end{code} + +The general case (@fun@ is boxed): +\begin{code} +cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars +\end{code} + +%************************************************************************ +%* * +\subsection[return-and-tail-call]{Return and tail call} +%* * +%************************************************************************ + +ADR-HACK + + A quick bit of hacking to try to solve my void#-leaking blues... + + I think I'm getting bitten by this stuff because code like + + \begin{pseudocode} + case ds.s12 :: IoWorld of { + -- lvs: [ds.s12]; rhs lvs: []; uniq: c0 + IoWorld ds.s13# -> ds.s13#; + } :: Universe# + \end{pseudocode} + + causes me to try to allocate a register to return the result in. The + hope is that the following will avoid such problems (and that Will + will do this in a cleaner way when he hits the same problem). + +KCAH-RDA + +\begin{code} +performPrimReturn :: CAddrMode -- The thing to return + -> PlainStgLiveVars + -> Code + +performPrimReturn amode live_vars + = let + kind = getAmodeKind amode + ret_reg = dataReturnConvPrim kind + + assign_possibly = case kind of + VoidKind -> AbsCNop + kind -> (CAssign (CReg ret_reg) amode) + in + performReturn assign_possibly mkPrimReturnCode live_vars + +mkPrimReturnCode :: Sequel -> Code +--UNUSED:mkPrimReturnCode RestoreCostCentre = panic "mkPrimReturnCode: RCC" +mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd" +mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode -> + absC (CReturn dest_amode DirectReturn) + -- Direct, no vectoring + +-- All constructor arguments in registers; Node and InfoPtr are set. +-- All that remains is +-- (a) to set TagReg, if necessary +-- (b) to set InfoPtr to the info ptr, if necessary +-- (c) to do the right sort of jump. + +mkStaticAlgReturnCode :: Id -- The constructor + -> Maybe CLabel -- The info ptr, if it isn't already set + -> Sequel -- where to return to + -> Code + +mkStaticAlgReturnCode con maybe_info_lbl sequel + = -- Generate profiling code if necessary + (case return_convention of + VectoredReturn _ -> profCtrC SLIT("VEC_RETURN") [] + other -> nopC + ) `thenC` + + -- Set tag if necessary + -- This is done by a macro, because if we are short of registers + -- we don't set TagReg; instead the continuation gets the tag + -- by indexing off the info ptr + (case return_convention of + + UnvectoredReturn no_of_constrs + | no_of_constrs > 1 + -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag]) + + other -> nopC + ) `thenC` + + -- Generate the right jump or return + (case sequel of + UpdateCode _ -> -- Ha! We know the constructor, + -- so we can go direct to the correct + -- update code for that constructor + + -- Set the info pointer, and jump + set_info_ptr `thenC` + absC (CJump (CLbl update_label CodePtrKind)) + + CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so + -- we can go right to the alternative + + -- No need to set info ptr when returning to a + -- known join point. After all, the code at + -- the destination knows what constructor it + -- is going to handle. + + case assocMaybe alts tag of + Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind)) + Nothing -> panic "mkStaticAlgReturnCode: default" + -- The Nothing case should never happen; it's the subject + -- of a wad of special-case code in cgReturnCon + + other -> -- OnStack, or (CaseAlts) ret_amode Nothing) + -- Set the info pointer, and jump + set_info_ptr `thenC` + sequelToAmode sequel `thenFC` \ ret_amode -> + absC (CReturn ret_amode return_info) + ) + + where + tag = getDataConTag con + tycon = getDataConTyCon con + return_convention = ctrlReturnConvAlg tycon + zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed + -- cf AbsCFuns.mkAlgAltsCSwitch + + update_label = case dataReturnConvAlg con of + ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag + ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag + + return_info = case return_convention of + UnvectoredReturn _ -> DirectReturn + VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag + + set_info_ptr = case maybe_info_lbl of + Nothing -> nopC + Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind)) + + +mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code + +mkDynamicAlgReturnCode tycon dyn_tag sequel + = case ctrlReturnConvAlg tycon of + VectoredReturn _ -> + + profCtrC SLIT("VEC_RETURN") [] `thenC` + sequelToAmode sequel `thenFC` \ ret_addr -> + absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag)) + + UnvectoredReturn no_of_constrs -> + + -- Set tag if necessary + -- This is done by a macro, because if we are short of registers + -- we don't set TagReg; instead the continuation gets the tag + -- by indexing off the info ptr + (if no_of_constrs > 1 then + absC (CMacroStmt SET_TAG [dyn_tag]) + else + nopC + ) `thenC` + + + sequelToAmode sequel `thenFC` \ ret_addr -> + -- Generate the right jump or return + absC (CReturn ret_addr DirectReturn) +\end{code} + +\begin{code} +performReturn :: AbstractC -- Simultaneous assignments to perform + -> (Sequel -> Code) -- The code to execute to actually do + -- the return, given an addressing mode + -- for the return address + -> PlainStgLiveVars + -> Code + +performReturn sim_assts finish_code live_vars + = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> + + -- Do the simultaneous assignments, + doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts `thenC` + + -- Adjust stack pointers + adjustRealSps args_spa args_spb `thenC` + + -- Do the return + finish_code sequel -- "sequel" is `robust' in that it doesn't + -- depend on stk-ptr values +-- where +--UNUSED: live_regs = getDestinationRegs sim_assts + -- ToDo: this is a *really* boring way to compute the + -- live-reg set! +\end{code} + +\begin{code} +performTailCall :: Id -- Function + -> [PlainStgAtom] -- Args + -> PlainStgLiveVars + -> Code + +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 -> + + tailCallBusiness + fun fun_amode lf_info arg_amodes + live_vars AbsCNop {- No pending assignments -} + + +tailCallBusiness :: Id -> CAddrMode -- Function and its amode + -> LambdaFormInfo -- Info about the function + -> [CAddrMode] -- Arguments + -> PlainStgLiveVars -- Live in continuation + + -> AbstractC -- Pending simultaneous assignments + -- *** GUARANTEED to contain only stack assignments. + -- In ptic, we don't need to look in here to + -- discover all live regs + + -> Code + +tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts + = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_TAILCALL") IntKind] `thenC` + + isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks -> + + nodeMustPointToIt lf_info `thenFC` \ node_points -> + getEntryConvention fun lf_info + (map getAmodeKind arg_amodes) `thenFC` \ entry_conv -> + + getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> + + let + node_asst + = if node_points then + CAssign (CReg node) fun_amode + else + AbsCNop + + (arg_regs, finish_code) + = case entry_conv of + ViaNode -> + ([], + mkAbstractCs [ + CCallProfCtrMacro SLIT("ENT_VIA_NODE") [], + CAssign (CReg infoptr) + + (CMacroExpr DataPtrKind INFO_PTR [CReg node]), + CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) + ]) + StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrKind)) + StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind) + `mkAbsCStmts` + CJump (CLbl lbl CodePtrKind)) + DirectEntry lbl arity regs -> + (regs, (if do_arity_chks + then CMacroStmt SET_ARITY [mkIntCLit arity] + else AbsCNop) + `mkAbsCStmts` CJump (CLbl lbl CodePtrKind)) + + no_of_args = length arg_amodes + +{- UNUSED: live_regs = if node_points then + node : arg_regs + else + arg_regs +-} + (reg_arg_assts, stk_arg_amodes) + = (mkAbstractCs (zipWith assign_to_reg arg_regs arg_amodes), + drop (length arg_regs) arg_amodes) -- No regs, or + -- args beyond arity + + assign_to_reg reg_id amode = CAssign (CReg reg_id) amode + + in + case fun_amode of + CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy + + ASSERT(not (args_spa > join_spa) || (args_spb > join_spb)) + -- If ASSERTion fails: Oops: the join point has *lower* + -- stack ptrs than the continuation Note that we take + -- the SpB point without the return address here. The + -- return address is put on by the let-no-escapey thing + -- when it finishes. + + mkStkAmodes join_spa join_spb stk_arg_amodes + `thenFC` \ (final_spa, final_spb, stk_arg_assts) -> + + -- Do the simultaneous assignments, + doSimAssts join_spa live_vars {-UNUSED: live_regs-} + (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts]) + `thenC` + + -- Adjust stack ptrs + adjustRealSps final_spa final_spb `thenC` + + -- Jump to join point + absC finish_code + + _ -> -- else: not a let-no-escape (the common case) + + -- Make instruction to save return address + loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst -> + + mkStkAmodes args_spa args_spb stk_arg_amodes + `thenFC` + \ (final_spa, final_spb, stk_arg_assts) -> + + -- The B-stack space for the pushed return addess, with any args pushed + -- on top, is recorded in final_spb. + + -- Do the simultaneous assignments, + doSimAssts args_spa live_vars {-UNUSED: live_regs-} + (mkAbstractCs [pending_assts, node_asst, ret_asst, + reg_arg_assts, stk_arg_assts]) + `thenC` + + -- Final adjustment of stack pointers + adjustRealSps final_spa final_spb `thenC` + + -- Now decide about semi-tagging + isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on -> + case (semi_tagging_on, arg_amodes, node_points, sequel) of + + -- + -- *************** The semi-tagging case *************** + -- + ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) -> + + -- Whoppee! Semi-tagging rules OK! + -- (a) semi-tagging is switched on + -- (b) there are no arguments, + -- (c) Node points to the closure + -- (d) we have a case-alternative sequel with + -- some visible alternatives + + -- Why is test (c) necessary? + -- Usually Node will point to it at this point, because we're + -- scrutinsing something which is either a thunk or a + -- constructor. + -- But not always! The example I came across is when we have + -- a top-level Double: + -- lit.3 = D# 3.000 + -- ... (case lit.3 of ...) ... + -- Here, lit.3 is built as a re-entrant thing, which you must enter. + -- (OK, the simplifier should have eliminated this, but it's + -- easy to deal with the case anyway.) + + + let + join_details_to_code (load_regs_and_profiling_code, join_lbl) + = load_regs_and_profiling_code `mkAbsCStmts` + CJump (CLbl join_lbl CodePtrKind) + + semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)), + join_details_to_code join_details) + | (tag, join_details) <- st_alts + ] + + -- This alternative is for the unevaluated case; oTHER_TAG is -1 + un_evald_alt = (mkMachInt oTHER_TAG, enter_jump) + + enter_jump = CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) + -- Enter Node (we know infoptr will have the info ptr in it)! + + in + + -- Final switch + absC (mkAbstractCs [ + CAssign (CReg infoptr) + (CVal (NodeRel zeroOff) DataPtrKind), + + case maybe_deflt_join_details of + Nothing -> + CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr]) + (semi_tagged_alts) + (enter_jump) + Just (_, details) -> + CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr]) + [(mkMachInt 0, enter_jump)] + (CSwitch + (CMacroExpr IntKind INFO_TAG [CReg infoptr]) + (semi_tagged_alts) + (join_details_to_code details)) + ]) + + -- + -- *************** The non-semi-tagging case *************** + -- + other -> absC finish_code +\end{code} + +\begin{code} +loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC + +loadRetAddrIntoRetReg InRetReg + = returnFC AbsCNop -- Return address already there + +loadRetAddrIntoRetReg sequel + = sequelToAmode sequel `thenFC` \ amode -> + returnFC (CAssign (CReg RetReg) amode) + +\end{code} + +%************************************************************************ +%* * +\subsection[doSimAssts]{@doSimAssts@} +%* * +%************************************************************************ + +@doSimAssts@ happens at the end of every block of code. +They are separate because we sometimes do some jiggery-pokery in between. + +\begin{code} +doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation + -> PlainStgLiveVars -- Live in continuation +--UNUSED: -> [MagicId] -- Live regs (ptrs and non-ptrs) + -> AbstractC + -> Code + +doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts + = -- Do the simultaneous assignments + absC (CSimultaneous sim_assts) `thenC` + + -- Stub any unstubbed slots; the only live variables are indicated in + -- the end-of-block info in the monad + nukeDeadBindings live_vars `thenC` + getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots -> + -- Passing in tail_spa here should actually be redundant, because + -- the stack should be trimmed (by nukeDeadBindings) to + -- exactly the tail_spa position anyhow. + + -- Emit code to stub dead regs; this only generates actual + -- machine instructions in in the DEBUG version + -- *** NOT DONE YET *** + + (if (null a_slots) + then nopC + else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC` + mapCs stub_A_slot a_slots + ) + where + stub_A_slot :: VirtualSpAOffset -> Code + stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel -> + absC (CAssign (CVal spa_rel PtrKind) + (CReg StkStubReg)) +\end{code} diff --git a/ghc/compiler/codeGen/CgUpdate.hi b/ghc/compiler/codeGen/CgUpdate.hi new file mode 100644 index 0000000..0ff61fa --- /dev/null +++ b/ghc/compiler/codeGen/CgUpdate.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgUpdate where +import AbsCSyn(CAddrMode) +import CgMonad(CgInfoDownwards, CgState) +pushUpdateFrame :: CAddrMode -> CAddrMode -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _S_ "LLSU(U(LL)LU(LLS))U(LLU(LU(LLLL)L))" _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs new file mode 100644 index 0000000..40daf37 --- /dev/null +++ b/ghc/compiler/codeGen/CgUpdate.lhs @@ -0,0 +1,155 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[CgUpdate]{Manipulating update frames} + +\begin{code} +#include "HsVersions.h" + +module CgUpdate ( + pushUpdateFrame -- OLD: , evalPushRCCFrame + ) where + +import StgSyn +import CgMonad +import AbsCSyn + +import CgCompInfo ( sTD_UF_SIZE, cON_UF_SIZE, + sCC_STD_UF_SIZE, sCC_CON_UF_SIZE, + spARelToInt, spBRelToInt + ) +import CgStackery ( allocUpdateFrame ) +import CgUsages +import CmdLineOpts ( GlobalSwitch(..) ) +import Util +\end{code} + + +%******************************************************** +%* * +%* Setting up update frames * +%* * +%******************************************************** +\subsection[setting-update-frames]{Setting up update frames} + +@pushUpdateFrame@ $updatee$ pushes a general update frame which +points to $updatee$ as the thing to be updated. It is only used +when a thunk has just been entered, so the (real) stack pointers +are guaranteed to be nicely aligned with the top of stack. +@pushUpdateFrame@ adjusts the virtual and tail stack pointers +to reflect the frame pushed. + +\begin{code} +pushUpdateFrame :: CAddrMode -> CAddrMode -> Code -> Code + +pushUpdateFrame updatee vector code + = isSwitchSetC SccProfilingOn `thenFC` \ profiling_on -> + let + -- frame_size *includes* the return address + frame_size = if profiling_on + then sCC_STD_UF_SIZE + else sTD_UF_SIZE + in + getEndOfBlockInfo `thenFC` \ eob_info -> + ASSERT(case eob_info of { EndOfBlockInfo _ _ InRetReg -> True; _ -> False}) + allocUpdateFrame frame_size vector (\ _ -> + + -- Emit the push macro + absC (CMacroStmt PUSH_STD_UPD_FRAME [ + updatee, + int_CLit0, -- Known to be zero because we have just + int_CLit0 -- entered a thunk + ]) + `thenC` code + ) + +int_CLit0 = mkIntCLit 0 -- out here to avoid pushUpdateFrame CAF (sigh) + +{- --------------------- + What actually happens is something like this; but it got macro-ised + + = pushOnBStack (CReg CurCostCentre) `thenFC` \ _ -> + pushOnBStack (CReg SuA) `thenFC` \ _ -> + pushOnBStack (CReg SuB) `thenFC` \ _ -> + pushOnBStack updatee `thenFC` \ _ -> + pushOnBStack (CLabel sTD_UPD_RET_VEC_LABEL CodePtrKind) `thenFC` \ _ -> + + -- MAKE SuA, SuB POINT TO TOP OF A,B STACKS + -- Remember, SpB hasn't yet been incremented to account for the + -- 4-word update frame which has been pushed. + -- This code seems crude, but effective... + absC (AbsCStmts (CAssign (CReg SuA) (CReg SpA)) + (CAssign (CReg SuB) (CAddr (SpBRel 0 4)))) +-------------------------- -} +\end{code} + +@evalPushRCCFrame@ pushes a frame to restore the cost centre, and +deallocates stuff from the A and B stack if evaluation profiling. No +actual update is required so no closure to update is passed. +@evalPushRCCFrame@ is called for an @scc@ expression and on entry to a +single-entry thunk: no update reqd but cost centre manipulation is. + +\begin{code} +{- OLD: WDP: 94/06 + +evalPushRCCFrame :: Bool -> Code -> Code + +evalPushRCCFrame prim code + = isSwitchSetC SccProfiling_Eval `thenFC` \ eval_profiling -> + + if (not eval_profiling) then + code + else + + -- Find out how many words of stack must will be + -- deallocated at the end of the basic block + -- As we push stuff onto the B stack we must make the + -- RCC frame dealocate the B stack words + + -- We dont actually push things onto the A stack so we + -- can treat the A stack as if these words were not there + -- i.e. we subtract them from the A stack offset + -- They will be popped by the current block of code + + -- Tell downstream code about the update frame on the B stack + allocUpdateFrame + sCC_RCC_UF_SIZE + (panic "pushEvalRCCFrame: mkRestoreCostCentreLbl") + (\ (old_args_spa, old_args_spb, upd_frame_offset) -> + + getSpARelOffset old_args_spa `thenFC` \ old_args_spa_rel -> + getSpBRelOffset upd_frame_offset `thenFC` \ upd_frame_rel -> + + let b_wds_to_pop = upd_frame_offset - old_args_spb + in + + -- Allocate enough space on the B stack for the frame + + evalCostCentreC + (if prim then + "PUSH_RCC_FRAME_RETURN" + else + "PUSH_RCC_FRAME_VECTOR") + [ + mkIntCLit (spARelToInt old_args_spa_rel), + {- Place on A stack to ``draw the line'' -} + mkIntCLit (spBRelToInt upd_frame_rel), + {- Ditto B stk. The update frame is pushed starting + just above here -} + mkIntCLit 0, + {- Number of words of A below the line, which must be + popped to get to the tail-call position -} + mkIntCLit b_wds_to_pop + {- Ditto B stk -} + ] `thenC` + + code + + + -- If we actually pushed things onto the A stack we have + -- to arrange for the RCC frame to pop these as well + -- Would need to tell downstream code about the update frame + -- both the A and B stacks + ) +-} +\end{code} diff --git a/ghc/compiler/codeGen/CgUsages.hi b/ghc/compiler/codeGen/CgUsages.hi new file mode 100644 index 0000000..0a1ecaf --- /dev/null +++ b/ghc/compiler/codeGen/CgUsages.hi @@ -0,0 +1,39 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CgUsages where +import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CgBindery(CgIdInfo) +import CgMonad(CgInfoDownwards, CgState, StubFlag) +import ClosureInfo(ClosureInfo) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import UniqFM(UniqFM) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data HeapOffset +freeBStkSlot :: Int -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LU(LLLL)L))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getHpRelOffset :: HeapOffset -> CgInfoDownwards -> CgState -> (RegRelative, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LLU(LL)))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSpARelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(U(LLLL)LL))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSpBRelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LU(LLLL)L))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getVirtAndRealHp :: CgInfoDownwards -> CgState -> ((HeapOffset, HeapOffset), CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLU(LLU(LL)))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> case u1 of { _ALG_ _ORIG_ CgMonad MkCgState (u2 :: AbstractC) (u3 :: UniqFM CgIdInfo) (u4 :: ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))) -> case u4 of { _ALG_ _TUP_3 (u5 :: (Int, [(Int, StubFlag)], Int, Int)) (u6 :: (Int, [Int], Int, Int)) (u7 :: (HeapOffset, HeapOffset)) -> case u7 of { _ALG_ _TUP_2 (u8 :: HeapOffset) (u9 :: HeapOffset) -> _!_ _TUP_2 [(HeapOffset, HeapOffset), CgState] [u7, u1]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getVirtSps :: CgInfoDownwards -> CgState -> ((Int, Int), CgState) + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLU(U(LLLL)U(LLLL)L))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +initHeapUsage :: (HeapOffset -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLU(LLU(LLL))" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +setRealAndVirtualSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLU(U(ALAA)U(ALAA)L))" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +setRealHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LLU(LA)))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +setVirtHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LLU(AL)))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs new file mode 100644 index 0000000..41ebe84 --- /dev/null +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -0,0 +1,152 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CgUsages]{Accessing and modifying stacks and heap usage info} + +This module provides the functions to access (\tr{get*} functions) and +modify (\tr{set*} functions) the stacks and heap usage information. + +\begin{code} +module CgUsages ( + initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp, + setRealAndVirtualSps, + + getVirtSps, + + getHpRelOffset, getSpARelOffset, getSpBRelOffset, +--UNUSED: getVirtSpRelOffsets, + + freeBStkSlot, + + -- and to make the interface self-sufficient... + AbstractC, HeapOffset, RegRelative, CgState + ) where + +import AbsCSyn +import CgMonad +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage} +%* * +%************************************************************************ + +@initHeapUsage@ applies a function to the amount of heap that it uses. +It initialises the heap usage to zeros, and passes on an unchanged +heap usage. + +It is usually a prelude to performing a GC check, so everything must +be in a tidy and consistent state. + +\begin{code} +initHeapUsage :: (VirtualHeapOffset -> Code) -> Code + +initHeapUsage fcode info_down (MkCgState absC binds (a_usage, b_usage, heap_usage)) + = state3 + where + state1 = MkCgState absC binds (a_usage, b_usage, (zeroOff, zeroOff)) + state2 = fcode (heapHWM heap_usage2) info_down state1 + (MkCgState absC2 binds2 (a_usage2, b_usage2, heap_usage2)) = state2 + state3 = MkCgState absC2 + binds2 + (a_usage2, b_usage2, heap_usage {- unchanged -}) +\end{code} + +\begin{code} +setVirtHp :: VirtualHeapOffset -> Code +setVirtHp new_virtHp info_down + state@(MkCgState absC binds (a_stk, b_stk, (virtHp, realHp))) + = MkCgState absC binds (a_stk, b_stk, (new_virtHp, realHp)) +\end{code} + +\begin{code} +getVirtAndRealHp :: FCode (VirtualHeapOffset, VirtualHeapOffset) +getVirtAndRealHp info_down state@(MkCgState _ _ (au, bu, (virtHp, realHp))) + = ((virtHp, realHp), state) +\end{code} + +\begin{code} +setRealHp :: VirtualHeapOffset -> Code +setRealHp realHp info_down (MkCgState absC binds (au, bu, (vHp, _))) + = MkCgState absC binds (au, bu, (vHp, realHp)) +\end{code} + +\begin{code} +getHpRelOffset :: VirtualHeapOffset -> FCode RegRelative +getHpRelOffset virtual_offset info_down state@(MkCgState _ _ (_,_,(_,realHp))) + = (HpRel realHp virtual_offset, state) +\end{code} + +The heap high water mark is the larger of virtHp and hwHp. The latter is +only records the high water marks of forked-off branches, so to find the +heap high water mark you have to take the max of virtHp and hwHp. Remember, +virtHp never retreats! + +\begin{code} +heapHWM (virtHp, realHp) = virtHp +\end{code} + +%************************************************************************ +%* * +\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage} +%* * +%************************************************************************ + +@setRealAndVirtualSps@ sets into the environment the offsets of the +current position of the real and virtual stack pointers in the current +stack frame. The high-water mark is set too. It generates no code. +It is used to initialise things at the beginning of a closure body. + +\begin{code} +setRealAndVirtualSps :: VirtualSpAOffset -- New real SpA + -> VirtualSpBOffset -- Ditto B stack + -> Code + +setRealAndVirtualSps spA spB info_down (MkCgState absC binds + ((vspA,fA,realSpA,hwspA), + (vspB,fB,realSpB,hwspB), + h_usage)) + = MkCgState absC binds new_usage + where + new_usage = ((spA, fA, spA, spA), + (spB, fB, spB, spB), + h_usage) +\end{code} + +\begin{code} +getVirtSps :: FCode (VirtualSpAOffset,VirtualSpBOffset) +getVirtSps info_down state@(MkCgState absC binds ((virtSpA,_,_,_), (virtSpB,_,_,_), _)) + = ((virtSpA,virtSpB), state) +\end{code} + +\begin{code} +getSpARelOffset :: VirtualSpAOffset -> FCode RegRelative +getSpARelOffset virtual_offset info_down state@(MkCgState _ _ ((_,_,realSpA,_),_,_)) + = (SpARel realSpA virtual_offset, state) + +getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative +getSpBRelOffset virtual_offset info_down state@(MkCgState _ _ (_,(_,_,realSpB,_),_)) + = (SpBRel realSpB virtual_offset, state) +\end{code} + + +\begin{code} +{- UNUSED: +getVirtSpRelOffsets :: FCode (RegRelative, RegRelative) +getVirtSpRelOffsets info_down + state@(MkCgState absC binds ((virtSpA,_,realSpA,_), (virtSpB,_,realSpB,_), _)) + = ((SpARel realSpA virtSpA, SpBRel realSpB virtSpB), state) +-} +\end{code} + +\begin{code} +freeBStkSlot :: VirtualSpBOffset -> Code +freeBStkSlot b_slot info_down + state@(MkCgState absC binds (spa_usage, (virtSpB,free_b,realSpB,hwSpB), heap_usage)) + = MkCgState absC binds (spa_usage, (virtSpB,new_free_b,realSpB,hwSpB), heap_usage) + where + new_free_b = addFreeBSlots free_b [b_slot] + +\end{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.hi b/ghc/compiler/codeGen/ClosureInfo.hi new file mode 100644 index 0000000..8914c9f --- /dev/null +++ b/ghc/compiler/codeGen/ClosureInfo.hi @@ -0,0 +1,169 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ClosureInfo where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel, mkClosureLabel) +import CgBindery(CgIdInfo, StableLoc, VolatileLoc) +import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, FCode(..), StubFlag) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(DataCon(..), Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind, getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, ltSMRepHdr) +import StgSyn(PlainStgAtom(..), PlainStgExpr(..), PlainStgLiveVars(..), StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag(..)) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniTyFuns(getUniDataSpecTyCon_maybe) +import UniType(UniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data CLabel +data CgIdInfo {-# GHC_PRAGMA MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo #-} +data CgInfoDownwards {-# GHC_PRAGMA MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo #-} +data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-} +data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-} +data CompilationInfo {-# GHC_PRAGMA MkCompInfo (GlobalSwitch -> Bool) _PackedString #-} +data EntryConvention = ViaNode | StdEntry CLabel (Labda CLabel) | DirectEntry CLabel Int [MagicId] +type FCode a = CgInfoDownwards -> CgState -> (a, CgState) +data HeapOffset +type DataCon = Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +type PlainStgAtom = StgAtom Id +type PlainStgExpr = StgExpr Id Id +type PlainStgLiveVars = UniqFM Id +data StandardFormInfo {-# GHC_PRAGMA NonStandardThunk | SelectorThunk Id Id Int | VapThunk Id [StgAtom Id] Bool #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +data UpdateFlag = ReEntrant | Updatable | SingleEntry +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +allocProfilingMsg :: ClosureInfo -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +blackHoleClosureInfo :: ClosureInfo -> ClosureInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +blackHoleOnEntry :: Bool -> ClosureInfo -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LU(ALS)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureGoodStuffSize :: ClosureInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureHdrSize :: ClosureInfo -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ HeapOffs totHdrSize _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> _APP_ _ORIG_ HeapOffs totHdrSize [ u3 ]; _NO_DEFLT_ } _N_ #-} +closureId :: ClosureInfo -> Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(LLLL)AA)" {_A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: UniType) (u2 :: IdInfo) (u3 :: IdDetails) -> _!_ _ORIG_ Id Id [] [u0, u1, u2, u3] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> u1; _NO_DEFLT_ } _N_ #-} +closureKind :: ClosureInfo -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureLFInfo :: ClosureInfo -> LambdaFormInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: LambdaFormInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> u2; _NO_DEFLT_ } _N_ #-} +closureLabelFromCI :: ClosureInfo -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ CLabelInfo mkClosureLabel _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> _APP_ _ORIG_ CLabelInfo mkClosureLabel [ u1 ]; _NO_DEFLT_ } _N_ #-} +closureNonHdrSize :: ClosureInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closurePtrsSize :: ClosureInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureReturnsUnboxedType :: ClosureInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSA)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureSMRep :: ClosureInfo -> SMRep + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SMRep) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> u3; _NO_DEFLT_ } _N_ #-} +closureSemiTag :: ClosureInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureSingleEntry :: ClosureInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureSize :: ClosureInfo -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureType :: ClosureInfo -> Labda (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSA)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureTypeDescr :: ClosureInfo -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(ALAS)AA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +closureUpdReqd :: ClosureInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: LambdaFormInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo LFThunk (u1 :: Bool) (u2 :: Bool) (u3 :: Bool) (u4 :: StandardFormInfo) -> u3; _ORIG_ ClosureInfo LFBlackHole -> _!_ True [] []; (u5 :: LambdaFormInfo) -> _!_ False [] [] } _N_} _N_ _N_ #-} +dataConLiveness :: ClosureInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +entryLabelFromCI :: ClosureInfo -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSL)" {_A_ 3 _U_ 211 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fastLabelFromCI :: ClosureInfo -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fitsMinUpdSize :: ClosureInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +funInfoTableRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LSL" _N_ _N_ #-} +getEntryConvention :: Id -> LambdaFormInfo -> [PrimKind] -> CgInfoDownwards -> CgState -> (EntryConvention, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkClosureLabel :: Id -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +getSMInfoStr :: SMRep -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getSMInitHdrStr :: SMRep -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getSMUpdInplaceHdrStr :: SMRep -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getStandardFormThunkInfo :: LambdaFormInfo -> Labda [StgAtom Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getUniDataSpecTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +infoTableLabelFromCI :: ClosureInfo -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSL)" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isConstantRep :: SMRep -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isPhantomRep :: SMRep -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: SMRep) -> case u0 of { _ALG_ _ORIG_ SMRep PhantomRep -> _!_ True [] []; (u1 :: SMRep) -> _!_ False [] [] } _N_ #-} +isSpecRep :: SMRep -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: SMRep) -> case u0 of { _ALG_ _ORIG_ SMRep SpecialisedRep (u1 :: SMSpecRepKind) (u2 :: Int) (u3 :: Int) (u4 :: SMUpdateKind) -> _!_ True [] []; (u5 :: SMRep) -> _!_ False [] [] } _N_ #-} +isStaticClosure :: ClosureInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: SMRep) -> case u0 of { _ALG_ _ORIG_ SMRep StaticRep (u1 :: Int) (u2 :: Int) -> _!_ True [] []; (u3 :: SMRep) -> _!_ False [] [] } _N_} _N_ _N_ #-} +layOutDynClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)]) + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +layOutDynCon :: Id -> (a -> PrimKind) -> [a] -> (ClosureInfo, [(a, HeapOffset)]) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +layOutStaticClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)]) + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +ltSMRepHdr :: SMRep -> SMRep -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +maybeSelectorInfo :: ClosureInfo -> Labda (Id, Int) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkClosureLFInfo :: Bool -> [Id] -> UpdateFlag -> [Id] -> StgExpr Id Id -> LambdaFormInfo + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _S_ "LLLSL" _N_ _N_ #-} +mkConLFInfo :: Id -> LambdaFormInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkLFArgument :: LambdaFormInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ ClosureInfo LFArgument [] [] _N_ #-} +mkLFImported :: Id -> LambdaFormInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(SAAAAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkLFLetNoEscape :: Int -> UniqFM Id -> LambdaFormInfo + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: UniqFM Id) -> _!_ _ORIG_ ClosureInfo LFLetNoEscape [] [u0, u1] _N_ #-} +mkVirtHeapOffsets :: SMRep -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, HeapOffset)]) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +noUpdVapRequired :: StgBinderInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: StgBinderInfo) -> case u0 of { _ALG_ _ORIG_ StgSyn NoStgBinderInfo -> _!_ False [] []; _ORIG_ StgSyn StgBinderInfo (u1 :: Bool) (u2 :: Bool) (u3 :: Bool) (u4 :: Bool) (u5 :: Bool) -> u4; _NO_DEFLT_ } _N_ #-} +nodeMustPointToIt :: LambdaFormInfo -> CgInfoDownwards -> CgState -> (Bool, CgState) + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +slopSize :: ClosureInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +slowFunEntryCodeRequired :: Id -> StgBinderInfo -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +staticClosureRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LSL" _N_ _N_ #-} +stdVapRequired :: StgBinderInfo -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: StgBinderInfo) -> case u0 of { _ALG_ _ORIG_ StgSyn NoStgBinderInfo -> _!_ False [] []; _ORIG_ StgSyn StgBinderInfo (u1 :: Bool) (u2 :: Bool) (u3 :: Bool) (u4 :: Bool) (u5 :: Bool) -> u3; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs new file mode 100644 index 0000000..d705356 --- /dev/null +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -0,0 +1,1328 @@ + +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[ClosureInfo]{Data structures which describe closures} + +Much of the rationale for these things is in the ``details'' part of +the STG paper. + +\begin{code} +#include "HsVersions.h" + +module ClosureInfo ( + ClosureInfo, LambdaFormInfo, SMRep, -- all abstract + StandardFormInfo, + + EntryConvention(..), + + mkClosureLFInfo, mkConLFInfo, + mkLFImported, mkLFArgument, mkLFLetNoEscape, + + closureSize, closureHdrSize, + closureNonHdrSize, closureSizeWithoutFixedHdr, + closureGoodStuffSize, closurePtrsSize, -- UNUSED: closureNonPtrsSize, + slopSize, fitsMinUpdSize, + + layOutDynClosure, layOutDynCon, layOutStaticClosure, + layOutStaticNoFVClosure, layOutPhantomClosure, + mkVirtHeapOffsets, -- for GHCI + + nodeMustPointToIt, getEntryConvention, + blackHoleOnEntry, + + staticClosureRequired, + slowFunEntryCodeRequired, funInfoTableRequired, + stdVapRequired, noUpdVapRequired, + + closureId, infoTableLabelFromCI, + closureLabelFromCI, + entryLabelFromCI, fastLabelFromCI, + closureLFInfo, closureSMRep, closureUpdReqd, + closureSingleEntry, closureSemiTag, closureType, + closureReturnsUnboxedType, getStandardFormThunkInfo, + +--OLD auxInfoTableLabelFromCI, isIntLikeRep, -- go away in 0.23 + + closureKind, closureTypeDescr, -- profiling + + isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps? + isStaticClosure, allocProfilingMsg, + blackHoleClosureInfo, + getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, + ltSMRepHdr, --UNUSED: equivSMRepHdr, + maybeSelectorInfo, + + dataConLiveness, -- concurrency + + -- and to make the interface self-sufficient... + AbstractC, CAddrMode, HeapOffset, MagicId, + CgInfoDownwards, CgState, CgIdInfo, CompilationInfo, + CLabel, Id, Maybe, PrimKind, FCode(..), TyCon, StgExpr, + StgAtom, StgBinderInfo, + DataCon(..), PlainStgExpr(..), PlainStgLiveVars(..), + PlainStgAtom(..), + UniqSet(..), UniqFM, UpdateFlag(..) -- not abstract + + IF_ATTACK_PRAGMAS(COMMA mkClosureLabel) + IF_ATTACK_PRAGMAS(COMMA getUniDataSpecTyCon_maybe) + ) where + +import AbsCSyn +import CgMonad +import SMRep +import StgSyn + +import AbsUniType +import CgCompInfo -- some magic constants +import CgRetConv +import CLabelInfo -- Lots of label-making things +import CmdLineOpts ( GlobalSwitch(..) ) +import Id +import IdInfo -- SIGH +import Maybes ( maybeToBool, assocMaybe, Maybe(..) ) +import Outputable -- needed for INCLUDE_FRC_METHOD +import Pretty -- ( ppStr, Pretty(..) ) +import PrimKind ( PrimKind, getKindSize, separateByPtrFollowness ) +import Util +\end{code} + +The ``wrapper'' data type for closure information: + +\begin{code} +data ClosureInfo + = MkClosureInfo + Id -- The thing bound to this closure + LambdaFormInfo -- info derivable from the *source* + SMRep -- representation used by storage manager +\end{code} + +%************************************************************************ +%* * +\subsection[ClosureInfo-OLD-DOC]{OLD DOCUMENTATION PROBABLY SUPERCEDED BY stg-details} +%* * +%************************************************************************ + +We can optimise the function-entry code as follows. +\begin{itemize} + +\item If the ``function'' is not updatable, we can jump directly to its + entry code, rather than indirecting via the info pointer in the + closure. (For updatable thunks we must go via the closure, in + case it has been updated.) + +\item If the former bullet applies, and the application we are + compiling gives the function as many arguments as it needs, we + can jump to its fast-entry code. (This only applies if the + function has one or more args, because zero-arg closures have + no fast-entry code.) + +\item If the function is a top-level non-constructor or imported, there + is no need to make Node point to its closure. In order for + this to be right, we need to ensure that: + \begin{itemize} + \item If such closures are updatable then they push their + static address in the update frame, not Node. Actually + we create a black hole and push its address. + + \item The arg satisfaction check should load Node before jumping to + UpdatePAP. + + \item Top-level constructor closures need careful handling. If we are to + jump direct to the constructor code, we must load Node first, even + though they are top-level. But if we go to their ``own'' + standard-entry code (which loads Node and then jumps to the + constructor code) we don't need to load Node. + \end{itemize} +\end{itemize} + + +{\em Top level constructors (@mkStaticConEntryInfo@)} + +\begin{verbatim} + x = {y,ys} \ {} Cons {y,ys} -- Std form constructor +\end{verbatim} + +x-closure: Cons-info-table, y-closure, ys-closure + +x-entry: Node = x-closure; jump( Cons-entry ) + +x's EntryInfo in its own module: +\begin{verbatim} + Base-label = Cons -- Not x!! + NodeMustPoint = True + ClosureClass = Constructor +\end{verbatim} + + So if x is entered, Node will be set up and + we'll jump direct to the Cons code. + +x's EntryInfo in another module: (which may not know that x is a constructor) +\begin{verbatim} + Base-label = x -- Is x!! + NodeMustPoint = False -- All imported things have False + ClosureClass = non-committal +\end{verbatim} + + If x is entered, we'll jump to x-entry, which will set up Node + before jumping to the standard Cons code + +{\em Top level non-constructors (@mkStaticEntryInfo@)} +\begin{verbatim} + x = ... +\end{verbatim} + +For updatable thunks, x-entry must push an allocated BH in update frame, not Node. + +For non-zero arity, arg satis check must load Node before jumping to + UpdatePAP. + +x's EntryInfo in its own module: +\begin{verbatim} + Base-label = x + NodeMustPoint = False + ClosureClass = whatever +\end{verbatim} + +{\em Inner constructors (@mkConEntryInfo@)} + +\begin{verbatim} + Base-label = Cons -- Not x!! + NodeMustPoint = True -- If its arity were zero, it would + -- have been lifted to top level + ClosureClass = Constructor +\end{verbatim} + +{\em Inner non-constructors (@mkEntryInfo@)} + +\begin{verbatim} + Base-label = x + NodeMustPoint = True -- If no free vars, would have been + -- lifted to top level + ClosureClass = whatever +\end{verbatim} + +{\em Imported} + +\begin{verbatim} + Nothing, + or + Base-label = x + NodeMustPoint = False + ClosureClass = whatever +\end{verbatim} + +============== +THINK: we could omit making Node point to top-level constructors +of arity zero; but that might interact nastily with updates. +============== + + +========== +The info we need to import for imported things is: + +\begin{verbatim} + data ImportInfo = UnknownImportInfo + | HnfImport Int -- Not updatable, arity given + -- Arity can be zero, for (eg) constrs + | UpdatableImport -- Must enter via the closure +\end{verbatim} + +ToDo: move this stuff??? + +\begin{pseudocode} +mkStaticEntryInfo lbl cl_class + = MkEntryInfo lbl False cl_class + +mkStaticConEntryInfo lbl + = MkEntryInfo lbl True ConstructorClosure + +mkEntryInfo lbl cl_class + = MkEntryInfo lbl True cl_class + +mkConEntryInfo lbl + = MkEntryInfo lbl True ConstructorClosure +\end{pseudocode} + +%************************************************************************ +%* * +\subsection[ClosureInfo-datatypes]{Data types for closure information} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info} +%* * +%************************************************************************ + +\begin{code} +data LambdaFormInfo + = LFReEntrant -- Reentrant closure; used for PAPs too + Bool -- True if top level + Int -- Arity + Bool -- True <=> no fvs + + | LFCon -- Constructor + DataCon -- The constructor (may be specialised) + Bool -- True <=> zero arity + + | LFTuple -- Tuples + DataCon -- The tuple constructor (may be specialised) + Bool -- True <=> zero arity + + | LFThunk -- Thunk (zero arity) + Bool -- True <=> top level + Bool -- True <=> no free vars + Bool -- True <=> updatable (i.e., *not* single-entry) + StandardFormInfo + + | LFArgument -- Used for function arguments. We know nothing about + -- this closure. Treat like updatable "LFThunk"... + + | LFImported -- Used for imported things. We know nothing about this + -- closure. Treat like updatable "LFThunk"... + -- Imported things which we do know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + + | LFLetNoEscape -- See LetNoEscape module for precise description of + -- these "lets". + Int -- arity; + PlainStgLiveVars-- list of variables live in the RHS of the let. + -- (ToDo: maybe not used) + + | LFBlackHole -- Used for the closures allocated to hold the result + -- of a CAF. We want the target of the update frame to + -- be in the heap, so we make a black hole to hold it. + + -- This last one is really only for completeness; + -- it isn't actually used for anything interesting + | LFIndirection + +data StandardFormInfo -- Tells whether this thunk has one of a small number + -- of standard forms + + = NonStandardThunk -- No, it isn't + + | SelectorThunk + Id -- Scrutinee + DataCon -- Constructor + Int -- 0-origin offset of ak within the "goods" of constructor + -- (Recall that the a1,...,an may be laid out in the heap + -- in a non-obvious order.) + +{- A SelectorThunk is of form + + case x of + con a1,..,an -> ak + + and the constructor is from a single-constr type. + If we can't convert the heap-offset of the selectee into an Int, e.g., + it's "GEN_VHS+i", we just give up. +-} + + | VapThunk + Id -- Function + [PlainStgAtom] -- Args + Bool -- True <=> the function is not top-level, so + -- must be stored in the thunk too + +{- A VapThunk is of form + + f a1 ... an + + where f is a known function, with arity n + So for this thunk we can use the label for f's heap-entry + info table (generated when f's defn was dealt with), + rather than generating a one-off info table and entry code + for this one thunk. +-} + + +mkLFArgument = LFArgument +mkLFBlackHole = LFBlackHole +mkLFLetNoEscape = LFLetNoEscape + +mkLFImported :: Id -> LambdaFormInfo +mkLFImported id + = case arityMaybe (getIdArity id) of + Nothing -> LFImported + Just 0 -> LFThunk True{-top-lev-} True{-no fvs-} + True{-updatable-} NonStandardThunk + Just n -> LFReEntrant True n True -- n > 0 +\end{code} + +%************************************************************************ +%* * +\subsection[ClosureInfo-construction]{Functions which build LFInfos} +%* * +%************************************************************************ + +@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure. + +\begin{code} +mkClosureLFInfo :: Bool -- True of top level + -> [Id] -- Free vars + -> UpdateFlag -- Update flag + -> [Id] -- Args + -> PlainStgExpr -- Body of closure: passed so we + -- can look for selector thunks! + -> LambdaFormInfo + +mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args + = LFReEntrant top (length args) (null fvs) + +mkClosureLFInfo top fvs ReEntrant [] body + = LFReEntrant top 0 (null fvs) +\end{code} + +OK, this is where we look at the body of the closure to see if it's a +selector---turgid, but nothing deep. We are looking for a closure of +{\em exactly} the form: +\begin{verbatim} +... = [the_fv] \ u [] -> + case the_fv of + con a_1 ... a_n -> a_i +\end{verbatim} +Here we go: +\begin{code} +mkClosureLFInfo False -- don't bother if at top-level + [the_fv] -- just one... + Updatable + [] -- no args (a thunk) + (StgCase (StgApp (StgVarAtom scrutinee) [{-no args-}] _) + _ _ _ -- ignore live vars and uniq... + (StgAlgAlts case_ty + [(con, params, use_mask, + (StgApp (StgVarAtom selectee) [{-no args-}] _))] + StgNoDefault)) + | the_fv == scrutinee -- Scrutinee is the only free variable + && maybeToBool maybe_offset -- Selectee is a component of the tuple + && maybeToBool offset_into_int_maybe + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + = + ASSERT(is_single_constructor) -- This should be true anyway + LFThunk False False True (SelectorThunk scrutinee con offset_into_int) + where + (_, params_w_offsets) = layOutDynCon con getIdKind 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 +\end{code} + +Same kind of thing, looking for vector-apply thunks, of the form: + + x = [...] \ .. [] -> f a1 .. an + +where f has arity n. We rely on the arity info inside the Id being correct. + +\begin{code} +mkClosureLFInfo top_level + fvs + upd_flag + [] -- No args; a thunk + (StgApp (StgVarAtom fun_id) args _) + | not top_level -- A top-level thunk would require a static + -- vap_info table, which we don't generate just + -- now; so top-level thunks are never standard + -- form. + && isLocallyDefined fun_id -- Must be defined in this module + && maybeToBool arity_maybe -- A known function with known arity + && fun_arity > 0 -- It'd better be a function! + && fun_arity == length args -- Saturated application + = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap) + where + arity_maybe = arityMaybe (getIdArity fun_id) + Just fun_arity = arity_maybe + + -- If the function is a free variable then it must be stored + -- in the thunk too; if it isn't a free variable it must be + -- because it's constant, so it doesn't need to be stored in the thunk + store_fun_in_vap = fun_id `is_elem` fvs + + is_elem = isIn "mkClosureLFInfo" +\end{code} + +Finally, the general updatable-thing case: +\begin{code} +mkClosureLFInfo top fvs upd_flag [] body + = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk + +isUpdatable ReEntrant = False +isUpdatable SingleEntry = False +isUpdatable Updatable = True +\end{code} + +@mkConLFInfo@ is similar, for constructors. + +\begin{code} +mkConLFInfo :: DataCon -> LambdaFormInfo + +mkConLFInfo con + = ASSERT(isDataCon con) + let + arity = getDataConArity con + in + if isTupleCon con then + LFTuple con (arity == 0) + else + LFCon con (arity == 0) +\end{code} + + +%************************************************************************ +%* * +\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} +%* * +%************************************************************************ + +\begin{code} +closureSize :: ClosureInfo -> HeapOffset +closureSize cl_info@(MkClosureInfo _ _ sm_rep) + = totHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info)) + +closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset +closureSizeWithoutFixedHdr cl_info@(MkClosureInfo _ _ sm_rep) + = varHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info)) + +closureHdrSize :: ClosureInfo -> HeapOffset +closureHdrSize (MkClosureInfo _ _ sm_rep) + = totHdrSize sm_rep + +closureNonHdrSize :: ClosureInfo -> Int +closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep) + = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) --ToDo: pass lf_info? + where + tot_wds = closureGoodStuffSize cl_info + +closureGoodStuffSize :: ClosureInfo -> Int +closureGoodStuffSize (MkClosureInfo _ _ sm_rep) + = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep + in ptrs + nonptrs + +closurePtrsSize :: ClosureInfo -> Int +closurePtrsSize (MkClosureInfo _ _ sm_rep) + = let (ptrs, _) = sizes_from_SMRep sm_rep + in ptrs + +-- not exported: +sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _) = (ptrs, nonptrs) +sizes_from_SMRep (GenericRep ptrs nonptrs _) = (ptrs, nonptrs) +sizes_from_SMRep (BigTupleRep ptrs) = (ptrs, 0) +sizes_from_SMRep (MuTupleRep ptrs) = (ptrs, 0) +sizes_from_SMRep (DataRep nonptrs) = (0, nonptrs) +sizes_from_SMRep BlackHoleRep = (0, 0) +sizes_from_SMRep (StaticRep ptrs nonptrs) = (ptrs, nonptrs) +#ifdef DEBUG +sizes_from_SMRep PhantomRep = panic "sizes_from_SMRep: PhantomRep" +sizes_from_SMRep DynamicRep = panic "sizes_from_SMRep: DynamicRep" +#endif +\end{code} + +\begin{code} +fitsMinUpdSize :: ClosureInfo -> Bool +fitsMinUpdSize (MkClosureInfo _ _ BlackHoleRep) = True +fitsMinUpdSize cl_info = isSpecRep (closureSMRep cl_info) && closureNonHdrSize cl_info <= mIN_UPD_SIZE +\end{code} + +Computing slop size. WARNING: this looks dodgy --- it has deep +knowledge of what the storage manager does with the various +representations... + +Slop Requirements: +\begin{itemize} +\item +Updateable closures must be @mIN_UPD_SIZE@. + \begin{itemize} + \item + Cons cell requires 2 words + \item + Indirections require 1 word + \item + Appels collector indirections 2 words + \end{itemize} +THEREFORE: @mIN_UPD_SIZE = 2@. + +\item +Collectable closures which are allocated in the heap +must be @mIN_SIZE_NonUpdHeapObject@. + +Copying collector forward pointer requires 1 word + +THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@ + +\item +@SpecialisedRep@ closures closures may require slop: + \begin{itemize} + \item + @ConstantRep@ and @CharLikeRep@ closures always use the address of + a static closure. They are never allocated or + collected (eg hold forwarding pointer) hence never any slop. + + \item + @IntLikeRep@ are never updatable. + May need slop to be collected (as they will be size 1 or more + this probably has no affect) + + \item + @SpecRep@ may be updateable and will be collectable + + \item + @StaticRep@ may require slop if updatable. Non-updatable ones are OK. + + \item + @GenericRep@ closures will always be larger so never require slop. + \end{itemize} + + ***** ToDo: keep an eye on this! +\end{itemize} + +\begin{code} +slopSize cl_info@(MkClosureInfo _ lf_info sm_rep) + = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info) + +computeSlopSize :: Int -> SMRep -> Bool -> Int + +computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _ + = 0 +computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _ + = 0 + +computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True -- Updatable + = max 0 (mIN_UPD_SIZE - tot_wds) +computeSlopSize tot_wds (StaticRep _ _) True -- Updatable + = max 0 (mIN_UPD_SIZE - tot_wds) +computeSlopSize tot_wds BlackHoleRep _ -- Updatable + = max 0 (mIN_UPD_SIZE - tot_wds) + +computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False -- Not updatable + = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) + +computeSlopSize tot_wds other_rep _ -- Any other rep + = 0 +\end{code} + +%************************************************************************ +%* * +\subsection[layOutDynClosure]{Lay out a dynamic closure} +%* * +%************************************************************************ + +\begin{code} +layOutDynClosure, layOutStaticClosure + :: Id -- STG identifier w/ which this closure assoc'd + -> (a -> PrimKind) -- function w/ which to be able to get a PrimKind + -> [a] -- the "things" being layed out + -> LambdaFormInfo -- what sort of closure it is + -> (ClosureInfo, -- info about the closure + [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them + +layOutDynClosure name kind_fn things lf_info + = (MkClosureInfo name lf_info sm_rep, + things_w_offsets) + where + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things + sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds + +layOutStaticClosure name kind_fn things lf_info + = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)), + things_w_offsets) + where + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds + things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot) kind_fn things + bot = panic "layoutStaticClosure" + +layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo +layOutStaticNoFVClosure name lf_info + = MkClosureInfo name lf_info (StaticRep ptr_wds nonptr_wds) + where + -- I am very uncertain that this is right - it will show up when testing + -- my dynamic loading code. ADR + -- (If it's not right, we'll have to grab the kinds of the arguments from + -- somewhere.) + ptr_wds = 0 + nonptr_wds = 0 + +layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo +layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep +\end{code} + +A wrapper for when used with data constructors: +\begin{code} +layOutDynCon :: DataCon + -> (a -> PrimKind) + -> [a] + -> (ClosureInfo, [(a,VirtualHeapOffset)]) + +layOutDynCon con kind_fn args + = ASSERT(isDataCon con) + layOutDynClosure con kind_fn args (mkConLFInfo con) +\end{code} + + +%************************************************************************ +%* * +\subsection[SMreps]{Choosing SM reps} +%* * +%************************************************************************ + +\begin{code} +chooseDynSMRep + :: LambdaFormInfo + -> Int -> Int -- Tot wds, ptr wds + -> SMRep + +chooseDynSMRep lf_info tot_wds ptr_wds + = let + nonptr_wds = tot_wds - ptr_wds + + updatekind = case lf_info of + LFThunk _ _ upd _ -> if upd then SMUpdatable else SMSingleEntry + LFBlackHole -> SMUpdatable + _ -> SMNormalForm + in + if (nonptr_wds == 0 && ptr_wds <= mAX_SPEC_ALL_PTRS) + || (tot_wds <= mAX_SPEC_MIXED_FIELDS) + || (ptr_wds == 0 && nonptr_wds <= mAX_SPEC_ALL_NONPTRS) then + let + spec_kind = case lf_info of + + (LFTuple _ True) -> ConstantRep + + (LFTuple _ _) -> SpecRep + + (LFCon _ True) -> ConstantRep + + (LFCon con _ ) -> if maybeToBool (maybeCharLikeTyCon tycon) then CharLikeRep + else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep + else SpecRep + where + tycon = getDataConTyCon con + + _ -> SpecRep + in + SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind + else + GenericRep ptr_wds nonptr_wds updatekind +\end{code} + + +%************************************************************************ +%* * +\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure} +%* * +%************************************************************************ + +@mkVirtHeapOffsets@ (the heap version) always returns boxed things with +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 + -> (a -> PrimKind) -- 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 + +-- First in list gets lowest offset, which is initial offset + 1. + +mkVirtHeapOffsets sm_rep kind_fun things + = let (ptrs, non_ptrs) = separateByPtrFollowness kind_fun things + (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs + (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs + in + (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) + where + offset_of_first_word = totHdrSize sm_rep + computeOffset wds_so_far thing + = (wds_so_far + (getKindSize . kind_fun) thing, + (thing, (offset_of_first_word `addOff` (intOff wds_so_far))) + ) +\end{code} + +%************************************************************************ +%* * +\subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@} +%* * +%************************************************************************ + +Be sure to see the stg-details notes about these... + +\begin{code} +nodeMustPointToIt :: LambdaFormInfo -> FCode Bool +nodeMustPointToIt lf_info + = isSwitchSetC SccProfilingOn `thenFC` \ do_profiling -> + + case lf_info of + LFReEntrant top arity no_fvs -> returnFC ( + not no_fvs || -- Certainly if it has fvs we need to point to it + + not top -- If it is not top level we will point to it + -- We can have a \r closure with no_fvs which + -- is not top level as special case cgRhsClosure + -- has been dissabled in favour of let floating + +--OLD: || (arity == 0 && do_profiling) +-- -- Access to cost centre required for 0 arity if profiling +-- -- Simon: WHY? (94/12) + + -- For lex_profiling we also access the cost centre for a + -- non-inherited function i.e. not top level + -- the not top case above ensures this is ok. + ) + + LFCon _ zero_arity -> returnFC True + LFTuple _ zero_arity -> returnFC True + + -- Strictly speaking, the above two don't need Node to point + -- to it if the arity = 0. But this is a *really* unlikely + -- situation. If we know it's nil (say) and we are entering + -- it. Eg: let x = [] in x then we will certainly have inlined + -- x, since nil is a simple atom. So we gain little by not + -- having Node point to known zero-arity things. On the other + -- hand, we do lose something; Patrick's code for figuring out + -- when something has been updated but not entered relies on + -- having Node point to the result of an update. SLPJ + -- 27/11/92. + + LFThunk _ no_fvs updatable _ + -> returnFC (updatable || not no_fvs || do_profiling) + + -- For the non-updatable (single-entry case): + -- + -- True if has fvs (in which case we need access to them, and we + -- should black-hole it) + -- or profiling (in which case we need to recover the cost centre + -- from inside it) + + LFArgument -> returnFC True + LFImported -> returnFC True + LFBlackHole -> returnFC True + -- BH entry may require Node to point + + LFLetNoEscape _ _ -> returnFC False +\end{code} + +The entry conventions depend on the type of closure being entered, +whether or not it has free variables, and whether we're running +sequentially or in parallel. + +\begin{tabular}{lllll} +Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\ +Unknown & no & yes & stack & node \\ +Known fun ($\ge$ 1 arg), no fvs & no & no & registers & fast entry (enough args) \\ +\ & \ & \ & \ & slow entry (otherwise) \\ +Known fun ($\ge$ 1 arg), fvs & no & yes & registers & fast entry (enough args) \\ +0 arg, no fvs @\r,\s@ & no & no & n/a & direct entry \\ +0 arg, no fvs @\u@ & no & yes & n/a & node \\ +0 arg, fvs @\r,\s@ & no & yes & n/a & direct entry \\ +0 arg, fvs @\u@ & no & yes & n/a & node \\ + +Unknown & yes & yes & stack & node \\ +Known fun ($\ge$ 1 arg), no fvs & yes & no & registers & fast entry (enough args) \\ +\ & \ & \ & \ & slow entry (otherwise) \\ +Known fun ($\ge$ 1 arg), fvs & yes & yes & registers & node \\ +0 arg, no fvs @\r,\s@ & yes & no & n/a & direct entry \\ +0 arg, no fvs @\u@ & yes & yes & n/a & node \\ +0 arg, fvs @\r,\s@ & yes & yes & n/a & node \\ +0 arg, fvs @\u@ & yes & yes & n/a & node\\ +\end{tabular} + +When black-holing, single-entry closures could also be entered via node +(rather than directly) to catch double-entry. + +\begin{code} +data EntryConvention + = ViaNode -- The "normal" convention + + | StdEntry CLabel -- Jump to this code, with args on stack + (Maybe CLabel) -- possibly setting infoptr to this + + | DirectEntry -- Jump directly to code, with args in regs + CLabel -- The code label + Int -- Its arity + [MagicId] -- Its register assignments (possibly empty) + +getEntryConvention :: Id -- Function being applied + -> LambdaFormInfo -- Its info + -> [PrimKind] -- Available arguments + -> FCode EntryConvention + +getEntryConvention id lf_info arg_kinds + = nodeMustPointToIt lf_info `thenFC` \ node_points -> + isSwitchSetC ForConcurrent `thenFC` \ is_concurrent -> + returnFC ( + + if (node_points && is_concurrent) then ViaNode else + + case lf_info of + + LFReEntrant _ arity _ -> + if arity == 0 || (length arg_kinds) < arity then + StdEntry (mkStdEntryLabel id) Nothing + else + DirectEntry (mkFastEntryLabel id arity) arity arg_regs + where + (arg_regs, _) = assignRegs live_regs (take arity arg_kinds) + live_regs = if node_points then [node] else [] + + LFCon con zero_arity + -> let itbl = if zero_arity then + mkPhantomInfoTableLabel con + else + mkInfoTableLabel con + in StdEntry (mkStdEntryLabel con) (Just itbl) + -- Should have no args + LFTuple tup zero_arity + -> StdEntry (mkStdEntryLabel tup) + (Just (mkInfoTableLabel tup)) + -- Should have no args + + LFThunk _ _ updatable std_form_info + -> if updatable + then ViaNode + else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing + + LFArgument -> ViaNode + LFImported -> ViaNode + LFBlackHole -> ViaNode -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we enter via Node + + LFLetNoEscape arity _ + -> ASSERT(arity == length arg_kinds) + DirectEntry (mkFastEntryLabel id arity) arity arg_regs + where + (arg_regs, _) = assignRegs live_regs arg_kinds + live_regs = if node_points then [node] else [] + ) + +blackHoleOnEntry :: Bool -- No-black-holing flag + -> ClosureInfo + -> Bool + +-- Static closures are never themselves black-holed. +-- Updatable ones will be overwritten with a CAFList cell, which points to a black hole; +-- Single-entry ones have no fvs to plug, and we trust they don't form part of a loop. + +blackHoleOnEntry no_black_holing (MkClosureInfo _ _ (StaticRep _ _)) = False + +blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _) + = case lf_info of + LFReEntrant _ _ _ -> False + LFThunk _ no_fvs updatable _ + -> if updatable + then not no_black_holing + else not no_fvs + other -> panic "blackHoleOnEntry" -- Should never happen + +getStandardFormThunkInfo + :: LambdaFormInfo + -> Maybe [PlainStgAtom] -- Nothing => not a standard-form thunk + -- Just atoms => a standard-form thunk with payload atoms + +getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _)) + = --trace "Selector thunk: missed opportunity to save info table + code" + Nothing + -- Just [StgVarAtom scrutinee] + -- We can't save the info tbl + code until we have a way to generate + -- a fixed family thereof. + +getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload)) + | fun_in_payload = Just (StgVarAtom fun_id : args) + | otherwise = Just args + +getStandardFormThunkInfo other_lf_info = Nothing + +maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset) +maybeSelectorInfo _ = Nothing +\end{code} + +Avoiding generating entries and info tables +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At present, for every function we generate all of the following, +just in case. But they aren't always all needed, as noted below: + +[NB1: all of this applies only to *functions*. Thunks always +have closure, info table, and entry code.] + +[NB2: All are needed if the function is *exported*, just to play safe.] + + +* Fast-entry code ALWAYS NEEDED + +* Slow-entry code + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) we're in the parallel world and the function has free vars + [Reason: in parallel world, we always enter functions + with free vars via the closure.] + +* The function closure + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) if the function has free vars (ie not top level) + + Why case (a) here? Because if the arg-satis check fails, + UpdatePAP stuffs a pointer to the function closure in the PAP. + [Could be changed; UpdatePAP could stuff in a code ptr instead, + but doesn't seem worth it.] + + [NB: these conditions imply that we might need the closure + without the slow-entry code. Here's how. + + f x y = let g w = ...x..y..w... + in + ...(g t)... + + Here we need a closure for g which contains x and y, + but since the calls are all saturated we just jump to the + fast entry point for g, with R1 pointing to the closure for g.] + + +* Standard info table + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) the function has free vars (ie not top level) + + NB. In the sequential world, (c) is only required so that the function closure has + an info table to point to, to keep the storage manager happy. + If (c) alone is true we could fake up an info table by choosing + one of a standard family of info tables, whose entry code just + bombs out. + + [NB In the parallel world (c) is needed regardless because + we enter functions with free vars via the closure.] + + If (c) is retained, then we'll sometimes generate an info table + (for storage mgr purposes) without slow-entry code. Then we need + to use an error label in the info table to substitute for the absent + slow entry code. + +* Standard vap-entry code + Standard vap-entry info table + Needed iff we have any updatable thunks of the standard vap-entry shape. + +* Single-update vap-entry code + Single-update vap-entry info table + Needed iff we have any non-updatable thunks of the + standard vap-entry shape. + + +\begin{code} +staticClosureRequired + :: Id + -> StgBinderInfo + -> LambdaFormInfo + -> Bool +staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) + (LFReEntrant top_level _ _) -- It's a function + = ASSERT( top_level ) -- Assumption: it's a top-level, no-free-var binding + arg_occ -- There's an argument occurrence + || unsat_occ -- There's an unsaturated call + || externallyVisibleId binder + +staticClosureRequired binder other_binder_info other_lf_info = True + +slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk. + :: Id + -> StgBinderInfo + -> Bool +slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) + = arg_occ -- There's an argument occurrence + || unsat_occ -- There's an unsaturated call + || externallyVisibleId binder + {- HAS FREE VARS AND IS PARALLEL WORLD -} + +slowFunEntryCodeRequired binder NoStgBinderInfo = True + +funInfoTableRequired + :: Id + -> StgBinderInfo + -> LambdaFormInfo + -> Bool +funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) + (LFReEntrant top_level _ _) + = not top_level + || arg_occ -- There's an argument occurrence + || unsat_occ -- There's an unsaturated call + || externallyVisibleId binder + +funInfoTableRequired other_binder_info binder other_lf_info = True + +-- We need the vector-apply entry points for a function if +-- there's a vector-apply occurrence in this module + +stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool + +stdVapRequired binder_info + = case binder_info of + StgBinderInfo _ _ std_vap_occ _ _ -> std_vap_occ + _ -> False + +noUpdVapRequired binder_info + = case binder_info of + StgBinderInfo _ _ _ no_upd_vap_occ _ -> no_upd_vap_occ + _ -> False +\end{code} + +%************************************************************************ +%* * +\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.} +%* * +%************************************************************************ + +\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 + +closureId :: ClosureInfo -> Id +closureId (MkClosureInfo id _ _) = id + +closureSMRep :: ClosureInfo -> SMRep +closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep + +closureLFInfo :: ClosureInfo -> LambdaFormInfo +closureLFInfo (MkClosureInfo _ lf_info _) = lf_info + +closureUpdReqd :: ClosureInfo -> Bool + +closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd +closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True + -- Black-hole closures are allocated to receive the results of an + -- alg case with a named default... so they need to be updated. +closureUpdReqd other_closure = False + +closureSingleEntry :: ClosureInfo -> Bool + +closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd +closureSingleEntry other_closure = False +\end{code} + +Note: @closureType@ returns appropriately specialised tycon and +datacons. +\begin{code} +closureType :: ClosureInfo -> Maybe (TyCon, [UniType], [Id]) + +-- First, a turgid special case. When we are generating the +-- standard code and info-table for Vaps (which is done when the function +-- defn is encountered), we don't have a convenient Id to hand whose +-- type is that of (f x y z). So we need to figure out the type +-- 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 (getIdUniType fun_id) + +closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (getIdUniType id) +\end{code} + +@closureReturnsUnboxedType@ is used to check whether a closure, {\em +once it has eaten its arguments}, returns an unboxed type. For +example, the closure for a function: +\begin{verbatim} + f :: Int -> Int# +\end{verbatim} +returns an unboxed type. This is important when dealing with stack +overflow checks. +\begin{code} +closureReturnsUnboxedType :: ClosureInfo -> Bool + +closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _) + = isPrimType (funResultTy de_foralld_ty arity) + where + (_, de_foralld_ty) = splitForalls (getIdUniType fun_id) + +closureReturnsUnboxedType other_closure = False + -- All non-function closures aren't functions, + -- and hence are boxed, since they are heap alloc'd +\end{code} + +\begin{code} +closureSemiTag :: ClosureInfo -> Int + +closureSemiTag (MkClosureInfo _ lf_info _) + = case lf_info of + LFCon data_con _ -> getDataConTag data_con - fIRST_TAG + LFTuple _ _ -> 0 + LFIndirection -> fromInteger iND_TAG + _ -> fromInteger oTHER_TAG +\end{code} + +Label generation. + +\begin{code} +infoTableLabelFromCI :: ClosureInfo -> CLabel + +infoTableLabelFromCI (MkClosureInfo id lf_info rep) + = case lf_info of + LFCon con _ -> mkConInfoPtr con rep + LFTuple tup _ -> mkConInfoPtr tup rep + + LFBlackHole -> mkBlackHoleInfoTableLabel + + LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag + -- Use the standard vap info table + -- for the function, rather than a one-off one + -- for this particular closure + +{- For now, we generate individual info table and entry code for selector thunks, + so their info table should be labelled in the standard way. + The only special thing about them is that the info table has a field which + tells the GC that it really is a selector. + + Later, perhaps, we'll have some standard RTS code for selector-thunk info tables, + in which case this line will spring back to life. + + LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset + -- Ditto for selectors +-} + + other -> if isStaticRep rep + then mkStaticInfoTableLabel id + else mkInfoTableLabel id + +mkConInfoPtr :: Id -> SMRep -> CLabel +mkConInfoPtr id rep = + case rep of + PhantomRep -> mkPhantomInfoTableLabel id + StaticRep _ _ -> mkStaticInfoTableLabel id + _ -> mkInfoTableLabel id + +mkConEntryPtr :: Id -> SMRep -> CLabel +mkConEntryPtr id rep = + case rep of + StaticRep _ _ -> mkStaticConEntryLabel id + _ -> mkConEntryLabel id + + +closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI (MkClosureInfo id lf_info rep) + = case lf_info of + LFThunk _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag + LFCon con _ -> mkConEntryPtr con rep + LFTuple tup _ -> mkConEntryPtr tup rep + other -> mkStdEntryLabel id + +-- thunkEntryLabel is a local help function, not exported. It's used from both +-- entryLabelFromCI and getEntryConvention. +-- I don't think it needs to deal with the SelectorThunk case +-- Well, it's falling over now, so I've made it deal with it. (JSM) + +thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable + = mkVapEntryLabel fun_id is_updatable +thunkEntryLabel thunk_id _ is_updatable + = mkStdEntryLabel thunk_id + +fastLabelFromCI :: ClosureInfo -> CLabel +fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity + where + arity_maybe = arityMaybe (getIdArity id) + fun_arity = case arity_maybe of + Just x -> x + _ -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id) +\end{code} + +\begin{code} +allocProfilingMsg :: ClosureInfo -> FAST_STRING + +allocProfilingMsg (MkClosureInfo _ lf_info _) + = case lf_info of + LFReEntrant _ _ _ -> SLIT("ALLOC_FUN") + LFCon _ _ -> SLIT("ALLOC_CON") + LFTuple _ _ -> SLIT("ALLOC_CON") + LFThunk _ _ _ _ -> SLIT("ALLOC_THK") + LFBlackHole -> SLIT("ALLOC_BH") + LFIndirection -> panic "ALLOC_IND" + 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. + +\begin{code} +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. + +\begin{code} + +dataConLiveness (MkClosureInfo con _ PhantomRep) + = case dataReturnConvAlg con of + ReturnInRegs regs -> mkLiveRegsBitMask regs + ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???" + +dataConLiveness _ = mkLiveRegsBitMask [node] +\end{code} + +%************************************************************************ +%* * +\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.} +%* * +%************************************************************************ + +Profiling requires three pices of information to be determined for +each closure's info table --- kind, description and type. + +The description is stored directly in the @CClosureInfoTable@ when the +info table is built. + +The kind is determined from the @LambdaForm@ stored in the closure +info using @closureKind@. + +The type is determined from the type information stored with the @Id@ +in the closure info using @closureTypeDescr@. + +\begin{code} +closureKind :: ClosureInfo -> String + +closureKind (MkClosureInfo _ lf _) + = case lf of + LFReEntrant _ n _ -> if n > 0 then "FN_K" else "THK_K" + LFCon _ _ -> "CON_K" + LFTuple _ _ -> "CON_K" + LFThunk _ _ _ _ -> "THK_K" + LFBlackHole -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?) + LFIndirection -> panic "IND_KIND" + LFImported -> panic "IMP_KIND" + +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 -> + else + getUniTyDescription (getIdUniType id) +\end{code} + diff --git a/ghc/compiler/codeGen/CodeGen.hi b/ghc/compiler/codeGen/CodeGen.hi new file mode 100644 index 0000000..28362e7 --- /dev/null +++ b/ghc/compiler/codeGen/CodeGen.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CodeGen where +import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import ClosureInfo(ClosureInfo) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CostCentre(CostCentre) +import FiniteMap(FiniteMap) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import StgSyn(StgBinding, StgRhs) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +codeGen :: _PackedString -> ([CostCentre], [CostCentre]) -> [_PackedString] -> (GlobalSwitch -> SwitchResult) -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> [StgBinding Id Id] -> AbstractC + {-# GHC_PRAGMA _A_ 7 _U_ 2112112 _N_ _S_ "LU(LL)LSLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs new file mode 100644 index 0000000..a1aa854 --- /dev/null +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -0,0 +1,177 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CodeGen]{@CodeGen@: main module of the code generator} + +This module says how things get going at the top level. + +@codeGen@ is the interface to the outside world. The \tr{cgTop*} +functions drive the mangling of top-level bindings. + +%************************************************************************ +%* * +\subsection[codeGen-outside-interface]{The code generator's offering to the world} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module CodeGen ( + codeGen, + + -- and to make the interface self-sufficient... + UniqFM, AbstractC, StgBinding, Id, FiniteMap + ) where + + +import StgSyn +import CgMonad +import AbsCSyn + +import CLabelInfo ( modnameToC ) +import CgClosure ( cgTopRhsClosure ) +import CgCon ( cgTopRhsCon ) +import CgConTbls ( genStaticConBits, TCE(..), UniqFM ) +import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo ) +import CmdLineOpts ( GlobalSwitch(..), switchIsOn, stringSwitchSet, SwitchResult ) +import FiniteMap ( FiniteMap ) +import Maybes ( Maybe(..) ) +import PrimKind ( getKindSize ) +import Util +\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 + -> (GlobalSwitch -> SwitchResult) + -- global switch lookup function + -> [TyCon] -- tycons with data constructors to convert + -> FiniteMap TyCon [[Maybe UniType]] + -- tycon specialisation info + -> PlainStgProgram -- bindings to convert + -> AbstractC -- output + +codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons tycon_specs stg_pgm + = let + switch_is_on = switchIsOn sw_lookup_fn + doing_profiling = switch_is_on SccProfilingOn + compiling_prelude = switch_is_on CompilingPrelude + splitting = switch_is_on (EnsureSplittableC (panic "codeGen:esc")) + in + if not doing_profiling then + let + cinfo = MkCompInfo switch_is_on mod_name + in + mkAbstractCs [ + genStaticConBits cinfo gen_tycons tycon_specs, + initC cinfo (cgTopBindings splitting stg_pgm) ] + + else -- yes, cost-centre profiling: + -- Besides the usual stuff, we must produce: + -- + -- * Declarations for the cost-centres defined in this module; + -- * Code to participate in "registering" all the cost-centres + -- in the program (done at startup time when the pgm is run). + -- + -- (The local cost-centres involved in this are passed + -- into the code-generator, as are the imported-modules' names.) + -- + -- Note: we don't register/etc if compiling Prelude bits. + let + cinfo = MkCompInfo switch_is_on mod_name + in + mkAbstractCs [ + if compiling_prelude + then AbsCNop + else mkAbstractCs [mkAbstractCs (map (CCostCentreDecl True) local_CCs), + mkAbstractCs (map (CCostCentreDecl False) extern_CCs), + mkCcRegister local_CCs import_names], + + genStaticConBits cinfo gen_tycons tycon_specs, + initC cinfo (cgTopBindings splitting stg_pgm) ] + where + ----------------- + grp_name = case (stringSwitchSet sw_lookup_fn SccGroup) of + Just xx -> _PK_ 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) + in + mkAbstractCs [ + CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrKind], + register_ccs, + register_imports, + CCallProfCCMacro SLIT("END_REGISTER_CCS") [] + ] + where + mk_register cc + = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc] + + mk_import_register import_name + = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrKind] +\end{code} + +%************************************************************************ +%* * +\subsection[codegen-top-bindings]{Converting top-level STG bindings} +%* * +%************************************************************************ + +@cgTopBindings@ is only used for top-level bindings, since they need +to be allocated statically (not in the heap) and need to be labelled. +No unboxed bindings can happen at top level. + +In the code below, the static bindings are accumulated in the +@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@. +This is so that we can write the top level processing in a compositional +style, with the increasing static environment being plumbed as a state +variable. + +\begin{code} +cgTopBindings :: Bool -> PlainStgProgram -> Code + +cgTopBindings splitting bindings = mapCs (cgTopBinding splitting) bindings + +cgTopBinding :: Bool -> PlainStgBinding -> Code + +cgTopBinding splitting (StgNonRec name rhs) + = absC maybe_split `thenC` + cgTopRhs name rhs `thenFC` \ (name, info) -> + addBindC name info + where + maybe_split = if splitting then CSplitMarker else AbsCNop + +cgTopBinding splitting (StgRec pairs) + = absC maybe_split `thenC` + fixC (\ new_binds -> addBindsC new_binds `thenC` + mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs + ) `thenFC` \ new_binds -> + addBindsC new_binds + where + maybe_split = if splitting then CSplitMarker else AbsCNop + +-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs +-- to enclose the listFCs in cgTopBinding, but that tickled the +-- statics "error" call in initC. I DON'T UNDERSTAND WHY! + +cgTopRhs :: Id -> PlainStgRhs -> FCode (Id, CgIdInfo) + -- the Id is passed along for setting up a binding... + +cgTopRhs name (StgRhsCon cc con args) + = forkStatics (cgTopRhsCon name con args (all zero_size args)) + where + zero_size atom = getKindSize (getAtomKind atom) == 0 + +cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body) + = ASSERT(null fvs) -- There should be no free variables + forkStatics (cgTopRhsClosure name cc bi args body lf_info) + where + lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body +\end{code} diff --git a/ghc/compiler/codeGen/Jmakefile b/ghc/compiler/codeGen/Jmakefile new file mode 100644 index 0000000..03e6c14 --- /dev/null +++ b/ghc/compiler/codeGen/Jmakefile @@ -0,0 +1,19 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) +HaskellSuffixRules() + +LitSuffixRule(.lit,/*none*/) /* no language really */ +LitSuffixRule(.lhs,.hs) /* Haskell */ +LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */ +LitSuffixRule(.lprl,.prl) /* Perl */ +LitSuffixRule(.lsh,.sh) /* Bourne shell */ +LitSuffixRule(.lc,.c) /* C */ +LitSuffixRule(.lh,.h) +LitSuffixRule(.llex,.lex) /* Lex */ +LitSuffixRule(.lflex,.flex) /* Flex */ + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTargetWithNamedOutput(codegen,lit,codegen-standalone) diff --git a/ghc/compiler/codeGen/SMRep.hi b/ghc/compiler/codeGen/SMRep.hi new file mode 100644 index 0000000..bad95d4 --- /dev/null +++ b/ghc/compiler/codeGen/SMRep.hi @@ -0,0 +1,37 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SMRep where +import Outputable(Outputable) +data SMRep = StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int +data SMSpecRepKind = SpecRep | ConstantRep | CharLikeRep | IntLikeRep +data SMUpdateKind = SMNormalForm | SMSingleEntry | SMUpdatable +getSMInfoStr :: SMRep -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getSMInitHdrStr :: SMRep -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getSMUpdInplaceHdrStr :: SMRep -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +ltSMRepHdr :: SMRep -> SMRep -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq SMRep + {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool)] [_CONSTM_ Eq (==) (SMRep), _CONSTM_ Eq (/=) (SMRep)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord SMRep + {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq SMRep}}, (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> SMRep), (SMRep -> SMRep -> SMRep), (SMRep -> SMRep -> _CMP_TAG)] [_DFUN_ Eq (SMRep), _CONSTM_ Ord (<) (SMRep), _CONSTM_ Ord (<=) (SMRep), _CONSTM_ Ord (>=) (SMRep), _CONSTM_ Ord (>) (SMRep), _CONSTM_ Ord max (SMRep), _CONSTM_ Ord min (SMRep), _CONSTM_ Ord _tagCmp (SMRep)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: SMRep) (u1 :: SMRep) -> _APP_ _CONSTM_ Ord (<=) (SMRep) [ u1, u0 ] _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: SMRep) (u1 :: SMRep) -> _APP_ _CONSTM_ Ord (<) (SMRep) [ u1, u0 ] _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Outputable SMRep + {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (SMRep) _N_ + ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Text SMRep + {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SMRep, [Char])]), (Int -> SMRep -> [Char] -> [Char]), ([Char] -> [([SMRep], [Char])]), ([SMRep] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SMRep), _CONSTM_ Text showsPrec (SMRep), _CONSTM_ Text readList (SMRep), _CONSTM_ Text showList (SMRep)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(SMRep, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 3 _U_ 012 _N_ _S_ "ASL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs new file mode 100644 index 0000000..fb5b113 --- /dev/null +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -0,0 +1,208 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[SMRep]{Storage manager representations of closure} + +This is here, rather than in ClosureInfo, just to keep nhc happy. +Other modules should access this info through ClosureInfo. + +\begin{code} +#include "HsVersions.h" + +module SMRep ( + SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), + getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, + ltSMRepHdr -- UNUSED, equivSMRepHdr + ) where + +import Outputable +import Pretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation} +%* * +%************************************************************************ + +Ways in which a closure may be represented by the storage manager; +this list slavishly follows the storage-manager interface document. + +\begin{code} +data SMSpecRepKind + = SpecRep -- Normal Spec representation + + | ConstantRep -- Common me up with single global copy + -- Used for nullary constructors + + | CharLikeRep -- Common me up with entry from global table + + | IntLikeRep -- Common me up with entry from global table, + -- if the intlike field is in range. + +data SMUpdateKind + = SMNormalForm -- Normal form, no update + | SMSingleEntry -- Single entry thunk, non-updatable + | SMUpdatable -- Shared thunk, updatable + +data SMRep + = StaticRep -- Don't move me, Oh garbage collector! + -- Used for all statically-allocated closures. + Int -- # ptr words (useful for interpreter, debugger, etc) + Int -- # non-ptr words + + | SpecialisedRep -- GC routines know size etc + -- All have same _HS = SPEC_HS and no _VHS + SMSpecRepKind -- Which kind of specialised representation + Int -- # ptr words + Int -- # non-ptr words + SMUpdateKind -- Updatable? + + | GenericRep -- GC routines consult sizes in info tbl + Int -- # ptr words + Int -- # non-ptr words + SMUpdateKind -- Updatable? + + | BigTupleRep -- All ptrs, size in var-hdr field + -- Used for big tuples + Int -- # ptr words + + | DataRep -- All non-ptrs, size in var-hdr field + -- Used for arbitrary-precision integers, strings + Int -- # non-ptr words + + | DynamicRep -- Size and # ptrs in var-hdr field + -- Used by RTS for partial applications + + | BlackHoleRep -- for black hole closures + + | PhantomRep -- for "phantom" closures that only exist in registers + + | MuTupleRep -- All ptrs, size in var-hdr field + -- Used for mutable tuples + Int -- # ptr words + +instance Eq SMRep where + (SpecialisedRep k1 a1 b1 _) == (SpecialisedRep k2 a2 b2 _) = (tagOf_SMSpecRepKind k1) _EQ_ (tagOf_SMSpecRepKind k2) + && a1 == a2 && b1 == b2 + (GenericRep a1 b1 _) == (GenericRep a2 b2 _) = a1 == a2 && b1 == b2 + (BigTupleRep a1) == (BigTupleRep a2) = a1 == a2 + (MuTupleRep a1) == (MuTupleRep a2) = a1 == a2 + (DataRep a1) == (DataRep a2) = a1 == a2 + a == b = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b) + +{- UNUSED: +equivSMRepHdr :: SMRep -> SMRep -> Bool +a `equivSMRepHdr` b = (tagOf_SMRep a) _EQ_ (tagOf_SMRep b) +-} + +ltSMRepHdr :: SMRep -> SMRep -> Bool +a `ltSMRepHdr` b = (tagOf_SMRep a) _LT_ (tagOf_SMRep b) + +instance Ord SMRep where + -- ToDo: cmp-ify? This instance seems a bit weird (WDP 94/10) + rep1 <= rep2 = rep1 < rep2 || rep1 == rep2 + rep1 < rep2 + = let tag1 = tagOf_SMRep rep1 + tag2 = tagOf_SMRep rep2 + in + if tag1 _LT_ tag2 then True + else if tag1 _GT_ tag2 then False + else {- tags equal -} rep1 `lt` rep2 + where + (SpecialisedRep k1 a1 b1 _) `lt` (SpecialisedRep k2 a2 b2 _) = + t1 _LT_ t2 || (t1 _EQ_ t2 && (a1 < a2 || (a1 == a2 && b1 < b2))) + where t1 = tagOf_SMSpecRepKind k1 + t2 = tagOf_SMSpecRepKind k2 + (GenericRep a1 b1 _) `lt` (GenericRep a2 b2 _) = a1 < a2 || (a1 == a2 && b1 < b2) + (BigTupleRep a1) `lt` (BigTupleRep a2) = a1 < a2 + (MuTupleRep a1) `lt` (MuTupleRep a2) = a1 < a2 + (DataRep a1) `lt` (DataRep a2) = a1 < a2 + a `lt` b = True + +tagOf_SMSpecRepKind SpecRep = (ILIT(1) :: FAST_INT) +tagOf_SMSpecRepKind ConstantRep = ILIT(2) +tagOf_SMSpecRepKind CharLikeRep = ILIT(3) +tagOf_SMSpecRepKind IntLikeRep = ILIT(4) + +tagOf_SMRep (StaticRep _ _) = (ILIT(1) :: FAST_INT) +tagOf_SMRep (SpecialisedRep k _ _ _) = ILIT(2) +tagOf_SMRep (GenericRep _ _ _) = ILIT(3) +tagOf_SMRep (BigTupleRep _) = ILIT(4) +tagOf_SMRep (DataRep _) = ILIT(5) +tagOf_SMRep DynamicRep = ILIT(6) +tagOf_SMRep BlackHoleRep = ILIT(7) +tagOf_SMRep PhantomRep = ILIT(8) +tagOf_SMRep (MuTupleRep _) = ILIT(9) + +instance Text SMRep where + showsPrec d rep rest + = (case rep of + StaticRep _ _ -> "STATIC" + SpecialisedRep kind _ _ SMNormalForm -> "SPEC_N" + SpecialisedRep kind _ _ SMSingleEntry -> "SPEC_S" + SpecialisedRep kind _ _ SMUpdatable -> "SPEC_U" + GenericRep _ _ SMNormalForm -> "GEN_N" + GenericRep _ _ SMSingleEntry -> "GEN_S" + GenericRep _ _ SMUpdatable -> "GEN_U" + BigTupleRep _ -> "TUPLE" + DataRep _ -> "DATA" + DynamicRep -> "DYN" + BlackHoleRep -> "BH" + PhantomRep -> "INREGS" + MuTupleRep _ -> "MUTUPLE") ++ rest + +instance Outputable SMRep where + ppr sty rep = ppStr (show rep) + +getSMInfoStr :: SMRep -> String +getSMInfoStr (StaticRep _ _) = "STATIC" +getSMInfoStr (SpecialisedRep ConstantRep _ _ _) = "CONST" +getSMInfoStr (SpecialisedRep CharLikeRep _ _ _) = "CHARLIKE" +getSMInfoStr (SpecialisedRep IntLikeRep _ _ _) = "INTLIKE" +getSMInfoStr (SpecialisedRep SpecRep _ _ SMNormalForm) = "SPEC_N" +getSMInfoStr (SpecialisedRep SpecRep _ _ SMSingleEntry) = "SPEC_S" +getSMInfoStr (SpecialisedRep SpecRep _ _ SMUpdatable) = "SPEC_U" +getSMInfoStr (GenericRep _ _ SMNormalForm) = "GEN_N" +getSMInfoStr (GenericRep _ _ SMSingleEntry) = "GEN_S" +getSMInfoStr (GenericRep _ _ SMUpdatable) = "GEN_U" +getSMInfoStr (BigTupleRep _) = "TUPLE" +getSMInfoStr (DataRep _ ) = "DATA" +getSMInfoStr DynamicRep = "DYN" +getSMInfoStr BlackHoleRep = panic "getSMInfoStr.BlackHole" +getSMInfoStr PhantomRep = "INREGS" +getSMInfoStr (MuTupleRep _) = "MUTUPLE" + +getSMInitHdrStr :: SMRep -> String +getSMInitHdrStr (SpecialisedRep IntLikeRep _ _ _) = "SET_INTLIKE" +getSMInitHdrStr (SpecialisedRep SpecRep _ _ _) = "SET_SPEC" +getSMInitHdrStr (GenericRep _ _ _) = "SET_GEN" +getSMInitHdrStr (BigTupleRep _) = "SET_TUPLE" +getSMInitHdrStr (DataRep _ ) = "SET_DATA" +getSMInitHdrStr DynamicRep = "SET_DYN" +getSMInitHdrStr BlackHoleRep = "SET_BH" +#ifdef DEBUG +getSMInitHdrStr (StaticRep _ _) = panic "getSMInitHdrStr.Static" +getSMInitHdrStr PhantomRep = panic "getSMInitHdrStr.Phantom" +getSMInitHdrStr (MuTupleRep _) = panic "getSMInitHdrStr.Mutuple" +getSMInitHdrStr (SpecialisedRep ConstantRep _ _ _) = panic "getSMInitHdrStr.Constant" +getSMInitHdrStr (SpecialisedRep CharLikeRep _ _ _) = panic "getSMInitHdrStr.CharLike" +#endif + +getSMUpdInplaceHdrStr :: SMRep -> String +getSMUpdInplaceHdrStr (SpecialisedRep ConstantRep _ _ _) = "INPLACE_UPD" +getSMUpdInplaceHdrStr (SpecialisedRep CharLikeRep _ _ _) = "INPLACE_UPD" +getSMUpdInplaceHdrStr (SpecialisedRep IntLikeRep _ _ _) = "INPLACE_UPD" +getSMUpdInplaceHdrStr (SpecialisedRep SpecRep _ _ _) = "INPLACE_UPD" +#ifdef DEBUG +getSMUpdInplaceHdrStr (StaticRep _ _) = panic "getSMUpdInplaceHdrStr.Static" +getSMUpdInplaceHdrStr (GenericRep _ _ _) = panic "getSMUpdInplaceHdrStr.Generic" +getSMUpdInplaceHdrStr (BigTupleRep _ ) = panic "getSMUpdInplaceHdrStr.BigTuple" +getSMUpdInplaceHdrStr (DataRep _ ) = panic "getSMUpdInplaceHdrStr.Data" +getSMUpdInplaceHdrStr DynamicRep = panic "getSMUpdInplaceHdrStr.Dynamic" +getSMUpdInplaceHdrStr BlackHoleRep = panic "getSMUpdInplaceHdrStr.BlackHole" +getSMUpdInplaceHdrStr PhantomRep = panic "getSMUpdInplaceHdrStr.Phantom" +getSMUpdInplaceHdrStr (MuTupleRep _ ) = panic "getSMUpdInplaceHdrStr.MuTuple" +#endif +\end{code} diff --git a/ghc/compiler/codeGen/cgintro.lit b/ghc/compiler/codeGen/cgintro.lit new file mode 100644 index 0000000..4df253e --- /dev/null +++ b/ghc/compiler/codeGen/cgintro.lit @@ -0,0 +1,783 @@ +\section[codegen-intro]{Intro/background info for the code generator} + +\tr{NOTES.codeGen} LIVES!!! + +\begin{verbatim} +======================= +NEW! 10 Nov 93 Semi-tagging + +Rough idea + + case x of -- NB just a variable scrutinised + [] -> ... + (p:ps) -> ...p... -- eg. ps not used + +generates + + Node = a ptr to x + while TRUE do { switch TAG(Node) { + + INDIRECTION_TAG : Node = Node[1]; break; -- Dereference indirection + + OTHER_TAG : adjust stack; push return address; ENTER(Node) + + 0 : adjust stack; + JUMP( Nil_case ) + + 1 : adjust stack; + R2 := Node[2] -- Get ps + JUMP( Cons_case ) + } + +* The "return address" is a vector table, which contains pointers to + Nil_case and Cons_case. + +* The "adjust stack" in the case of OTHER_TAG is one word different to + that in the case of a constructor tag (0,1,...), because it needs to + take account of the return address. That's why the stack adjust + shows up in the branches, rather than before the switch. + +* In the case of *unvectored* returns, the "return address" will be + some code which switches on TagReg. Currently, the branches of the + case at the return address have the code for the alternatives + actually there: + + switch TagReg { + 0 : code for nil case + 1 : code for cons case + } + +But with semi-tagging, we'll have to label each branch: + + switch TagReg { + 0 : JUMP( Nil_case ) + 1 : JUMP( Cons_case ) + } + +So there's an extra jump. Boring. Boring. (But things are usually +eval'd...in which case we save a jump.) + +* TAG is a macro which gets a "tag" from the info table. The tag + encodes whether the thing is (a) an indirection, (b) evaluated + constructor with tag N, or (c) something else. The "something else" + usually indicates something unevaluated, but it might also include + FETCH_MEs etc. Anything which must be entered. + +* Maybe we should get the info ptr out of Node, into a temporary + InfoPtrReg, so that TAG and ENTER share the info-ptr fetch. + +* We only load registers which are live in the alternatives. So at + the start of an alternative, either the unused fields *will* be in + regs (if we came via enter/return) or they *won't* (if we came via + the semi-tagging switch). If they aren't, GC had better not follow + them. So we can't arrange that all live ptrs are neatly lined up in + the first N regs any more. So GC has to take a liveness + bit-pattern, not just a "number of live regs" number. + +* We need to know which of the constructors fields are live in the + alternatives. Hence STG code has to be elaborated to keep live vars + for each alternative, or to tag each bound-var in the alternatives + with whether or not it is used. + +* The code generator needs to be able to construct unique labels for + the case alternatives. (Previously this was done by the AbsC + flattening pass.) Reason: we now have an explicit join point at the + start of each alternative. + +* There's some question about how tags are mapped. Is 0 the first + tag? (Good when switching on TagReg when there are only two + constructors.) What is OTHER_TAG and INDIRECTION_TAG? + +* This whole deal can be freely mixed with un-semi-tagged code. + There should be a compiler flag to control it. + +======================= +Many of the details herein are moldy and dubious, but the general +principles are still mostly sound. +\end{verbatim} + +%************************************************************************ +%* * +\subsection{LIST OF OPTIMISATIONS TO DO} +%* * +%************************************************************************ + +\begin{itemize} +\item +Register return conventions. + +\item +Optimisations for Enter when + \begin{itemize} + \item + know code ptr, so don't indirect via Node + \item + know how many args + \item + top level closures don't load Node + \end{itemize} +\item +Strings. + +\item +Case of unboxed op with more than one alternative, should generate +a switch or an if statement. +\end{itemize} + +{\em Medium} + +\begin{itemize} +\item +Don't allocate constructors with no args. +Instead have a single global one. + +\item +Have global closures for all characters, and all small numbers. +\end{itemize} + + +{\em Small} + +\begin{itemize} +\item +When a closure is one of its own free variables, don't waste a field +on it. Instead just use Node. +\end{itemize} + + +%************************************************************************ +%* * +\subsection{ENTERING THE GARBAGE COLLECTOR} +%* * +%************************************************************************ + +[WDP: OLD] + +There are the following ways to get into the garbage collector: + +\begin{verbatim} +_HEAP_OVERFLOW_ReturnViaNode +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Used for the GC trap at closure entry. + + - Node is only live ptr + - After GC, enter Node + +_HEAP_OVERFLOW_ReturnDirect0, _HEAP_OVERFLOW_ReturnDirect1, ... +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Used: for fast entry of functions, and + case alternative where values are returned in regs + + - PtrReg1..n are live ptrs + - ReturnReg points to start of code (before hp oflo check) + - After GC, jump to ReturnReg + - TagReg is preserved, in case this is an unvectored return + + +_HEAP_OVERFLOW_CaseReturnViaNode +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + *** GRIP ONLY *** + +Used for case alternatives which return node in heap + + - Node is only live ptr + - RetVecReg points to return vector + - After GC, push RetVecReg and enter Node +\end{verbatim} + +Exactly equivalent to @GC_ReturnViaNode@, preceded by pushing @ReturnVectorReg@. + +The only reason we re-enter Node is so that in a GRIP-ish world, the +closure pointed to be Node is re-loaded into local store if necessary. + +%************************************************************************ +%* * +\subsection{UPDATES} +%* * +%************************************************************************ + +[New stuff 27 Nov 91] + +\subsubsection{Return conventions} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When executing the update continuation code for a constructor, +@RetVecReg@ points to the {\em beginning of} the return vector. This is to +enable the update code to find the normal continuation code. +(@RetVecReg@ is set up by the code which jumps to the update continuation +code.) + +\subsubsection{Stack arrangement} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Each stack has a ``stack update ptr'', SuA and SuB, which point to the +topmost word of the stack just after an update frame has been pushed. + +A standard update frame (on the B stack) looks like this +(stack grows downward in this picture): + +\begin{verbatim} + | | + |---------------------------------------| + | Saved SuA | + |---------------------------------------| + | Saved SuB | + |---------------------------------------| + | Pointer to closure to be updated | + |---------------------------------------| + | Pointer to Update return vector | + |---------------------------------------| +\end{verbatim} + +The SuB therefore points to the Update return vector component of the +topmost update frame. + +A {\em constructor} update frame, which is pushed only by closures +which know they will evaluate to a data object, looks just the +same, but without the saved SuA pointer. + +\subsubsection{Pushing update frames} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An update is pushed right at the start of the code for an updatable +closure. But {\em after} the stack overflow check. (The B-stack oflo +check should thereby include allowance for the update frame itself.) + +\subsubsection{Return vectors} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Every ``return address'' pushed on the stack by a boxed \tr{case} is a +pointer to a vector of one or more pairs of code pointers: + +\begin{verbatim} + ------> ----------------- + | Cont1 | + |---------------| + | Update1 | + ----------------- + | Cont2 | + |---------------| + | Update2 | + ----------------- + ...etc... +\end{verbatim} + +Each pair consists of a {\em continuation} code pointer and an +{\em update} code pointer. + +For data types with only one constructor, or too many constructors for +vectoring, the return vector consists of a single pair. + +When the \tr{data} decl for each data type is compiled, as well as +making info tables for each constructor, an update code sequence for +each constructor (or a single one, if unvectored) is also created. + +ToDo: ** record naming convention for these code sequences somewhere ** + +When the update code is entered, it uses the value stored in the +return registers used by that constructor to update the thing pointed +to by the update frame (all of which except for the return address is +still on the B stack). If it can do an update in place (ie +constructor takes 3 words or fewer) it does so. + +In the unvectored case, this code first has to do a switch on the tag, +UNLESS the return is in the heap, in which case simply overwrite with +an indirection to the thing Node points to. + +Tricky point: if the update code can't update in place it has to +allocate a new object, by performing a heap-oflo check and jumping to +the appropriate heap-overflow entry point depending on which RetPtr +registers are live (just as when compiling a case alternative). + +When the update code is entered, a register @ReturnReg@ is assumed to +contain the ``return address'' popped from the B stack. This is so +that the update code can enter the normal continuation code when it is +done. + +For standard update frames, the A and B stack update ptrs are restored +from the saved versions before returning, too. + +\subsubsection{Update return vector} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both standard and constructor update frames have as their topmost word +a pointer to a static, fixed, update return vector. + +The ``continuation'' entry of each pair in this vector sets UpdReg to +point to the thing to be updated (gotten from the update frame), pops +the update frame, and returns to the ``update'' entry of the +corresponding pair in the next return vector (now exposed on top of B +stk). + +The ``update'' entry of each pair in this vector overwrites the thing +to be updated with an indirection to the thing UpdReg points to, and +then returns in the same was as the "continuation" entry above. + +There need to be enough pairs in the update return vector to cater for +any constructor at all. + + +************************* + +Things which need to be altered if you change the number of constructors +which switches off vectored returns: +\begin{verbatim} + Extra cases in update return vector (file xxx) + The value xxxx in yyyy.lhs + others? +\end{verbatim} +************************** + +%************************************************************************ +%* * +\subsection{HEAP OBJECTS} +%* * +%************************************************************************ + +The heap consists of {\em closures}. +A closure can be either: +\begin{itemize} +\item +a {\em suspension}, which is an unevaluated thunk. +\item +a {\em constructed object} (or just constructor); created by let(recs) and +by updating. +\item +a {\em partial application} (only updating creates these). +\end{itemize} + +Closures are laid out with the {\em info pointer} at the lowest +address (but see notes on the Global Address field for parallel +system). [We don't try to localise knowledge of this! It is a royal +pain having to cope with closures laid out backwards.] + +Ptr fields occur first (before non-ptr ones). + +Non-normal-form closures are always at least 3 words in size (excl +global address), so they can be updated with a list cell (should they +evaluate to that). + +Normal form (constructor) closures are always at least 2 words in size +(excl global address), so they have room enough for forwarding ptrs +during GC, and FETCHME boxes after flushing. + +1-word closures for normal-form closures in static space. Explain +more. + +Ideally, the info pointer of a closure would point to... +\begin{verbatim} + |-------------| + | info table | + |-------------| +info ptr ---> code +\end{verbatim} + +But when C is the target code we can't guarantee the relative +positions of code and data. So the info ptr points to +\begin{verbatim} + |-------------| +info ptr ---->| ------------------------> code + |-------------| + | info table | + |-------------| +\end{verbatim} + +That is, there's an extra indirection involved; and the info table +occurs AFTER the info pointer rather than before. The info table +entries are ``reversed'' too, so that bigger negative offsets in the +``usual'' case turn into bigger positive offsets. + +SUSPENSIONS + +The simplest form of suspension is +\begin{verbatim} + info-ptr, ptr free vars, non-ptr free vars +\end{verbatim} + +where the info table for info-ptr gives +\begin{itemize} +\item +the total number of words of free vars +\item +the number of words of ptr free vars (== number of ptr free vars) +in its extra-info part. +\end{itemize} + +Optimised versions omit the size info from the info table, and instead +use specialised GC routines. + + +%************************************************************************ +%* * +\subsection{NAMING CONVENTIONS for compiled code} +%* * +%************************************************************************ + + +Given a top-level closure called f defined in module M, + +\begin{verbatim} + _M_f_closure labels the closure itself + (only for top-level (ie static) closures) + + _M_f_entry labels the slow entry point of the code + _M_f_fast labels the fast entry point of the code + + _M_f_info labels the info pointer for the closure for f + (NB the info ptr of a closure isn't public + in the sense that these labels + are. It is private to a module, and + its name can be a secret.) +\end{verbatim} + +These names are the REAL names that the linker sees. The initial underscores +are attached by the C compiler. + +A non-top-level closure has the same names, but as well as the \tr{f} +the labels have the unique number, so that different local closures +which share a name don't get confused. The reason we need a naming +convention at all is that with a little optimisation a tail call may +jump direct to the fast entry of a locally-defined closure. + +\tr{f} may be a constructor, in the case of closures which are the curried +versions of the constructor. + +For constructor closures, we have the following naming conventions, where +the constructor is C defined in module M: + +\begin{verbatim} + _M_C_con_info is the info ptr for the constructor + _M_C_con_entry is the corresponding code entry point +\end{verbatim} + +%************************************************************************ +%* * +\subsection{ENTRY CONVENTIONS} +%* * +%************************************************************************ + +\begin{description} +\item[Constructor objects:] + On entry to the code for a constructor (\tr{_M_C_con_entry}), Node + points to the constructor object. [Even if the constructor has arity + zero...] + +\item[Non-top-level suspensions (both fast and slow entries):] + Node points to the closure. + +\item[Top-level suspensions, slow entry:] + ReturnReg points to the slow entry point itself + +\item[..ditto, fast entry:] + No entry convention +\end{description} + + +%************************************************************************ +%* * +\subsection{CONSTRUCTOR RETURN CONVENTIONS} +%* * +%************************************************************************ + +There is lots of excitement concerning the way in which constructors +are returned to case expressions. + +{\em Simplest version} +%===================== + +The return address on the stack points directly to some code. It +expects: + +\begin{verbatim} +Boxed objects: + PtrReg1 points to the constructed value (in the heap) (unless arity=0) + Tag contains its tag (unless # of constructors = 1) + +Unboxed Ints: IntReg contains the int + Float: FloatReg contains the returned value +\end{verbatim} + +{\em Small improvement: vectoring} +%================================= + +If there are fewer than (say) 8 constructors in the type, the return +address points to a vector of return addresses. The constructor does +a vectored return. No CSwitch. + +Complication: updates. Update frames are built before the type of the +thing which will be returned is known. Hence their return address +UPDATE has to be able to handle anything (vectored and nonvectored). + +Hence the vector table goes BACKWARD from ONE WORD BEFORE the word +pointed to by the return address. + +{\em Big improvement: contents in registers} +%=========================================== + +Constructor with few enough components (eg 8ish) return their +arguments in registers. [If there is only one constructor in the +type, the tag register can be pressed into service for this purpose.] + +Complication: updates. Update frames are built before the type of the +thing which will be returned is known. Hence their return address +UPDATE has to be able to handle anything. + +So, a return address is a pointer to a PAIR of return addresses (or +maybe a pointer to some code immediately preceded by a pointer to some +code). + +The ``main'' return address is just as before. + +The ``update'' return address expects just the same regs to be in use +as the ``main'' address, BUT AS WELL the magic loc UpdPtr points to a +closure to be updated. It carries out the update, and contines with +the main return address. + +The ``main'' code for UPDATE just loads UpdPtr the thing to be +updated, and returns to the "update" entry of the next thing on the +stack. + +The ``update'' entry for UPDATE just overwrites the thing to be +updated with an indirection to UpdPtr. + +These two improvements can be combined orthogonally. + + +%************************************************************************ +%* * +\subsection{REGISTERS} +%* * +%************************************************************************ + +Separate registers for +\begin{verbatim} + C stack (incl interrupt handling, if this is not done on + another stk) (if interrupts don't mangle the C stack, + we could save it for most of the time and reuse the + register) + + Arg stack + Basic value and control stack + These two grow towards each other, so they are each + other's limits! + + Heap pointer +\end{verbatim} + +And probably also +\begin{verbatim} + Heap limit +\end{verbatim} + + +%************************************************************************ +%* * +\subsection{THE OFFSET SWAMP} +%* * +%************************************************************************ + +There are THREE kinds of offset: +\begin{description} +\item[virtual offsets:] + + start at 1 at base of frame, and increase towards top of stack. + + don't change when you adjust sp/hp. + + independent of stack direction. + + only exist inside the code generator, pre Abstract C + + for multi-word objects, the offset identifies the word of the + object with smallest offset + +\item[reg-relative offsets:] + + start at 0 for elt to which sp points, and increase ``into the + interesting stuff.'' + + Specifically, towards + \begin{itemize} + \item + bottom of stack (for SpA, SpB) + \item + beginning of heap (for Hp) + \item + end of closure (for Node) + \end{itemize} + + offset for a particular item changes when you adjust sp. + + independent of stack direction. + + exist in abstract C CVal and CAddr addressing modes + + for multi-word objects, the offset identifies the word of the + object with smallest offset + +\item[real offsets:] + + either the negation or identity of sp-relative offset. + + start at 0 for elt to which sp points, and either increase or + decrease towards bottom of stk, depending on stk direction + + exist in real C, usually as a macro call passing an sp-rel offset + + for multi-word objects, the offset identifies the word of the + object with lowest address +\end{description} + +%************************************************************************ +%* * +\subsection{STACKS} +%* * +%************************************************************************ + +There are two stacks, as in the STG paper. +\begin{description} +\item[A stack:] +contains only closure pointers. Its stack ptr is SpA. + +\item[B stack:] +contains basic values, return addresses, update frames. +Its stack ptr is SpB. +\end{description} + +SpA and SpB point to the topmost allocated word of stack (though they +may not be up to date in the middle of a basic block). + +\subsubsection{STACK ALLOCATION} + +A stack and B stack grow towards each other, so they overflow when +they collide. + +The A stack grows downward; the B stack grows upward. [We'll try to +localise stuff which uses this info.] + +We can check for stack {\em overflow} not just at the start of a basic +block, but at the start of an entire expression evaluation. The +high-water marks of case-expression alternatives can be max'd. + +Within the code for a closure, the ``stack frame'' is deemed to start +with the last argument taken by the closure (ie the one deepest in the +stack). Stack slots are can then be identified by ``virtual offsets'' +from the base of the frame; the bottom-most word of the frame has +offset 1. + +For multi-word slots (B stack only) the offset identifies the word +with the smallest virtual offset. [If B grows upward, this is the word +with the lowest physical address too.] + +Since there are two stacks, a ``stack frame'' really consists of two +stack frames, one on each stack. + +For each stack, we keep track of the following: + +\begin{verbatim} +* virtSp virtual stack ptr offset of topmost occupied stack slot + (initialised to 0 if no args) + +* realSp real stack ptr offset of real stack ptr reg + (initialised to 0 if no args) + +* tailSp tail-call ptr offset of topmost slot to be retained + at next tail call, excluding the + argument to the tail call itself + +* hwSp high-water mark largest value taken by virtSp + in this closure body +\end{verbatim} + +The real stack pointer is (for now) only adjusted at the tail call itself, +at which point it is made to point to the topmost occupied word of the stack. + +We can't always adjust it at the beginning, because we don't +necessarily know which tail call will be made (a conditional might +intervene). So stuff is actually put on the stack ``above'' the stack +pointer. This is ok because interrupts are serviced on a different +stack. + +The code generator works entirely in terms of stack {\em virtual +offsets}. The conversion to real addressing modes is done solely when +we look up a binding. When we move a stack pointer, the offsets of +variables currently bound to stack offsets in the environment will +change. We provide operations in the @cgBindings@ type to perform +this offset-change (to wit, @shiftStkOffsets@), leaving open whether +it is done pronto, or kept separate and applied to lookups. + +Stack overflow checking takes place at the start of a closure body, using +the high-water mark information gotten from the closure body. + + +%************************************************************************ +%* * +\subsection{HEAP ALLOCATION} +%* * +%************************************************************************ + +Heap ptr reg (Hp) points to the last word of allocated space (and not +to the first word of free space). + +The heap limit register (HpLim) points to the last word of available +space. + +A basic block allocates a chunk of heap called a ``heap frame''. +The word of the frame nearest to the previously-allocated stuff +has virtual offset 1, and offsets increase from 1 to the size of the +frame in words. + +Closures are allocated with their code pointers having the lowest virtual +offset. + +NOTE: this means that closures are only laid out with code ptr at +lowest PHYSICAL address if the heap grows upwards. + +Heap ptr reg is moved at the beginning of a basic block to account for +the allocation of the whole frame. At this time a heap exhaustion +check is made (has the heap ptr gone past the heap limit?). In the +basic block, indexed accesses off the heap ptr fill in this newly +allocated block. [Bias to RISC here: no cheap auto-inc mode, and free +indexing.] + +We maintain the following information during code generation: + +\begin{verbatim} +* virtHp virtual heap ptr offset of last word + of the frame allocated so far + Starts at 0 and increases. +* realHp virtual offset of + the real Hp register +\end{verbatim} + +Since virtHp only ever increases, it doubles as the heap high water mark. + +\subsubsection{BINDINGS} + +The code generator maintains info for each name about where it is. +Each variable maps to: + +\begin{verbatim} + - its kind + + - its volatile location:- a temporary variable + - a virtual heap offset n, meaning the + ADDRESS OF a word in the current + heap frame + - absent + + - its stable location: - a virtual stack offset n, meaning the + CONTENTS OF an object in the + current stack frame + - absent +\end{verbatim} + +\subsubsection{ENTERING AN OBJECT} + +When a closure is entered at the normal entry point, the magic locs +\begin{verbatim} + Node points to the closure (unless it is a top-level closure) + ReturnReg points to the code being jumped to +\end{verbatim} +At the fast entry point, Node is still set up, but ReturnReg may not be. +[Not sure about this.] diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.hi b/ghc/compiler/coreSyn/AnnCoreSyn.hi new file mode 100644 index 0000000..fbc7e7a --- /dev/null +++ b/ghc/compiler/coreSyn/AnnCoreSyn.hi @@ -0,0 +1,127 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AnnCoreSyn where +import BasicLit(BasicLit) +import Class(Class) +import CoreSyn(CoreAtom, CoreExpr) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName, ShortName) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import TyCon(TyCon, cmpTyCon) +import TyVar(TyVar, TyVarTemplate, cmpTyVar) +import UniType(UniType, cmpUniType) +import Unique(Unique) +data AnnCoreBinding a b c = AnnCoNonRec a (c, AnnCoreExpr' a b c) | AnnCoRec [(a, (c, AnnCoreExpr' a b c))] +data AnnCoreCaseAlternatives a b c = AnnCoAlgAlts [(Id, [a], (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) | AnnCoPrimAlts [(BasicLit, (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) +data AnnCoreCaseDefault a b c = AnnCoNoDefault | AnnCoBindDefault a (c, AnnCoreExpr' a b c) +type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c) +data AnnCoreExpr' a b c = AnnCoVar b | AnnCoLit BasicLit | AnnCoCon Id [UniType] [CoreAtom b] | AnnCoPrim PrimOp [UniType] [CoreAtom b] | AnnCoLam [a] (c, AnnCoreExpr' a b c) | AnnCoTyLam TyVar (c, AnnCoreExpr' a b c) | AnnCoApp (c, AnnCoreExpr' a b c) (CoreAtom b) | AnnCoTyApp (c, AnnCoreExpr' a b c) UniType | AnnCoCase (c, AnnCoreExpr' a b c) (AnnCoreCaseAlternatives a b c) | AnnCoLet (AnnCoreBinding a b c) (c, AnnCoreExpr' a b c) | AnnCoSCC CostCentre (c, AnnCoreExpr' a b c) +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpTyVar :: TyVar -> TyVar -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +deAnnotate :: (a, AnnCoreExpr' b c a) -> CoreExpr b c + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Eq BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-} +instance Outputable BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_ + ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_ + ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-} + diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs new file mode 100644 index 0000000..25ba46c --- /dev/null +++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs @@ -0,0 +1,185 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[AnnCoreSyntax]{Annotated core syntax} + +For when you want @CoreSyntax@ trees annotated at every node. Other +than that, just like @CoreSyntax@. (Important to be sure that it {\em +really is} just like @CoreSyntax@.) + +\begin{code} +#include "HsVersions.h" + +module AnnCoreSyn ( + AnnCoreBinding(..), AnnCoreExpr(..), + AnnCoreExpr'(..), -- v sad that this must be exported + AnnCoreCaseAlternatives(..), AnnCoreCaseDefault(..), +#ifdef DPH + AnnCoreParQuals(..), + AnnCoreParCommunicate(..), +#endif {- Data Parallel Haskell -} + + deAnnotate, -- we may eventually export some of the other deAnners + + -- and to make the interface self-sufficient + BasicLit, Id, PrimOp, TyCon, TyVar, UniType, CostCentre + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) where + +import AbsPrel ( PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( Id, TyVar, TyCon, UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import BasicLit ( BasicLit ) +import CoreSyn +import Outputable +import CostCentre ( CostCentre ) +#if USE_ATTACK_PRAGMAS +import Util +#endif +\end{code} + +\begin{code} +data AnnCoreBinding binder bindee annot + = AnnCoNonRec binder (AnnCoreExpr binder bindee annot) + | AnnCoRec [(binder, AnnCoreExpr binder bindee annot)] +\end{code} + +\begin{code} +type AnnCoreExpr binder bindee annot = (annot, AnnCoreExpr' binder bindee annot) + +data AnnCoreExpr' binder bindee annot + = AnnCoVar bindee + | AnnCoLit BasicLit + + | AnnCoCon Id [UniType] [CoreAtom bindee] + + | AnnCoPrim PrimOp [UniType] [CoreAtom bindee] + + | AnnCoLam [binder] + (AnnCoreExpr binder bindee annot) + | AnnCoTyLam TyVar + (AnnCoreExpr binder bindee annot) + + | AnnCoApp (AnnCoreExpr binder bindee annot) + (CoreAtom bindee) + | AnnCoTyApp (AnnCoreExpr binder bindee annot) + UniType + + | AnnCoCase (AnnCoreExpr binder bindee annot) + (AnnCoreCaseAlternatives binder bindee annot) + + | AnnCoLet (AnnCoreBinding binder bindee annot) + (AnnCoreExpr binder bindee annot) + + | AnnCoSCC CostCentre + (AnnCoreExpr binder bindee annot) +#ifdef DPH + | AnnCoZfExpr (AnnCoreExpr binder bindee annot) + (AnnCoreParQuals binder bindee annot) + + | AnnCoParCon Id Int [UniType] [AnnCoreExpr binder bindee annot] + + | AnnCoParComm + Int + (AnnCoreExpr binder bindee annot) + (AnnCoreParCommunicate binder bindee annot) + | AnnCoParZipWith + Int + (AnnCoreExpr binder bindee annot) + [AnnCoreExpr binder bindee annot] +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifdef DPH +data AnnCoreParQuals binder bindee annot + = AnnCoAndQuals (AnnCoreParQuals binder bindee annot) + (AnnCoreParQuals binder bindee annot) + | AnnCoParFilter (AnnCoreExpr binder bindee annot) + | AnnCoDrawnGen [binder] + (binder) + (AnnCoreExpr binder bindee annot) + | AnnCoIndexGen [AnnCoreExpr binder bindee annot] + (binder) + (AnnCoreExpr binder bindee annot) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +data AnnCoreCaseAlternatives binder bindee annot + = AnnCoAlgAlts [(Id, + [binder], + AnnCoreExpr binder bindee annot)] + (AnnCoreCaseDefault binder bindee annot) + | AnnCoPrimAlts [(BasicLit, + AnnCoreExpr binder bindee annot)] + (AnnCoreCaseDefault binder bindee annot) +#ifdef DPH + | AnnCoParAlgAlts TyCon + Int + [binder] + [(Id, + AnnCoreExpr binder bindee annot)] + (AnnCoreCaseDefault binder bindee annot) + | AnnCoParPrimAlts TyCon + Int + [(BasicLit, + AnnCoreExpr binder bindee annot)] + (AnnCoreCaseDefault binder bindee annot) +#endif {- Data Parallel Haskell -} + +data AnnCoreCaseDefault binder bindee annot + = AnnCoNoDefault + | AnnCoBindDefault binder + (AnnCoreExpr binder bindee annot) +\end{code} + +\begin{code} +#ifdef DPH +data AnnCoreParCommunicate binder bindee annot + = AnnCoParSend [AnnCoreExpr binder bindee annot] + | AnnCoParFetch [AnnCoreExpr binder bindee annot] + | AnnCoToPodized + | AnnCoFromPodized +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +deAnnotate :: AnnCoreExpr bndr bdee ann -> CoreExpr bndr bdee + +deAnnotate (_, AnnCoVar v) = CoVar v +deAnnotate (_, AnnCoLit lit) = CoLit lit +deAnnotate (_, AnnCoCon con tys args) = CoCon con tys args +deAnnotate (_, AnnCoPrim op tys args) = CoPrim op tys args +deAnnotate (_, AnnCoLam binders body) = CoLam binders (deAnnotate body) +deAnnotate (_, AnnCoTyLam tyvar body) = CoTyLam tyvar (deAnnotate body) +deAnnotate (_, AnnCoApp fun arg) = CoApp (deAnnotate fun) arg +deAnnotate (_, AnnCoTyApp fun ty) = CoTyApp (deAnnotate fun) ty +deAnnotate (_, AnnCoSCC lbl body) = CoSCC lbl (deAnnotate body) + +deAnnotate (_, AnnCoLet bind body) + = CoLet (deAnnBind bind) (deAnnotate body) + where + deAnnBind (AnnCoNonRec var rhs) = CoNonRec var (deAnnotate rhs) + deAnnBind (AnnCoRec pairs) = CoRec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +deAnnotate (_, AnnCoCase scrut alts) + = CoCase (deAnnotate scrut) (deAnnAlts alts) + where + deAnnAlts (AnnCoAlgAlts alts deflt) + = CoAlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts] + (deAnnDeflt deflt) + + deAnnAlts (AnnCoPrimAlts alts deflt) + = CoPrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts] + (deAnnDeflt deflt) + + deAnnDeflt AnnCoNoDefault = CoNoDefault + deAnnDeflt (AnnCoBindDefault var rhs) = CoBindDefault var (deAnnotate rhs) +\end{code} diff --git a/ghc/compiler/coreSyn/CoreFuns.hi b/ghc/compiler/coreSyn/CoreFuns.hi new file mode 100644 index 0000000..3cef698 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreFuns.hi @@ -0,0 +1,102 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreFuns where +import BasicLit(BasicLit) +import Class(Class) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(IdInfo) +import Maybes(Labda) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TyVarEnv(..)) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(UniqSM(..), Unique, UniqueSupply) +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type TyVarEnv a = UniqFM a +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSM a = UniqueSupply -> (UniqueSupply, a) +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +atomToExpr :: CoreAtom b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: CoreAtom u1) -> case u2 of { _ALG_ _ORIG_ CoreSyn CoVarAtom (u3 :: u1) -> _!_ _ORIG_ CoreSyn CoVar [u0, u1] [u3]; _ORIG_ CoreSyn CoLitAtom (u4 :: BasicLit) -> _!_ _ORIG_ CoreSyn CoLit [u0, u1] [u4]; _NO_DEFLT_ } _N_ #-} +bindersOf :: CoreBinding b a -> [b] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +escErrorMsg :: [Char] -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +exprSmallEnoughToDup :: CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +isWrapperFor :: CoreExpr Id Id -> Id -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +manifestlyBottom :: CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +manifestlyWHNF :: CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ #-} +mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetAny, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetNoUnboxed, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetUnboxedToCase, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-} +mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LSLL" _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: UniqueSupply) (u1 :: UniqFM (CoreExpr Id Id)) (u2 :: UniqFM UniType) (u3 :: CoreExpr Id Id) -> _APP_ _ORIG_ CoreFuns substCoreExprUS [ u1, u2, u3, u0 ] _N_ #-} +substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 3 _U_ 2222 _N_ _S_ "SLL" _N_ _N_ #-} +typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfCoreExpr :: CoreExpr Id Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/coreSyn/CoreFuns.lhs b/ghc/compiler/coreSyn/CoreFuns.lhs new file mode 100644 index 0000000..2f11ea3 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreFuns.lhs @@ -0,0 +1,1307 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CoreUtils]{Utility functions} + +These functions are re-exported by the various parameterisations of +@CoreSyn@. + +\begin{code} +#include "HsVersions.h" + +module CoreFuns ( + typeOfCoreExpr, typeOfCoreAlts, + + instCoreExpr, substCoreExpr, -- UNUSED: cloneCoreExpr, + substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS, + + instCoreBindings, + + bindersOf, + + mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, + mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, + mkCoLetrecAny, mkCoLetrecNoUnboxed, + mkCoLam, mkCoreIfThenElse, +-- mkCoApp, mkCoCon, mkCoPrim, -- no need to export + mkCoApps, + mkCoTyLam, mkCoTyApps, + mkErrorCoApp, escErrorMsg, + pairsFromCoreBinds, + mkFunction, atomToExpr, + digForLambdas, + exprSmallEnoughToDup, + manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs, + coreExprArity, + isWrapperFor, + maybeErrorApp, +--UNUSED: boilsDownToConApp, + nonErrorRHSs, + squashableDictishCcExpr, + + unTagBinders, unTagBindersAlts, + +#ifdef DPH + mkNonRecBinds, + isParCoreCaseAlternative, +#endif {- Data Parallel Haskell -} + + -- to make the interface self-sufficient... + CoreAtom, CoreExpr, Id, UniType, UniqueSupply, UniqSM(..), + IdEnv(..), UniqFM, Unique, TyVarEnv(..), Maybe + ) where + +--IMPORT_Trace -- ToDo: debugging only +import Pretty + +import AbsPrel ( mkFunTy, trueDataCon, falseDataCon, + eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID, + buildId, + boolTyCon, fragilePrimOp, + PrimOp(..), typeOfPrimOp, + PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +#ifdef DPH + , mkPodTy, mkPodizedPodNTy +#endif {- Data Parallel Haskell -} + ) +import AbsUniType +import BasicLit ( isNoRepLit, typeOfBasicLit, BasicLit(..) + IF_ATTACK_PRAGMAS(COMMA isLitLitLit) + ) +import CostCentre ( isDictCC, CostCentre ) +import Id +import IdEnv +import IdInfo +import Maybes ( catMaybes, maybeToBool, Maybe(..) ) +import Outputable +import CoreSyn +import PlainCore -- the main stuff we're defining functions for +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +#ifdef DPH +import TyCon ( getPodizedPodDimension ) +#endif {- Data Parallel Haskell -} +import TyVarEnv +import SplitUniq +import Unique -- UniqueSupply monadery used here +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[bindersOf]{Small but useful} +%* * +%************************************************************************ + + +\begin{code} +bindersOf :: CoreBinding bder bdee -> [bder] +bindersOf (CoNonRec binder _) = [binder] +bindersOf (CoRec pairs) = [binder | (binder,_) <- pairs] +\end{code} + + +%************************************************************************ +%* * +\subsection[typeOfCore]{Find the type of a Core atom/expression} +%* * +%************************************************************************ + +\begin{code} +typeOfCoreExpr :: PlainCoreExpr -> UniType +typeOfCoreExpr (CoVar var) = getIdUniType var +typeOfCoreExpr (CoLit lit) = typeOfBasicLit lit +typeOfCoreExpr (CoLet binds body) = typeOfCoreExpr body +typeOfCoreExpr (CoSCC label expr) = typeOfCoreExpr expr + +-- a CoCon is a fully-saturated application of a data constructor +typeOfCoreExpr (CoCon con tys _) + = applyTyCon (getDataConTyCon con) tys + +-- and, analogously, ... +typeOfCoreExpr expr@(CoPrim op tys args) + -- Note: CoPrims may be polymorphic, so we do de-forall'ing. + = let + op_ty = typeOfPrimOp op + op_tau_ty = foldl applyTy op_ty tys + in + funResultTy op_tau_ty (length args) + +typeOfCoreExpr (CoCase _ alts) = typeOfCoreAlts alts + -- Q: What if the one you happen to grab is an "error"? + -- A: NO problem. The type application of error to its type will give you + -- the answer. + +typeOfCoreExpr (CoLam binders expr) + = foldr (mkFunTy . getIdUniType) (typeOfCoreExpr expr) binders + +typeOfCoreExpr (CoTyLam tyvar expr) + = case (quantifyTy [tyvar] (typeOfCoreExpr expr)) of + (_, ty) -> ty -- not worried about the TyVarTemplates that come back + +typeOfCoreExpr expr@(CoApp _ _) = typeOfCoreApp expr +typeOfCoreExpr expr@(CoTyApp _ _) = typeOfCoreApp expr + +#ifdef DPH +typeOfCoreExpr (CoParCon con ctxt tys args) + = mkPodizedPodNTy ctxt (applyTyCon (getDataConTyCon con) tys) + +typeOfCoreExpr (CoZfExpr expr quals) + = mkPodTy (typeOfCoreExpr expr) + +typeOfCoreExpr (CoParComm _ expr _) + = typeOfCoreExpr expr +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +typeOfCoreApp application + = case (collectArgs application) of { (fun, args) -> + apply_args (typeOfCoreExpr fun) args + } + where + apply_args expr_ty [] = expr_ty + + apply_args fun_ty (TypeArg ty_arg : args) + = apply_args (applyTy fun_ty ty_arg) args + + apply_args fun_ty (ValArg val_arg : args) + = case (maybeUnpackFunTy fun_ty) of + Just (_, result_ty) -> apply_args result_ty args + + Nothing -> pprPanic "typeOfCoreApp:\n" + (ppAboves + [ppr PprDebug val_arg, + ppr PprDebug fun_ty, + ppr PprShowAll application]) +\end{code} + +\begin{code} +typeOfCoreAlts :: PlainCoreCaseAlternatives -> UniType +typeOfCoreAlts (CoAlgAlts [] deflt) = typeOfDefault deflt +typeOfCoreAlts (CoAlgAlts ((_,_,rhs1):_) _) = typeOfCoreExpr rhs1 + +typeOfCoreAlts (CoPrimAlts [] deflt) = typeOfDefault deflt +typeOfCoreAlts (CoPrimAlts ((_,rhs1):_) _) = typeOfCoreExpr rhs1 +#ifdef DPH +typeOfCoreAlts (CoParAlgAlts _ _ _ [] deflt) = typeOfDefault deflt +typeOfCoreAlts (CoParAlgAlts _ _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1 + +typeOfCoreAlts (CoParPrimAlts _ _ [] deflt) = typeOfDefault deflt +typeOfCoreAlts (CoParPrimAlts _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1 +#endif {- Data Parallel Haskell -} + +typeOfDefault CoNoDefault = panic "typeOfCoreExpr:CoCase:typeOfDefault" +typeOfDefault (CoBindDefault _ rhs) = typeOfCoreExpr rhs +\end{code} + +%************************************************************************ +%* * +\subsection[CoreFuns-instantiate]{Instantiating core expressions: interfaces} +%* * +%************************************************************************ + +These subst/inst functions {\em must not} use splittable +UniqueSupplies! (yet) + +All of the desired functions are done by one piece of code, which +carries around a little (monadised) state (a @UniqueSupply@). +Meanwhile, here is what the outside world sees (NB: @UniqueSupply@ +passed in and out): +\begin{code} +{- UNUSED: +cloneCoreExpr :: UniqueSupply + -> PlainCoreExpr -- template + -> (UniqueSupply, PlainCoreExpr) + +cloneCoreExpr us expr = instCoreExpr us expr +-} + +-------------------- + +instCoreExpr :: UniqueSupply + -> PlainCoreExpr + -> (UniqueSupply, PlainCoreExpr) + +instCoreExpr us expr + = initUs us (do_CoreExpr nullIdEnv nullTyVarEnv expr) + +instCoreBindings :: UniqueSupply + -> [PlainCoreBinding] + -> (UniqueSupply, [PlainCoreBinding]) + +instCoreBindings us binds + = initUs us (do_CoreBindings nullIdEnv nullTyVarEnv binds) + +-------------------- + +substCoreExpr :: UniqueSupply + -> ValEnv + -> TypeEnv -- TyVar=>UniType + -> PlainCoreExpr + -> (UniqueSupply, PlainCoreExpr) + +substCoreExpr us venv tenv expr + = initUs us (substCoreExprUS venv tenv expr) + +-- we are often already in a UniqSM world, so here are the interfaces +-- for that: +{- UNUSED: +cloneCoreExprUS :: PlainCoreExpr{-template-} -> UniqSM PlainCoreExpr + +cloneCoreExprUS = instCoreExprUS + +instCoreExprUS :: PlainCoreExpr -> UniqSM PlainCoreExpr + +instCoreExprUS expr = do_CoreExpr nullIdEnv nullTyVarEnv expr +-} + +-------------------- + +substCoreExprUS :: ValEnv + -> TypeEnv -- TyVar=>UniType + -> PlainCoreExpr + -> UniqSM PlainCoreExpr + +substCoreExprUS venv tenv expr + -- if the envs are empty, then avoid doing anything + = if (isNullIdEnv venv && isNullTyVarEnv tenv) then + returnUs expr + else + do_CoreExpr venv tenv expr +\end{code} + +%************************************************************************ +%* * +\subsection[CoreFuns-inst-exprs]{Actual expression-instantiating code} +%* * +%************************************************************************ + +The equiv code for @UniTypes@ is in @UniTyFuns@. + +Because binders aren't necessarily unique: we don't do @plusEnvs@ +(which check for duplicates); rather, we use the shadowing version, +@growIdEnv@ (and shorthand @addOneToIdEnv@). + +\begin{code} +type ValEnv = IdEnv PlainCoreExpr + +do_CoreBinding :: ValEnv + -> TypeEnv + -> PlainCoreBinding + -> UniqSM (PlainCoreBinding, ValEnv) + +do_CoreBinding venv tenv (CoNonRec binder rhs) + = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs -> + + dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) -> + -- now plug new bindings into envs + let new_venv = addOneToIdEnv venv old new in + + returnUs (CoNonRec new_binder new_rhs, new_venv) + +do_CoreBinding venv tenv (CoRec binds) + = -- for letrec, we plug in new bindings BEFORE cloning rhss + mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) -> + let new_venv = growIdEnvList venv new_maps in + + mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss -> + returnUs (CoRec (new_binders `zip` new_rhss), new_venv) + where + binders = map fst binds + rhss = map snd binds +\end{code} + +@do_CoreBindings@ takes into account the semantics of a list of +@CoreBindings@---things defined early in the list are visible later in +the list, but not vice versa. + +\begin{code} +do_CoreBindings :: ValEnv + -> TypeEnv + -> [PlainCoreBinding] + -> UniqSM [PlainCoreBinding] + +do_CoreBindings venv tenv [] = returnUs [] +do_CoreBindings venv tenv (b:bs) + = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) -> + do_CoreBindings new_venv tenv bs `thenUs` \ new_bs -> + returnUs (new_b : new_bs) +\end{code} + +\begin{code} +do_CoreAtom :: ValEnv + -> TypeEnv + -> PlainCoreAtom + -> UniqSM PlainCoreExpr + +do_CoreAtom venv tenv a@(CoLitAtom lit) = returnUs (CoLit lit) + +do_CoreAtom venv tenv orig_a@(CoVarAtom v) + = returnUs ( + case (lookupIdEnv venv v) of + Nothing -> --false:ASSERT(toplevelishId v) + CoVar v + Just expr -> expr + ) +\end{code} + +\begin{code} +do_CoreExpr :: ValEnv + -> TypeEnv + -> PlainCoreExpr + -> UniqSM PlainCoreExpr + +do_CoreExpr venv tenv orig_expr@(CoVar var) + = returnUs ( + case (lookupIdEnv venv var) of + Nothing -> --false:ASSERT(toplevelishId var) (SIGH) + orig_expr + Just expr -> expr + ) + +do_CoreExpr venv tenv e@(CoLit _) = returnUs e + +do_CoreExpr venv tenv (CoCon con ts as) + = let + new_ts = map (applyTypeEnvToTy tenv) ts + in + mapUs (do_CoreAtom venv tenv) as `thenUs` \ new_as -> + mkCoCon con new_ts new_as + +do_CoreExpr venv tenv (CoPrim op tys as) + = let + new_tys = map (applyTypeEnvToTy tenv) tys + in + mapUs (do_CoreAtom venv tenv) as `thenUs` \ new_as -> + do_PrimOp op `thenUs` \ new_op -> + mkCoPrim new_op new_tys new_as + where + do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty) + = let + new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys + new_result_ty = applyTypeEnvToTy tenv result_ty + in + returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty) + + do_PrimOp other_op = returnUs other_op + +do_CoreExpr venv tenv (CoLam binders expr) + = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) -> + let new_venv = growIdEnvList venv new_maps in + do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> + returnUs (CoLam new_binders new_expr) + +do_CoreExpr venv tenv (CoTyLam tyvar expr) + = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) -> + let + new_tenv = addOneToTyVarEnv tenv old new + in + do_CoreExpr venv new_tenv expr `thenUs` \ new_expr -> + returnUs (CoTyLam new_tyvar new_expr) + +do_CoreExpr venv tenv (CoApp expr atom) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + do_CoreAtom venv tenv atom `thenUs` \ new_atom -> + mkCoApp new_expr new_atom + +do_CoreExpr venv tenv (CoTyApp expr ty) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + let + new_ty = applyTypeEnvToTy tenv ty + in + returnUs (CoTyApp new_expr new_ty) + +do_CoreExpr venv tenv (CoCase expr alts) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + do_alts venv tenv alts `thenUs` \ new_alts -> + returnUs (CoCase new_expr new_alts) + where + do_alts venv tenv (CoAlgAlts alts deflt) + = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts -> + do_default venv tenv deflt `thenUs` \ new_deflt -> + returnUs (CoAlgAlts new_alts new_deflt) + where + do_boxed_alt venv tenv (con, binders, expr) + = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) -> + let new_venv = growIdEnvList venv new_vmaps in + do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> + returnUs (con, new_binders, new_expr) + + + do_alts venv tenv (CoPrimAlts alts deflt) + = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts -> + do_default venv tenv deflt `thenUs` \ new_deflt -> + returnUs (CoPrimAlts new_alts new_deflt) + where + do_unboxed_alt venv tenv (lit, expr) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + returnUs (lit, new_expr) +#ifdef DPH + do_alts venv tenv (CoParAlgAlts tycon dim params alts deflt) + = mapAndUnzipUs (dup_binder tenv) params `thenUs` \ (new_params,new_vmaps) -> + let new_venv = growIdEnvList venv new_vmaps in + mapUs (do_boxed_alt new_venv tenv) alts + `thenUs` \ new_alts -> + do_default venv tenv deflt `thenUs` \ new_deflt -> + returnUs (CoParAlgAlts tycon dim new_params new_alts new_deflt) + where + do_boxed_alt venv tenv (con, expr) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + returnUs (con, new_expr) + + do_alts venv tenv (CoParPrimAlts tycon dim alts deflt) + = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts -> + do_default venv tenv deflt `thenUs` \ new_deflt -> + returnUs (CoParPrimAlts tycon dim new_alts new_deflt) + where + do_unboxed_alt venv tenv (lit, expr) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + returnUs (lit, new_expr) +#endif {- Data Parallel Haskell -} + + do_default venv tenv CoNoDefault = returnUs CoNoDefault + + do_default venv tenv (CoBindDefault binder expr) + = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) -> + let new_venv = addOneToIdEnv venv old new in + do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> + returnUs (CoBindDefault new_binder new_expr) + +do_CoreExpr venv tenv (CoLet core_bind expr) + = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) -> + -- and do the body of the let + do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> + returnUs (CoLet new_bind new_expr) + +do_CoreExpr venv tenv (CoSCC label expr) + = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> + returnUs (CoSCC label new_expr) + +#ifdef DPH +do_CoreExpr venv tenv (CoParCon con ctxt ts es) + = let + new_ts = map (applyTypeEnvToTy tenv) ts + in + mapUs (do_CoreExpr venv tenv) es) `thenUs` \ new_es -> + returnUs (CoParCon con ctxt new_ts new_es) + +do_CoreExpr venv tenv (CoZfExpr expr quals) + = do_CoreParQuals venv tenv quals `thenUs` \ (quals',venv') -> + do_CoreExpr venv' tenv expr `thenUs` \ expr' -> + returnUs (CoZfExpr expr' quals') + +do_CoreExpr venv tenv (CoParComm dim expr comm) + = do_CoreExpr venv tenv expr `thenUs` \ expr' -> + do_ParComm comm `thenUs` \ comm' -> + returnUs (CoParComm dim expr' comm') + where + do_ParComm (CoParSend exprs) + = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' -> + returnUs (CoParSend exprs') + do_ParComm (CoParFetch exprs) + = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' -> + returnUs (CoParFetch exprs') + do_ParComm (CoToPodized) + = returnUs (CoToPodized) + do_ParComm (CoFromPodized) + = returnUs (CoFromPodized) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifdef DPH +do_CoreParQuals :: ValEnv + -> TypeEnv + -> PlainCoreParQuals + -> UniqSM (PlainCoreParQuals, ValEnv) + +do_CoreParQuals venv tenv (CoAndQuals l r) + = do_CoreParQuals venv tenv r `thenUs` \ (r',right_venv) -> + do_CoreParQuals right_venv tenv l `thenUs` \ (l',left_env) -> + returnUs (CoAndQuals l' r',left_env) + +do_CoreParQuals venv tenv (CoParFilter expr) + = do_CoreExpr venv tenv expr `thenUs` \ expr' -> + returnUs (CoParFilter expr',venv)) + +do_CoreParQuals venv tenv (CoDrawnGen binders binder expr) + = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (newBs,newMs) -> + let new_venv = growIdEnvList venv newMs in + dup_binder tenv binder `thenUs` \ (newB,(old,new)) -> + let new_venv' = addOneToIdEnv new_venv old new in + do_CoreExpr new_venv' tenv expr `thenUs` \ new_expr -> + returnUs (CoDrawnGen newBs newB new_expr,new_venv') + +do_CoreParQuals venv tenv (CoIndexGen exprs binder expr) + = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ new_exprs -> + dup_binder tenv binder `thenUs` \ (newB,(old,new)) -> + let new_venv = addOneToIdEnv venv old new in + do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> + returnUs (CoIndexGen new_exprs newB new_expr,new_venv) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, UniType)) +dup_tyvar tyvar + = getUnique `thenUs` \ uniq -> + let new_tyvar = cloneTyVar tyvar uniq in + returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar)) + +-- same thing all over again -------------------- + +dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, PlainCoreExpr)) +dup_binder tenv b + = if (toplevelishId b) then + -- binder is "top-level-ish"; -- it should *NOT* be renamed + -- ToDo: it's unsavoury that we return something to heave in env + returnUs (b, (b, CoVar b)) + + else -- otherwise, the full business + getUnique `thenUs` \ uniq -> + let + new_b1 = mkIdWithNewUniq b uniq + new_b2 = applyTypeEnvToId tenv new_b1 + in + returnUs (new_b2, (b, CoVar new_b2)) +\end{code} + +%************************************************************************ +%* * +\subsection[mk_CoreExpr_bits]{Routines to manufacture bits of @CoreExpr@} +%* * +%************************************************************************ + +When making @CoLets@, we may want to take evasive action if the thing +being bound has unboxed type. We have different variants ... + +@mkCoLet(s|rec)Any@ let-binds any binding, regardless of type +@mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings +@mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case + (unboxed bindings in a letrec are still prohibited) + +\begin{code} +mkCoLetAny :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr + +mkCoLetAny bind@(CoRec binds) body + = mkCoLetrecAny binds body +mkCoLetAny bind@(CoNonRec binder rhs) body + = case body of + CoVar binder2 | binder `eqId` binder2 + -> rhs -- hey, I have the rhs + other + -> CoLet bind body + +mkCoLetsAny [] expr = expr +mkCoLetsAny binds expr = foldr mkCoLetAny expr binds + +mkCoLetrecAny :: [(Id, PlainCoreExpr)] -- bindings + -> PlainCoreExpr -- body + -> PlainCoreExpr -- result + +mkCoLetrecAny [] body = body +mkCoLetrecAny binds body + = CoLet (CoRec binds) body +\end{code} + +\begin{code} +mkCoLetNoUnboxed :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr + +mkCoLetNoUnboxed bind@(CoRec binds) body + = mkCoLetrecNoUnboxed binds body +mkCoLetNoUnboxed bind@(CoNonRec binder rhs) body + = ASSERT (not (isUnboxedDataType (getIdUniType binder))) + case body of + CoVar binder2 | binder `eqId` binder2 + -> rhs -- hey, I have the rhs + other + -> CoLet bind body + +mkCoLetsNoUnboxed [] expr = expr +mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds + +mkCoLetrecNoUnboxed :: [(Id, PlainCoreExpr)] -- bindings + -> PlainCoreExpr -- body + -> PlainCoreExpr -- result + +mkCoLetrecNoUnboxed [] body = body +mkCoLetrecNoUnboxed binds body + = ASSERT (all is_boxed_bind binds) + CoLet (CoRec binds) body + where + is_boxed_bind (binder, rhs) + = (not . isUnboxedDataType . getIdUniType) binder +\end{code} + +\begin{code} +mkCoLetUnboxedToCase :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr + +mkCoLetUnboxedToCase bind@(CoRec binds) body + = mkCoLetrecNoUnboxed binds body +mkCoLetUnboxedToCase bind@(CoNonRec binder rhs) body + = case body of + CoVar binder2 | binder `eqId` binder2 + -> rhs -- hey, I have the rhs + other + -> if (not (isUnboxedDataType (getIdUniType binder))) then + CoLet bind body -- boxed... + else +#ifdef DPH + let (tycon,_,_) = getUniDataTyCon (getIdUniType binder) in + if isPodizedPodTyCon tycon + then CoCase rhs + (CoParPrimAlts tycon (getPodizedPodDimension tycon) [] + (CoBindDefault binder body)) + else +#endif {- DPH -} + CoCase rhs -- unboxed... + (CoPrimAlts [] + (CoBindDefault binder body)) + +mkCoLetsUnboxedToCase [] expr = expr +mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds +\end{code} + +Clump CoLams together if possible; friendlier to the code generator. + +\begin{code} +mkCoLam :: [binder] -> CoreExpr binder bindee -> CoreExpr binder bindee +mkCoLam [] body = body +mkCoLam binders body + = case (digForLambdas body) of { (tyvars, body_binders, body_expr) -> + if not (null tyvars) then + pprTrace "Inner /\\'s:" (ppr PprDebug tyvars) + (CoLam binders (mkCoTyLam tyvars (mkCoLam body_binders body_expr))) + else + CoLam (binders ++ body_binders) body_expr + } + +mkCoTyLam :: [TyVar] -> CoreExpr binder bindee -> CoreExpr binder bindee +mkCoTyLam tvs body = foldr CoTyLam body tvs + +mkCoTyApps :: CoreExpr binder bindee -> [UniType] -> CoreExpr binder bindee +mkCoTyApps expr tys = foldl mkCoTyApp expr tys +\end{code} + +\begin{code} +mkCoreIfThenElse (CoVar bool) then_expr else_expr + | bool `eqId` trueDataCon = then_expr + | bool `eqId` falseDataCon = else_expr + +mkCoreIfThenElse guard then_expr else_expr + = CoCase guard + (CoAlgAlts [ (trueDataCon, [], then_expr), + (falseDataCon, [], else_expr) ] + CoNoDefault ) +\end{code} + +\begin{code} +mkErrorCoApp :: UniType -> Id -> String -> PlainCoreExpr + +mkErrorCoApp ty str_var error_msg +--OLD: | not (isPrimType ty) + = CoLet (CoNonRec str_var (CoLit (NoRepStr (_PK_ error_msg)))) ( + CoApp (CoTyApp (CoVar pAT_ERROR_ID) ty) (CoVarAtom str_var)) +{- TOO PARANOID: removed 95/02 WDP + | otherwise + -- for now, force the user to write their own suitably-typed error msg + = error (ppShow 80 (ppAboves [ + ppStr "ERROR: can't generate a pattern-matching error message", + ppStr " when a primitive type is involved.", + ppCat [ppStr "Type:", ppr PprDebug ty], + ppCat [ppStr "Var :", ppr PprDebug str_var], + ppCat [ppStr "Msg :", ppStr error_msg] + ])) +-} + +escErrorMsg [] = [] +escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs +escErrorMsg (x:xs) = x : escErrorMsg xs +\end{code} + +For making @CoApps@ and @CoLets@, we must take appropriate evasive +action if the thing being bound has unboxed type. @mkCoApp@ requires +a name supply to do its work. Other-monad code will call @mkCoApp@ +through its own interface function (e.g., the desugarer uses +@mkCoAppDs@). + +@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the +arguments-must-be-atoms constraint. + +\begin{code} +mkCoApp :: PlainCoreExpr -> PlainCoreExpr -> UniqSM PlainCoreExpr + +mkCoApp e1 (CoVar v) = returnUs (CoApp e1 (CoVarAtom v)) +mkCoApp e1 (CoLit l) = returnUs (CoApp e1 (CoLitAtom l)) +mkCoApp e1 e2 + = let + e2_ty = typeOfCoreExpr e2 + in + getUnique `thenUs` \ uniq -> + let + new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc + in + returnUs ( + mkCoLetUnboxedToCase (CoNonRec new_var e2) + (CoApp e1 (CoVarAtom new_var)) + ) +\end{code} + +\begin{code} +mkCoCon :: Id -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr +mkCoPrim :: PrimOp -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr + +mkCoCon con tys args = mkCoThing (CoCon con) tys args +mkCoPrim op tys args = mkCoThing (CoPrim op) tys args + +mkCoThing thing tys args + = mapAndUnzipUs expr_to_atom args `thenUs` \ (atoms, maybe_binds) -> + returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing tys atoms)) + where + expr_to_atom :: PlainCoreExpr + -> UniqSM (PlainCoreAtom, Maybe PlainCoreBinding) + + expr_to_atom (CoVar v) = returnUs (CoVarAtom v, Nothing) + expr_to_atom (CoLit l) = returnUs (CoLitAtom l, Nothing) + expr_to_atom other_expr + = let + e_ty = typeOfCoreExpr other_expr + in + getUnique `thenUs` \ uniq -> + let + new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc + new_atom = CoVarAtom new_var + in + returnUs (new_atom, Just (CoNonRec new_var other_expr)) +\end{code} + +\begin{code} +atomToExpr :: CoreAtom bindee -> CoreExpr binder bindee + +atomToExpr (CoVarAtom v) = CoVar v +atomToExpr (CoLitAtom lit) = CoLit lit +\end{code} + +\begin{code} +pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)] + +pairsFromCoreBinds [] = [] +pairsFromCoreBinds ((CoNonRec b e) : bs) = (b,e) : (pairsFromCoreBinds bs) +pairsFromCoreBinds ((CoRec pairs) : bs) = pairs ++ (pairsFromCoreBinds bs) +\end{code} + +\begin{code} +#ifdef DPH +mkNonRecBinds :: [(a, CoreExpr a b)] -> [CoreBinding a b] +mkNonRecBinds xs = [ CoNonRec b e | (b,e) <- xs ] + +isParCoreCaseAlternative :: CoreCaseAlternatives a b -> Bool +{- +isParCoreCaseAlternative (CoParAlgAlts _ _ _ _ _) = True +isParCoreCaseAlternative (CoParPrimAlts _ _ _ _) = True +-} +isParCoreCaseAlternative _ = False +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +mkFunction tys args e + = foldr CoTyLam (mkCoLam args e) tys + +mkCoApps :: PlainCoreExpr -> [PlainCoreExpr] -> UniqSM PlainCoreExpr + +mkCoApps fun [] = returnUs fun +mkCoApps fun (arg:args) + = mkCoApp fun arg `thenUs` \ new_fun -> + mkCoApps new_fun args +\end{code} + +We often want to strip off leading \tr{/\}-bound @TyVars@ and +\tr{\}-bound binders, before we get down to business. @digForLambdas@ +is your friend. + +\begin{code} +digForLambdas :: CoreExpr bndr bdee -> ([TyVar], [bndr], CoreExpr bndr bdee) + +digForLambdas (CoTyLam tyvar body) + = let + (tyvars, args, final_body) = digForLambdas body + in + (tyvar:tyvars, args, final_body) + +digForLambdas other + = let + (args, body) = dig_in_lambdas other + in + ([], args, body) + where + dig_in_lambdas (CoLam args_here body) + = let + (args, final_body) = dig_in_lambdas body + in + (args_here ++ args, final_body) + +#ifdef DEBUG + dig_in_lambdas body@(CoTyLam ty expr) + = trace "Inner /\\'s when digging" ([],body) +#endif + + dig_in_lambdas body + = ([], body) +\end{code} + +\begin{code} +exprSmallEnoughToDup :: CoreExpr binder Id -> Bool + +exprSmallEnoughToDup (CoCon _ _ _) = True -- Could check # of args +exprSmallEnoughToDup (CoPrim op _ _) = not (fragilePrimOp op) -- Could check # of args +exprSmallEnoughToDup (CoLit lit) = not (isNoRepLit lit) + +exprSmallEnoughToDup expr -- for now, just: applied to + = case (collectArgs expr) of { (fun, args) -> + case fun of + CoVar v -> v /= buildId && length args <= 6 -- or 10 or 1 or 4 or anything smallish. + _ -> False + } +\end{code} +Question (ADR): What is the above used for? Is a _ccall_ really small +enough? + +@manifestlyWHNF@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form. It isn't a disaster if it +errs on the conservative side (returning \tr{False})---I've probably +left something out... [WDP] + +\begin{code} +manifestlyWHNF :: CoreExpr bndr Id -> Bool + +manifestlyWHNF (CoVar _) = True +manifestlyWHNF (CoLit _) = True +manifestlyWHNF (CoCon _ _ _) = True -- ToDo: anything for CoPrim? +manifestlyWHNF (CoLam _ _) = True +manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e +manifestlyWHNF (CoSCC _ e) = manifestlyWHNF e +manifestlyWHNF (CoLet _ e) = False +manifestlyWHNF (CoCase _ _) = False + +manifestlyWHNF other_expr -- look for manifest partial application + = case (collectArgs other_expr) of { (fun, args) -> + case fun of + CoVar f -> let + num_val_args = length [ a | (ValArg a) <- args ] + in + num_val_args == 0 || -- Just a type application of + -- a variable (f t1 t2 t3) + -- counts as WHNF + case (arityMaybe (getIdArity f)) of + Nothing -> False + Just arity -> num_val_args < arity + + _ -> False + } +\end{code} + +@manifestlyBottom@ looks at a Core expression and returns \tr{True} if +it is obviously bottom, that is, it will certainly return bottom at +some point. It isn't a disaster if it errs on the conservative side +(returning \tr{False}). + +\begin{code} +manifestlyBottom :: CoreExpr bndr Id -> Bool + +manifestlyBottom (CoVar v) = isBottomingId v +manifestlyBottom (CoLit _) = False +manifestlyBottom (CoCon _ _ _) = False +manifestlyBottom (CoPrim _ _ _)= False +manifestlyBottom (CoLam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo +manifestlyBottom (CoTyLam _ e) = manifestlyBottom e +manifestlyBottom (CoSCC _ e) = manifestlyBottom e +manifestlyBottom (CoLet _ e) = manifestlyBottom e + +manifestlyBottom (CoCase e a) + = manifestlyBottom e + || (case a of + CoAlgAlts alts def -> all mbalg alts && mbdef def + CoPrimAlts alts def -> all mbprim alts && mbdef def + ) + where + mbalg (_,_,e') = manifestlyBottom e' + + mbprim (_,e') = manifestlyBottom e' + + mbdef CoNoDefault = True + mbdef (CoBindDefault _ e') = manifestlyBottom e' + +manifestlyBottom other_expr -- look for manifest partial application + = case (collectArgs other_expr) of { (fun, args) -> + case fun of + CoVar f | isBottomingId f -> True -- Application of a function which + -- always gives bottom; we treat this as + -- a WHNF, because it certainly doesn't + -- need to be shared! + _ -> False + } +\end{code} + +UNUSED: @manifestWHNFArgs@ guarantees that an expression can absorb n args +before it ceases to be a manifest WHNF. E.g., +\begin{verbatim} + (\x->x) gives 1 + (\x -> +Int x) gives 2 +\end{verbatim} + +The function guarantees to err on the side of conservatism: the +conservative result is (Just 0). + +An applications of @error@ are special, because it can absorb as many +arguments as you care to give it. For this special case we return Nothing. + +\begin{code} +{- UNUSED: +manifestWHNFArgs :: CoreExpr bndr Id + -> Maybe Int -- Nothing indicates applicn of "error" + +manifestWHNFArgs expr + = my_trace (man expr) + where + man (CoLit _) = Just 0 + man (CoCon _ _ _) = Just 0 + man (CoLam bs e) = man e `plus_args` length bs + man (CoApp e _) = man e `minus_args` 1 + man (CoTyLam _ e) = man e + man (CoSCC _ e) = man e + man (CoLet _ e) = man e + + man (CoVar f) + | isBottomingId f = Nothing + | otherwise = case (arityMaybe (getIdArity f)) of + Nothing -> Just 0 + Just arity -> Just arity + + man other = Just 0 -- Give up on case + + plus_args, minus_args :: Maybe Int -> Int -> Maybe Int + + plus_args Nothing m = Nothing + plus_args (Just n) m = Just (n+m) + + minus_args Nothing m = Nothing + minus_args (Just n) m = Just (n-m) + + my_trace n = n + -- if n == 0 then n + -- else pprTrace "manifest:" (ppCat [ppr PprDebug fun, + -- ppr PprDebug args, ppStr "=>", ppInt n]) + -- n +-} +\end{code} + +\begin{code} +coreExprArity + :: (Id -> Maybe (CoreExpr bndr Id)) + -> CoreExpr bndr Id + -> Int +coreExprArity f (CoLam bnds expr) = coreExprArity f expr + length (bnds) +coreExprArity f (CoTyLam _ expr) = coreExprArity f expr +coreExprArity f (CoApp expr arg) = max (coreExprArity f expr - 1) 0 +coreExprArity f (CoTyApp expr _) = coreExprArity f expr +coreExprArity f (CoVar v) = max further info + where + further + = case f v of + Nothing -> 0 + Just expr -> coreExprArity f expr + info = case (arityMaybe (getIdArity v)) of + Nothing -> 0 + Just arity -> arity +coreExprArity f _ = 0 +\end{code} + +@isWrapperFor@: we want to see exactly: +\begin{verbatim} +/\ ... \ args -> case of ... -> case of ... -> wrkr +\end{verbatim} + +Probably a little too HACKY [WDP]. + +\begin{code} +isWrapperFor :: PlainCoreExpr -> Id -> Bool + +expr `isWrapperFor` var + = case (digForLambdas expr) of { (_, args, body) -> -- lambdas off the front + unravel_casing args body + --NO, THANKS: && not (null args) + } + where + var's_worker = getWorkerId (getIdStrictness var) + + is_elem = isIn "isWrapperFor" + + -------------- + unravel_casing case_ables (CoCase scrut alts) + = case (collectArgs scrut) of { (fun, args) -> + case fun of + CoVar scrut_var -> let + answer = + scrut_var /= var && all (doesn't_mention var) args + && scrut_var `is_elem` case_ables + && unravel_alts case_ables alts + in + answer + + _ -> False + } + + unravel_casing case_ables other_expr + = case (collectArgs other_expr) of { (fun, args) -> + case fun of + CoVar wrkr -> let + answer = + -- DOESN'T WORK: wrkr == var's_worker + wrkr /= var + && isWorkerId wrkr + && all (doesn't_mention var) args + && all (only_from case_ables) args + in + answer + + _ -> False + } + + -------------- + unravel_alts case_ables (CoAlgAlts [(_,params,rhs)] CoNoDefault) + = unravel_casing (params ++ case_ables) rhs + unravel_alts case_ables other = False + + ------------------------- + doesn't_mention var (ValArg (CoVarAtom v)) = v /= var + doesn't_mention var other = True + + ------------------------- + only_from case_ables (ValArg (CoVarAtom v)) = v `is_elem` case_ables + only_from case_ables other = True +\end{code} + +All the following functions operate on binders, perform a uniform +transformation on them; ie. the function @(\ x -> (x,False))@ +annotates all binders with False. + +\begin{code} +unTagBinders :: CoreExpr (Id,tag) bdee -> CoreExpr Id bdee +unTagBinders e = bop_expr fst e + +unTagBindersAlts :: CoreCaseAlternatives (Id,tag) bdee -> CoreCaseAlternatives Id bdee +unTagBindersAlts alts = bop_alts fst alts +\end{code} + +\begin{code} +bop_expr :: (a -> b) -> (CoreExpr a c) -> CoreExpr b c + +bop_expr f (CoVar b) = CoVar b +bop_expr f (CoLit lit) = CoLit lit +bop_expr f (CoCon id u atoms) = CoCon id u atoms +bop_expr f (CoPrim op tys atoms)= CoPrim op tys atoms +bop_expr f (CoLam binders expr) = CoLam [ f x | x <- binders ] (bop_expr f expr) +bop_expr f (CoTyLam ty expr) = CoTyLam ty (bop_expr f expr) +bop_expr f (CoApp expr atom) = CoApp (bop_expr f expr) atom +bop_expr f (CoTyApp expr ty) = CoTyApp (bop_expr f expr) ty +bop_expr f (CoSCC label expr) = CoSCC label (bop_expr f expr) +bop_expr f (CoLet bind expr) = CoLet (bop_bind f bind) (bop_expr f expr) +bop_expr f (CoCase expr alts) + = CoCase (bop_expr f expr) (bop_alts f alts) + +bop_bind f (CoNonRec b e) = CoNonRec (f b) (bop_expr f e) +bop_bind f (CoRec pairs) = CoRec [(f b, bop_expr f e) | (b, e) <- pairs] + +bop_alts f (CoAlgAlts alts deflt) + = CoAlgAlts [ (con, [f b | b <- binders], bop_expr f e) + | (con, binders, e) <- alts ] + (bop_deflt f deflt) + +bop_alts f (CoPrimAlts alts deflt) + = CoPrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ] + (bop_deflt f deflt) + +bop_deflt f (CoNoDefault) = CoNoDefault +bop_deflt f (CoBindDefault b expr) = CoBindDefault (f b) (bop_expr f expr) + +#ifdef DPH +bop_expr f (CoZfExpr expr quals) + = CoZfExpr (bop_expr f expr) (bop_quals quals) + where + bop_quals (CoAndQuals l r) = CoAndQuals (bop_quals l) (bop_quals r) + bop_quals (CoParFilter e) = CoParFilter (bop_expr f e) + bop_quals (CoDrawnGen bs b e) = CoDrawnGen (map f bs) (f b) (bop_expr f e) + bop_quals (CoIndexGen es b e) = CoIndexGen (map (bop_expr f) es) (f b) + (bop_expr f e) + +bop_expr f (CoParCon con ctxt tys args) + = CoParCon con ctxt tys (map (bop_expr f) args) + +bop_expr f (CoParComm ctxt e comm) + = CoParComm ctxt (bop_expr f e) (bop_comm comm) + where + bop_comm (CoParSend es) = CoParSend (map (bop_expr f) es) + bop_comm (CoParFetch es) = CoParFetch (map (bop_expr f) es) + bop_comm (CoToPodized) = CoToPodized + bop_comm (CoFromPodized) = CoFromPodized +#endif {- DPH -} +\end{code} + +OLD (but left here because of the nice example): @singleAlt@ checks +whether a bunch of case alternatives is actually just one alternative. +It specifically {\em ignores} alternatives which consist of just a +call to @error@, because they won't result in any code duplication. + +Example: +\begin{verbatim} + case (case of + True -> + False -> error "Foo") of + + +===> + + case of + True -> case of + + False -> case error "Foo" of + + +===> + + case of + True -> case of + + False -> error "Foo" +\end{verbatim} +Notice that the \tr{} don't get duplicated. + +\begin{code} +{- UNUSED: +boilsDownToConApp :: CoreExpr bndr bdee -> Bool -- Looks through lets + -- ToDo: could add something for NoRep literals... + +boilsDownToConApp (CoCon _ _ _) = True +boilsDownToConApp (CoTyLam _ e) = boilsDownToConApp e +boilsDownToConApp (CoTyApp e _) = boilsDownToConApp e +boilsDownToConApp (CoLet _ e) = boilsDownToConApp e +boilsDownToConApp other = False +-} +\end{code} + +\begin{code} +nonErrorRHSs :: CoreCaseAlternatives binder Id -> [CoreExpr binder Id] + +nonErrorRHSs alts = filter not_error_app (find_rhss alts) + where + find_rhss (CoAlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt + find_rhss (CoPrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt + + deflt_rhs CoNoDefault = [] + deflt_rhs (CoBindDefault _ rhs) = [rhs] + + not_error_app rhs = case maybeErrorApp rhs Nothing of + Just _ -> False + Nothing -> True +\end{code} + +maybeErrorApp checkes whether an expression is of the form + + error ty args + +If so, it returns + + Just (error ty' args) + +where ty' is supplied as an argument to maybeErrorApp. + +Here's where it is useful: + + case (error ty "Foo" e1 e2) of + ===> + error ty' "Foo" + +where ty' is the type of any of the alternatives. +You might think this never occurs, but see the comments on +the definition of @singleAlt@. + +Note: we *avoid* the case where ty' might end up as a +primitive type: this is very uncool (totally wrong). + +NOTICE: in the example above we threw away e1 and e2, but +not the string "Foo". How did we know to do that? + +Answer: for now anyway, we only handle the case of a function +whose type is of form + + bottomingFn :: forall a. t1 -> ... -> tn -> a + ^---------------------^ NB! + +Furthermore, we only count a bottomingApp if the function is +applied to more than n args. If so, we transform: + + bottomingFn ty e1 ... en en+1 ... em +to + bottomingFn ty' e1 ... en + +That is, we discard en+1 .. em + +\begin{code} +maybeErrorApp :: CoreExpr bndr Id -- Expr to look at + -> Maybe UniType -- Just ty => a result type *already cloned*; + -- Nothing => don't know result ty; we + -- *pretend* that the result ty won't be + -- primitive -- somebody later must + -- ensure this. + -> Maybe (CoreExpr bndr Id) + +maybeErrorApp expr result_ty_maybe + = case collectArgs expr of + (CoVar fun, (TypeArg ty : other_args)) + | isBottomingId fun + && maybeToBool result_ty_maybe -- we *know* the result type + -- (otherwise: live a fairy-tale existence...) + && not (isPrimType result_ty) -> + case splitType (getIdUniType fun) of + ([tyvar_tmpl], [], tau_ty) -> + case (splitTyArgs tau_ty) of { (arg_tys, res_ty) -> + let + n_args_to_keep = length arg_tys + args_to_keep = take n_args_to_keep other_args + in + if res_ty == mkTyVarTemplateTy tyvar_tmpl && + n_args_to_keep <= length other_args + then + -- Phew! We're in business + Just (applyToArgs (CoVar fun) + (TypeArg result_ty : args_to_keep)) + else + Nothing + } + + other -> -- Function type wrong shape + Nothing + other -> Nothing + where + Just result_ty = result_ty_maybe +\end{code} + +\begin{code} +squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool + +squashableDictishCcExpr cc expr + = if not (isDictCC cc) then + False -- that was easy... + else + squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier + where + squashable (CoVar _) = True + squashable (CoTyApp f _) = squashable f + squashable (CoCon _ _ _) = True -- I think so... WDP 94/09 + squashable (CoPrim _ _ _) = True -- ditto + squashable other = False +\end{code} + diff --git a/ghc/compiler/coreSyn/CoreLift.hi b/ghc/compiler/coreSyn/CoreLift.hi new file mode 100644 index 0000000..38d4f0d --- /dev/null +++ b/ghc/compiler/coreSyn/CoreLift.hi @@ -0,0 +1,31 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreLift where +import BasicLit(BasicLit) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..)) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreBinding = CoreBinding Id Id +type PlainCoreExpr = CoreExpr Id Id +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +applyBindUnlifts :: [CoreExpr Id Id -> CoreExpr Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +bindUnlift :: Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +liftCoreBindings :: SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +liftExpr :: Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkLiftedId :: Id -> Unique -> (Id, Id) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs new file mode 100644 index 0000000..9430cc5 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -0,0 +1,316 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[CoreLift]{Lifts unboxed bindings and any references to them} + +\begin{code} +#include "HsVersions.h" + +module CoreLift ( + liftCoreBindings, + + mkLiftedId, + liftExpr, + bindUnlift, + applyBindUnlifts, + + CoreBinding, PlainCoreBinding(..), + CoreExpr, PlainCoreExpr(..), + Id, SplitUniqSupply, Unique + ) where + +IMPORT_Trace + +import AbsPrel ( liftDataCon, mkLiftTy ) +import TysPrim ( statePrimTyCon ) -- ToDo: get from AbsPrel +import AbsUniType +import Id ( getIdUniType, updateIdType, mkSysLocal, isLocallyDefined ) +import IdEnv +import Outputable +import PlainCore +import SplitUniq +import Util + +infixr 9 `thenL` + +\end{code} + +%************************************************************************ +%* * +\subsection{``lift'' for various constructs} +%* * +%************************************************************************ + +@liftCoreBindings@ is the top-level interface function. + +\begin{code} +liftCoreBindings :: SplitUniqSupply -- unique supply + -> [PlainCoreBinding] -- unlifted bindings + -> [PlainCoreBinding] -- lifted bindings + +liftCoreBindings us binds + = initL (lift_top_binds binds) us + where + lift_top_binds (b:bs) + = liftBindAndScope True (is_rec b) b ( + lift_top_binds bs `thenL` \ bs -> + returnL (ItsABinds bs) + ) `thenL` \ (b, ItsABinds bs) -> + returnL (b:bs) + + lift_top_binds [] + = returnL [] + +is_rec (CoNonRec _ _) = False +is_rec _ = True + +liftBindAndScope :: Bool -- True <=> a top level group + -> Bool -- True <=> a recursive group + -> PlainCoreBinding -- As yet unprocessed + -> LiftM BindsOrExpr -- Do the scope of the bindings + -> LiftM (PlainCoreBinding, -- Processed + BindsOrExpr) + +liftBindAndScope toplev is_rec bind scopeM + = liftBinders toplev is_rec binders ( + liftCoreBind bind `thenL` \ bind -> + scopeM `thenL` \ bindsorexpr -> + returnL (bind, bindsorexpr) + ) + where + binders = bindersOf bind + +liftCoreAtom :: PlainCoreAtom -> LiftM (PlainCoreAtom, PlainCoreExpr -> PlainCoreExpr) + +liftCoreAtom (CoLitAtom lit) + = returnL (CoLitAtom lit, id) + +liftCoreAtom (CoVarAtom v) + = isLiftedId v `thenL` \ lifted -> + case lifted of + Just (lifted, unlifted) -> + returnL (CoVarAtom unlifted, bindUnlift lifted unlifted) + Nothing -> + returnL (CoVarAtom v, id) + + +liftCoreBind :: PlainCoreBinding -> LiftM PlainCoreBinding + +liftCoreBind (CoNonRec b rhs) + = liftOneBind (b,rhs) `thenL` \ (b,rhs) -> + returnL (CoNonRec b rhs) + +liftCoreBind (CoRec pairs) + = mapL liftOneBind pairs `thenL` \ pairs -> + returnL (CoRec pairs) + +liftOneBind (binder,rhs) + = liftCoreExpr rhs `thenL` \ rhs -> + isLiftedId binder `thenL` \ lifted -> + case lifted of + Just (lifted, unlifted) -> + returnL (lifted, liftExpr unlifted rhs) + Nothing -> + returnL (binder, rhs) + +liftCoreExpr :: PlainCoreExpr -> LiftM PlainCoreExpr + +liftCoreExpr (CoVar var) + = isLiftedId var `thenL` \ lifted -> + case lifted of + Just (lifted, unlifted) -> + returnL (bindUnlift lifted unlifted (CoVar unlifted)) + Nothing -> + returnL (CoVar var) + +liftCoreExpr (CoLit lit) + = returnL (CoLit lit) + +liftCoreExpr (CoSCC label expr) + = liftCoreExpr expr `thenL` \ expr -> + returnL (CoSCC label expr) + +liftCoreExpr (CoLet (CoNonRec binder rhs) body) -- special case: for speed + = liftCoreExpr rhs `thenL` \ rhs2 -> + liftCoreExpr body `thenL` \ body2 -> + returnL (mkCoLetUnboxedToCase (CoNonRec binder rhs2) body2) + +liftCoreExpr (CoLet bind body) -- general case + = liftBindAndScope False{-not top-level-} (is_rec bind) bind ( + liftCoreExpr body `thenL` \ body -> + returnL (ItsAnExpr body) + ) `thenL` \ (bind, ItsAnExpr body) -> + returnL (CoLet bind body) + +liftCoreExpr (CoCon con tys args) + = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) -> + returnL (applyBindUnlifts unlifts (CoCon con tys args)) + +liftCoreExpr (CoPrim op tys args) + = mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) -> + returnL (applyBindUnlifts unlifts (CoPrim op tys args)) + +liftCoreExpr (CoApp fun arg) + = lift_app fun [arg] + where + lift_app (CoApp fun arg) args + = lift_app fun (arg:args) + lift_app other_fun args + = liftCoreExpr other_fun `thenL` \ other_fun -> + mapAndUnzipL liftCoreAtom args `thenL` \ (args, unlifts) -> + returnL (applyBindUnlifts unlifts (foldl CoApp other_fun args)) + +liftCoreExpr (CoTyApp fun ty_arg) + = liftCoreExpr fun `thenL` \ fun -> + returnL (CoTyApp fun ty_arg) + +liftCoreExpr (CoLam binders expr) + = liftCoreExpr expr `thenL` \ expr -> + returnL (CoLam binders expr) + +liftCoreExpr (CoTyLam tyvar expr) + = liftCoreExpr expr `thenL` \ expr -> + returnL (CoTyLam tyvar expr) + +liftCoreExpr (CoCase scrut alts) + = liftCoreExpr scrut `thenL` \ scrut -> + liftCoreAlts alts `thenL` \ alts -> + returnL (CoCase scrut alts) + + +liftCoreAlts :: PlainCoreCaseAlternatives -> LiftM PlainCoreCaseAlternatives + +liftCoreAlts (CoAlgAlts alg_alts deflt) + = mapL liftAlgAlt alg_alts `thenL` \ alg_alts -> + liftDeflt deflt `thenL` \ deflt -> + returnL (CoAlgAlts alg_alts deflt) + +liftCoreAlts (CoPrimAlts prim_alts deflt) + = mapL liftPrimAlt prim_alts `thenL` \ prim_alts -> + liftDeflt deflt `thenL` \ deflt -> + returnL (CoPrimAlts prim_alts deflt) + + +liftAlgAlt (con,args,rhs) + = liftCoreExpr rhs `thenL` \ rhs -> + returnL (con,args,rhs) + +liftPrimAlt (lit,rhs) + = liftCoreExpr rhs `thenL` \ rhs -> + returnL (lit,rhs) + +liftDeflt CoNoDefault + = returnL CoNoDefault +liftDeflt (CoBindDefault binder rhs) + = liftCoreExpr rhs `thenL` \ rhs -> + returnL (CoBindDefault binder rhs) + +\end{code} + +%************************************************************************ +%* * +\subsection{Misc functions} +%* * +%************************************************************************ + +\begin{code} +type LiftM a = IdEnv (Id, Id) -- lifted Ids are mapped to: + -- * lifted Id with the same Unique + -- (top-level bindings must keep their + -- unique (see TopLevId in Id.lhs)) + -- * unlifted version with a new Unique + -> SplitUniqSupply -- unique supply + -> a -- result + +data BindsOrExpr = ItsABinds [PlainCoreBinding] + | ItsAnExpr PlainCoreExpr + +initL m us + = m nullIdEnv us + +returnL :: a -> LiftM a +returnL r idenv us + = r + +thenL :: LiftM a -> (a -> LiftM b) -> LiftM b +thenL m k idenv s0 + = case splitUniqSupply s0 of { (s1, s2) -> + case (m idenv s1) of { r -> + k r idenv s2 }} + + +mapL :: (a -> LiftM b) -> [a] -> LiftM [b] +mapL f [] = returnL [] +mapL f (x:xs) + = f x `thenL` \ r -> + mapL f xs `thenL` \ rs -> + returnL (r:rs) + +mapAndUnzipL :: (a -> LiftM (b1, b2)) -> [a] -> LiftM ([b1],[b2]) +mapAndUnzipL f [] = returnL ([],[]) +mapAndUnzipL f (x:xs) + = f x `thenL` \ (r1, r2) -> + mapAndUnzipL f xs `thenL` \ (rs1,rs2) -> + returnL ((r1:rs1),(r2:rs2)) + + +liftBinders :: Bool -> Bool -> [Id] -> LiftM thing -> LiftM thing +liftBinders toplev is_rec ids liftM idenv s0 + +--ToDo | toplev || is_rec -- *must* play the lifting game + = liftM (growIdEnvList idenv lift_map) s1 + where + lift_ids = [ id | id <- ids, is_unboxed_but_not_state (getIdUniType id) ] + (lift_uniqs, s1) = getSUniquesAndDepleted (length lift_ids) s0 + lift_map = zip lift_ids (zipWith mkLiftedId lift_ids lift_uniqs) + +isLiftedId :: Id -> LiftM (Maybe (Id, Id)) +isLiftedId id idenv us + | isLocallyDefined id + = lookupIdEnv idenv id + | otherwise -- ensure all imported ids are lifted + = if is_unboxed_but_not_state (getIdUniType id) + then Just (mkLiftedId id (getSUnique us)) + else Nothing + +mkLiftedId :: Id -> Unique -> (Id,Id) +mkLiftedId id u + = ASSERT (is_unboxed_but_not_state unlifted_ty) + (lifted_id, unlifted_id) + where + id_name = getOccurrenceName id + lifted_id = updateIdType id lifted_ty + unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id) + + unlifted_ty = getIdUniType id + lifted_ty = mkLiftTy unlifted_ty + +bindUnlift :: Id -> Id -> PlainCoreExpr -> PlainCoreExpr +bindUnlift vlift vunlift expr + = ASSERT (is_unboxed_but_not_state unlift_ty && lift_ty == mkLiftTy unlift_ty) + CoCase (CoVar vlift) + (CoAlgAlts [(liftDataCon, [vunlift], expr)] CoNoDefault) + where + lift_ty = getIdUniType vlift + unlift_ty = getIdUniType vunlift + +liftExpr :: Id -> PlainCoreExpr -> PlainCoreExpr +liftExpr vunlift rhs + = ASSERT (is_unboxed_but_not_state unlift_ty && rhs_ty == unlift_ty) + CoCase rhs (CoPrimAlts [] (CoBindDefault vunlift + (CoCon liftDataCon [unlift_ty] [CoVarAtom vunlift]))) + where + rhs_ty = typeOfCoreExpr rhs + unlift_ty = getIdUniType vunlift + + +applyBindUnlifts :: [PlainCoreExpr -> PlainCoreExpr] -> PlainCoreExpr -> PlainCoreExpr +applyBindUnlifts [] expr = expr +applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr) + +is_unboxed_but_not_state ty + = case (getUniDataTyCon_maybe ty) of + Nothing -> False + Just (tycon, _, _) -> + not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon) +\end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.hi b/ghc/compiler/coreSyn/CoreLint.hi new file mode 100644 index 0000000..aa9ebfe --- /dev/null +++ b/ghc/compiler/coreSyn/CoreLint.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreLint where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding, CoreExpr) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreBinding(..)) +import Pretty(PprStyle) +import SrcLoc(SrcLoc) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreBinding = CoreBinding Id Id +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +lintCoreBindings :: PprStyle -> [Char] -> Bool -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LLLS" _N_ _N_ #-} +lintUnfolding :: SrcLoc -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs new file mode 100644 index 0000000..f42a49e --- /dev/null +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -0,0 +1,651 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[CoreLint]{A ``lint'' pass to check for Core correctness} + +\begin{code} +#include "HsVersions.h" + +module CoreLint ( + lintCoreBindings, + lintUnfolding, + + PprStyle, CoreBinding, PlainCoreBinding(..), Id + ) where + +IMPORT_Trace + +import AbsPrel ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType +import Bag +import BasicLit ( typeOfBasicLit, BasicLit ) +import CoreSyn ( pprCoreBinding ) -- ToDo: correctly +import Id ( getIdUniType, isNullaryDataCon, isBottomingId, + getInstantiatedDataConSig, Id + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import Maybes +import Outputable +import PlainCore +import Pretty +import SrcLoc ( SrcLoc ) +import UniqSet +import Util + +infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` +\end{code} + +Checks for + (a) type errors + (b) locally-defined variables used but not defined + +Doesn't check for out-of-scope type variables, because they can +legitimately arise. Eg +\begin{verbatim} + k = /\a b -> \x::a y::b -> x + f = /\c -> \z::c -> k c w z (error w "foo") +\end{verbatim} +Here \tr{w} is just a free type variable. + +%************************************************************************ +%* * +\subsection{``lint'' for various constructs} +%* * +%************************************************************************ + +@lintCoreBindings@ is the top-level interface function. + +\begin{code} +lintCoreBindings :: PprStyle -> String -> Bool -> [PlainCoreBinding] -> [PlainCoreBinding] + +lintCoreBindings sty whodunnit spec_done binds + = BSCC("CoreLint") + case (initL (lint_binds binds) spec_done) of + Nothing -> binds + Just msg -> pprPanic "" (ppAboves [ + ppStr ("*** Core Lint Errors: in "++whodunnit++" ***"), + msg sty, + ppStr "*** Offending Program ***", + ppAboves (map (pprCoreBinding sty pprBigCoreBinder pprTypedCoreBinder ppr) binds), + ppStr "*** End of Offense ***"]) + ESCC + where + lint_binds :: [PlainCoreBinding] -> LintM () + + lint_binds [] = returnL () + lint_binds (bind:binds) + = lintCoreBinds bind `thenL` \ binders -> + addInScopeVars binders ( + lint_binds binds + ) +\end{code} + +We use this to check all unfoldings that come in from interfaces +(it is very painful to catch errors otherwise): +\begin{code} +lintUnfolding :: SrcLoc -> PlainCoreExpr -> PlainCoreExpr + +lintUnfolding locn expr + = case (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) True{-pretend spec done-}) of + Nothing -> expr + Just msg -> error ("ERROR: Type-incorrect unfolding from an interface:\n"++ + (ppShow 80 (ppAboves [msg PprForUser, + ppStr "*** Bad unfolding ***", + ppr PprDebug expr, + ppStr "*** End of bad unfolding ***"]))) +\end{code} + +\begin{code} +lintCoreAtom :: PlainCoreAtom -> LintM (Maybe UniType) + +lintCoreAtom (CoLitAtom lit) = returnL (Just (typeOfBasicLit lit)) +lintCoreAtom a@(CoVarAtom v) + = checkInScope v `thenL_` + returnL (Just (getIdUniType v)) +\end{code} + +\begin{code} +lintCoreBinds :: PlainCoreBinding -> LintM [Id] -- Returns the binders +lintCoreBinds (CoNonRec binder rhs) + = lint_binds_help (binder,rhs) `thenL_` + returnL [binder] + +lintCoreBinds (CoRec pairs) + = addInScopeVars binders ( + mapL lint_binds_help pairs `thenL_` + returnL binders + ) + where + binders = [b | (b,_) <- pairs] + +lint_binds_help (binder,rhs) + = addLoc (RhsOf binder) ( + -- Check the rhs + lintCoreExpr rhs `thenL` \ maybe_rhs_ty -> + + -- Check match to RHS type + (case maybe_rhs_ty of + Nothing -> returnL () + Just rhs_ty -> checkTys (getIdUniType binder) + rhs_ty + (mkRhsMsg binder rhs_ty) + ) `thenL_` + + -- Check not isPrimType + checkL (not (isPrimType (getIdUniType binder))) + (mkRhsPrimMsg binder rhs) + `thenL_` + + -- Check unfolding, if any + -- Blegh. This is tricky, because the unfolding is a SimplifiableCoreExpr + -- Give up for now + + returnL () + ) +\end{code} + +\begin{code} +lintCoreExpr :: PlainCoreExpr -> LintM (Maybe UniType) -- Nothing if error found + +lintCoreExpr (CoVar var) + = checkInScope var `thenL_` + returnL (Just ty) +{- + case (splitForalls ty) of { (tyvars, _) -> + if null tyvars then + returnL (Just ty) + else + addErrL (mkUnappTyMsg var ty) `thenL_` + returnL Nothing + } +-} + where + ty = getIdUniType var + +lintCoreExpr (CoLit lit) = returnL (Just (typeOfBasicLit lit)) +lintCoreExpr (CoSCC label expr) = lintCoreExpr expr + +lintCoreExpr (CoLet binds body) + = lintCoreBinds binds `thenL` \ binders -> + ASSERT(not (null binders)) + addLoc (BodyOfLetRec binders) ( + addInScopeVars binders ( + lintCoreExpr body + )) + +lintCoreExpr e@(CoCon con tys args) + = checkTyApp con_ty tys (mkTyAppMsg e) `thenMaybeL` \ con_tau_ty -> + -- Note: no call to checkSpecTyApp; + -- we allow CoCons applied to unboxed types to sail through + mapMaybeL lintCoreAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp con_tau_ty arg_tys (mkFunAppMsg con_tau_ty arg_tys e) + where + con_ty = getIdUniType con + +lintCoreExpr e@(CoPrim op tys args) + = checkTyApp op_ty tys (mkTyAppMsg e) `thenMaybeL` \ op_tau_ty -> + -- checkSpecTyApp e tys (mkSpecTyAppMsg e) `thenMaybeL_` + mapMaybeL lintCoreAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp op_tau_ty arg_tys (mkFunAppMsg op_tau_ty arg_tys e) + where + op_ty = typeOfPrimOp op + +lintCoreExpr e@(CoApp fun arg) + = lce e [] + where + lce (CoApp fun arg) arg_tys = lintCoreAtom arg `thenMaybeL` \ arg_ty -> + lce fun (arg_ty:arg_tys) + + lce other_fun arg_tys = lintCoreExpr other_fun `thenMaybeL` \ fun_ty -> + checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) + +lintCoreExpr e@(CoTyApp fun ty_arg) + = lce e [] + where + lce (CoTyApp fun ty_arg) ty_args = lce fun (ty_arg:ty_args) + + lce other_fun ty_args = lintCoreExpr other_fun `thenMaybeL` \ fun_ty -> + checkTyApp fun_ty ty_args (mkTyAppMsg e) + `thenMaybeL` \ res_ty -> + checkSpecTyApp other_fun ty_args (mkSpecTyAppMsg e) + `thenMaybeL_` + returnL (Just res_ty) + +lintCoreExpr (CoLam binders expr) + = ASSERT (not (null binders)) + addLoc (LambdaBodyOf binders) ( + addInScopeVars binders ( + lintCoreExpr expr `thenMaybeL` \ body_ty -> + returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders)) + )) + +lintCoreExpr (CoTyLam tyvar expr) + = lintCoreExpr expr `thenMaybeL` \ body_ty -> + case quantifyTy [tyvar] body_ty of + (_, ty) -> returnL (Just ty) -- not worried about the TyVarTemplates that come back + +lintCoreExpr e@(CoCase scrut alts) + = lintCoreExpr scrut `thenMaybeL` \ scrut_ty -> + + -- Check that it is a data type + case getUniDataTyCon_maybe scrut_ty of + Nothing -> addErrL (mkCaseDataConMsg e) `thenL_` + returnL Nothing + Just (tycon, _, _) + -> lintCoreAlts alts scrut_ty tycon + +lintCoreAlts :: PlainCoreCaseAlternatives + -> UniType -- Type of scrutinee + -> TyCon -- TyCon pinned on the case + -> LintM (Maybe UniType) -- Type of alternatives + +lintCoreAlts alts scrut_ty case_tycon + = (case alts of + CoAlgAlts alg_alts deflt -> + chk_prim_type False case_tycon `thenL_` + chk_non_abstract_type case_tycon `thenL_` + mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys -> + lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty -> + returnL (maybe_deflt_ty : maybe_alt_tys) + + CoPrimAlts prim_alts deflt -> + chk_prim_type True case_tycon `thenL_` + mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys -> + lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty -> + returnL (maybe_deflt_ty : maybe_alt_tys) + ) `thenL` \ maybe_result_tys -> + -- Check the result types + case catMaybes (maybe_result_tys) of + [] -> returnL Nothing + + (first_ty:tys) -> mapL check tys `thenL_` + returnL (Just first_ty) + where + check ty = checkTys first_ty ty (mkCaseAltMsg alts) + where + chk_prim_type prim_required tycon + = if (isPrimTyCon tycon == prim_required) then + returnL () + else + addErrL (mkCasePrimMsg prim_required tycon) + + chk_non_abstract_type tycon + = case (getTyConFamilySize tycon) of + Nothing -> addErrL (mkCaseAbstractMsg tycon) + Just _ -> returnL () + + +lintAlgAlt scrut_ty (con,args,rhs) + = (case getUniDataTyCon_maybe scrut_ty of + Nothing -> + addErrL (mkAlgAltMsg1 scrut_ty) + Just (tycon, tys_applied, cons) -> + let + (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied + in + checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_` + checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) + `thenL_` + mapL check (arg_tys `zipEqual` args) `thenL_` + returnL () + ) `thenL_` + addInScopeVars args ( + lintCoreExpr rhs + ) + where + check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg) + + -- elem: yes, the elem-list here can sometimes be long-ish, + -- but as it's use-once, probably not worth doing anything different + -- We give it its own copy, so it isn't overloaded. + elem _ [] = False + elem x (y:ys) = x==y || elem x ys + +lintPrimAlt scrut_ty alt@(lit,rhs) + = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt) `thenL_` + lintCoreExpr rhs + +lintDeflt CoNoDefault scrut_ty = returnL Nothing +lintDeflt deflt@(CoBindDefault binder rhs) scrut_ty + = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt) `thenL_` + addInScopeVars [binder] ( + lintCoreExpr rhs + ) +\end{code} + + +%************************************************************************ +%* * +\subsection[lint-monad]{The Lint monad} +%* * +%************************************************************************ + +\begin{code} +type LintM a = Bool -- True <=> specialisation has been done + -> [LintLocInfo] -- Locations + -> UniqSet Id -- Local vars in scope + -> Bag ErrMsg -- Error messages so far + -> (a, Bag ErrMsg) -- Result and error messages (if any) + +type ErrMsg = PprStyle -> Pretty + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf [Id] -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + +instance Outputable LintLocInfo where + ppr sty (RhsOf v) + = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + + ppr sty (LambdaBodyOf bs) + = ppBesides [ppr sty (getSrcLoc (head bs)), + ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"] + + ppr sty (BodyOfLetRec bs) + = ppBesides [ppr sty (getSrcLoc (head bs)), + ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + + ppr sty (ImportedUnfolding locn) + = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]") + +pp_binders :: PprStyle -> [Id] -> Pretty +pp_binders sty bs + = ppInterleave ppComma (map pp_binder bs) + where + pp_binder b + = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)] +\end{code} + +\begin{code} +initL :: LintM a -> Bool -> Maybe ErrMsg +initL m spec_done + = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) -> + if isEmptyBag errs then + Nothing + else + Just ( \ sty -> + ppAboves [ msg sty | msg <- bagToList errs ] + ) + } + +returnL :: a -> LintM a +returnL r spec loc scope errs = (r, errs) + +thenL :: LintM a -> (a -> LintM b) -> LintM b +thenL m k spec loc scope errs + = case m spec loc scope errs of + (r, errs') -> k r spec loc scope errs' + +thenL_ :: LintM a -> LintM b -> LintM b +thenL_ m k spec loc scope errs + = case m spec loc scope errs of + (_, errs') -> k spec loc scope errs' + +thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b) +thenMaybeL m k spec loc scope errs + = case m spec loc scope errs of + (Nothing, errs2) -> (Nothing, errs2) + (Just r, errs2) -> k r spec loc scope errs2 + +thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b) +thenMaybeL_ m k spec loc scope errs + = case m spec loc scope errs of + (Nothing, errs2) -> (Nothing, errs2) + (Just _, errs2) -> k spec loc scope errs2 + +mapL :: (a -> LintM b) -> [a] -> LintM [b] +mapL f [] = returnL [] +mapL f (x:xs) + = f x `thenL` \ r -> + mapL f xs `thenL` \ rs -> + returnL (r:rs) + +mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b]) + -- Returns Nothing if anything fails +mapMaybeL f [] = returnL (Just []) +mapMaybeL f (x:xs) + = f x `thenMaybeL` \ r -> + mapMaybeL f xs `thenMaybeL` \ rs -> + returnL (Just (r:rs)) +\end{code} + +\begin{code} +checkL :: Bool -> ErrMsg -> LintM () +checkL True msg spec loc scope errs = ((), errs) +checkL False msg spec loc scope errs = ((), addErr errs msg loc) + +addErrL :: ErrMsg -> LintM () +addErrL msg spec loc scope errs = ((), addErr errs msg loc) + +addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg + +addErr errs_so_far msg locs + = ASSERT (not (null locs)) + errs_so_far `snocBag` ( \ sty -> + ppHang (ppr sty (head locs)) 4 (msg sty) + ) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m spec loc scope errs + = m spec (extra_loc:loc) scope errs + +addInScopeVars :: [Id] -> LintM a -> LintM a +addInScopeVars ids m spec loc scope errs + = -- We check if these "new" ids are already + -- in scope, i.e., we have *shadowing* going on. + -- For now, it's just a "trace"; we may make + -- a real error out of it... + let + new_set = mkUniqSet ids + + shadowed = scope `intersectUniqSets` new_set + in +-- After adding -fliberate-case, Simon decided he likes shadowed +-- names after all. WDP 94/07 +-- (if isEmptyUniqSet shadowed +-- then id +-- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( + m spec loc (scope `unionUniqSets` new_set) errs +-- ) +\end{code} + +\begin{code} +checkTyApp :: UniType + -> [UniType] + -> ErrMsg + -> LintM (Maybe UniType) + +checkTyApp forall_ty ty_args msg spec_done loc scope errs + = if (not spec_done && n_ty_args /= n_tyvars) + || (spec_done && n_ty_args > n_tyvars) + -- + -- Things are *not* OK if: + -- + -- * Unsaturated type app before specialisation has been done; + -- + -- * Oversaturated type app after specialisation (eta reduction + -- may well be happening...); + -- + -- Note: checkTyApp is usually followed by a call to checkSpecTyApp. + -- + then (Nothing, addErr errs msg loc) + else (Just res_ty, errs) + where + (tyvars, rho_ty) = splitForalls forall_ty + n_tyvars = length tyvars + n_ty_args = length ty_args + leftover_tyvars = drop n_ty_args tyvars + inst_env = tyvars `zip` ty_args + res_ty = mkForallTy leftover_tyvars (instantiateTy inst_env rho_ty) +\end{code} + +\begin{code} +checkSpecTyApp :: PlainCoreExpr -> [UniType] -> ErrMsg -> LintM (Maybe ()) + +checkSpecTyApp expr ty_args msg spec_done loc scope errs + = if spec_done + && any isUnboxedDataType ty_args + && not (an_application_of_error expr) + then (Nothing, addErr errs msg loc) + else (Just (), errs) + where + -- always safe (but maybe unfriendly) to say "False" + an_application_of_error (CoVar id) | isBottomingId id = True + an_application_of_error _ = False +\end{code} + +\begin{code} +checkFunApp :: UniType -- The function type + -> [UniType] -- The arg type(s) + -> ErrMsg -- Error messgae + -> LintM (Maybe UniType) -- The result type + +checkFunApp fun_ty arg_tys msg spec loc scope errs + = cfa res_ty expected_arg_tys arg_tys + where + (expected_arg_tys, res_ty) = splitTyArgs fun_ty + + cfa res_ty expected [] -- Args have run out; that's fine + = (Just (glueTyArgs expected res_ty), errs) + + cfa res_ty [] arg_tys -- Expected arg tys ran out first; maybe res_ty is a + -- dictionary type which is actually a function? + = case splitTyArgs (unDictifyTy res_ty) of + ([], _) -> (Nothing, addErr errs msg loc) -- Too many args + (new_expected, new_res) -> cfa new_res new_expected arg_tys + + cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys) + = case (cmpUniType True{-properly-} expected_arg_ty arg_ty) of + EQ_ -> cfa res_ty expected_arg_tys arg_tys + other -> (Nothing, addErr errs msg loc) -- Arg mis-match +\end{code} + +\begin{code} +checkInScope :: Id -> LintM () +checkInScope id spec loc scope errs + = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then + ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) + else + ((), errs) + +checkTys :: UniType -> UniType -> ErrMsg -> LintM () +checkTys ty1 ty2 msg spec loc scope errs + = case (cmpUniType True{-properly-} ty1 ty2) of + EQ_ -> ((), errs) + other -> ((), addErr errs msg loc) +\end{code} + +\begin{code} +mkCaseAltMsg :: PlainCoreCaseAlternatives -> ErrMsg +mkCaseAltMsg alts sty + = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:") + (ppr sty alts) + +mkCaseDataConMsg :: PlainCoreExpr -> ErrMsg +mkCaseDataConMsg expr sty + = ppAbove (ppStr "A case scrutinee not a type-constructor type:") + (pp_expr sty expr) + +mkCasePrimMsg :: Bool -> TyCon -> ErrMsg +mkCasePrimMsg True tycon sty + = ppAbove (ppStr "A primitive case on a non-primitive type:") + (ppr sty tycon) +mkCasePrimMsg False tycon sty + = ppAbove (ppStr "An algebraic case on a primitive type:") + (ppr sty tycon) + +mkCaseAbstractMsg :: TyCon -> ErrMsg +mkCaseAbstractMsg tycon sty + = ppAbove (ppStr "An algebraic case on an abstract type:") + (ppr sty tycon) + +mkDefltMsg :: PlainCoreCaseDefault -> ErrMsg +mkDefltMsg deflt sty + = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:") + (ppr sty deflt) + +mkFunAppMsg :: UniType -> [UniType] -> PlainCoreExpr -> ErrMsg +mkFunAppMsg fun_ty arg_tys expr sty + = ppAboves [ppStr "In a function application, function type doesn't match arg types:", + ppHang (ppStr "Function type:") 4 (ppr sty fun_ty), + ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)), + ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + +mkUnappTyMsg :: Id -> UniType -> ErrMsg +mkUnappTyMsg var ty sty + = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.", + ppBeside (ppStr "Var: ") (ppr sty var), + ppBeside (ppStr "Its type: ") (ppr sty ty)] + +mkAlgAltMsg1 :: UniType -> ErrMsg +mkAlgAltMsg1 ty sty + = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") + (ppr sty ty) + +mkAlgAltMsg2 :: UniType -> Id -> ErrMsg +mkAlgAltMsg2 ty con sty + = ppAboves [ + ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + ppr sty ty, + ppr sty con + ] + +mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg +mkAlgAltMsg3 con alts sty + = ppAboves [ + ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:", + ppr sty con, + ppr sty alts + ] + +mkAlgAltMsg4 :: UniType -> Id -> ErrMsg +mkAlgAltMsg4 ty arg sty + = ppAboves [ + ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:", + ppr sty ty, + ppr sty arg + ] + +mkPrimAltMsg :: (BasicLit, PlainCoreExpr) -> ErrMsg +mkPrimAltMsg alt sty + = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:") + (ppr sty alt) + +mkRhsMsg :: Id -> UniType -> ErrMsg +mkRhsMsg binder ty sty + = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + ppr sty binder], + ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)], + ppCat [ppStr "Rhs type:", ppr sty ty] + ] + +mkRhsPrimMsg :: Id -> PlainCoreExpr -> ErrMsg +mkRhsPrimMsg binder rhs sty + = ppAboves [ppCat [ppStr "The type of this binder is primitive:", + ppr sty binder], + ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)] + ] + +mkTyAppMsg :: PlainCoreExpr -> ErrMsg +mkTyAppMsg expr sty + = ppAboves [ppStr "In a type application, either the function's type doesn't match", + ppStr "the argument types, or an argument type is primitive:", + pp_expr sty expr] + +mkSpecTyAppMsg :: PlainCoreExpr -> ErrMsg +mkSpecTyAppMsg expr sty + = ppAbove (ppStr "Unboxed types in a type application (after specialisation):") + (pp_expr sty expr) + +pp_expr sty expr + = pprCoreExpr sty pprBigCoreBinder pprTypedCoreBinder pprTypedCoreBinder expr +\end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.hi b/ghc/compiler/coreSyn/CoreSyn.hi new file mode 100644 index 0000000..7454e8d --- /dev/null +++ b/ghc/compiler/coreSyn/CoreSyn.hi @@ -0,0 +1,63 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreSyn where +import BasicLit(BasicLit) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName, ShortName) +import Outputable(Outputable) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data CoreArg a = TypeArg UniType | ValArg (CoreAtom a) +data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit +data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] +data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) +data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b) +data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 2 2 XX 3 _/\_ u0 u1 -> \ (u2 :: CoreExpr u0 u1) (u3 :: UniType) -> _!_ _ORIG_ CoreSyn CoTyApp [u0, u1] [u2, u3] _N_ #-} +pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLS" _N_ _N_ #-} +pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-} +instance Outputable a => Outputable (CoreArg a) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (CoreAtom a) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreBinding a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreBinding u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreBinding { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreExpr a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreExpr u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreExpr { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-} + diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs new file mode 100644 index 0000000..1cdba66 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -0,0 +1,738 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CoreSyn]{A data type for the Haskell compiler midsection} + +\begin{code} +#include "HsVersions.h" + +module CoreSyn ( + CoreBinding(..), CoreExpr(..), CoreAtom(..), + CoreCaseAlternatives(..), CoreCaseDefault(..), +#ifdef DPH + CoreParQuals(..), + CoreParCommunicate(..), +#endif {- Data Parallel Haskell -} + mkCoTyApp, + pprCoreBinding, pprCoreExpr, + + CoreArg(..), applyToArgs, decomposeArgs, collectArgs, + + -- and to make the interface self-sufficient ... + Id, UniType, TyVar, TyCon, PrimOp, BasicLit, + PprStyle, PrettyRep, CostCentre, Maybe + ) where + +import AbsPrel ( PrimOp, PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( isPrimType, pprParendUniType, TyVar, TyCon, UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import BasicLit ( BasicLit ) +import Id ( getIdUniType, isBottomingId, Id + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import Outputable +import Pretty +import CostCentre ( showCostCentre, CostCentre ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @CoreBinding@} +%* * +%************************************************************************ + +Core programs, bindings, expressions, etc., are parameterised with +respect to the information kept about binding and bound occurrences of +variables, called {\em binders} and {\em bindees}, respectively. [I +don't really like the pair of names; I prefer {\em binder} and {\em +bounder}. Or {\em binder} and {\em var}.] + +A @CoreBinding@ is either a single non-recursive binding of a +``binder'' to an expression, or a mutually-recursive blob of same. +\begin{code} +data CoreBinding binder bindee + = CoNonRec binder (CoreExpr binder bindee) + | CoRec [(binder, CoreExpr binder bindee)] +\end{code} + +%************************************************************************ +%* * +\subsection[CoreAtom]{Core atoms: @CoreAtom@} +%* * +%************************************************************************ + +Same deal as @StgAtoms@, except that, for @Core@, the atomic object +may need to be applied to some types. + +\begin{code} +data CoreAtom bindee + = CoVarAtom bindee + | CoLitAtom BasicLit +\end{code} + +%************************************************************************ +%* * +\subsection[CoreExpr]{Core expressions: @CoreExpr@} +%* * +%************************************************************************ + +@CoreExpr@ is the heart of the ``core'' data types; it is +(more-or-less) boiled-down second-order polymorphic lambda calculus. +For types in the core world, we just keep using @UniTypes@. +\begin{code} +data CoreExpr binder bindee + = CoVar bindee + | CoLit BasicLit -- literal constants +\end{code} + +@CoCons@ and @CoPrims@ are saturated constructor and primitive-op +applications (see the comment). Note: @CoCon@s are only set up by the +simplifier (and by the desugarer when it knows what it's doing). The +desugarer sets up constructors as applications of global @CoVars@s. +\begin{code} + | CoCon Id [UniType] [CoreAtom bindee] + -- saturated constructor application: + -- the constructor is a function of the form: + -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn -> + -- where "/\" is a type lambda and "\" the + -- regular kind; there will be "m" UniTypes and + -- "n" bindees in the CoCon args. + + | CoPrim PrimOp [UniType] [CoreAtom bindee] + -- saturated primitive operation; + -- comment on CoCons applies here, too. + -- The types work the same way + -- (PrimitiveOps may be polymorphic). +\end{code} + +Lambdas have multiple binders; this is good for the lambda lifter. +Single binders may be simulated easily with multiple binders; vice +versa is a pain. +\begin{code} + | CoLam [binder] -- lambda var_1 ... var_n -> CoreExpr + (CoreExpr binder bindee) + | CoTyLam TyVar -- Lambda TyVar -> CoreExpr + (CoreExpr binder bindee) + + | CoApp (CoreExpr binder bindee) + (CoreAtom bindee) + | CoTyApp (CoreExpr binder bindee) + UniType -- type application +\end{code} + +Case expressions (\tr{case CoreExpr of }): there +are really two flavours masquerading here---those for scrutinising +{\em algebraic} types and those for {\em primitive} types. Please see +under @CoreCaseAlternatives@. +\begin{code} + | CoCase (CoreExpr binder bindee) + (CoreCaseAlternatives binder bindee) +\end{code} + +A Core case expression \tr{case e of v -> ...} implies evaluation of +\tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell +\tr{case}). + +Non-recursive @CoLets@ only have one binding; having more than one +doesn't buy you much, and it is an easy way to mess up variable +scoping. +\begin{code} + | CoLet (CoreBinding binder bindee) + (CoreExpr binder bindee) + -- both recursive and non-. + -- The "CoreBinding" records that information +\end{code} + +@build@ as a function is a *PAIN*. See Andy's thesis for +futher details. This is equivalent to: +@ + build unitype (/\ tyvar \ c n -> expr) +@ +\begin{code} +--ANDY: +-- | CoBuild UniType TyVar binder binder (CoreExpr binder bindee) +\end{code} + +@CoZfExpr@ exist in the core language, along with their qualifiers. After +succesive optimisations to the sequential bindings, we desugar the +@CoZfExpr@ into a subset of the core language without them - ``podization''. +\begin{code} +#ifdef DPH + | CoZfExpr (CoreExpr binder bindee) + (CoreParQuals binder bindee) +#endif {- Data Parallel Haskell -} +\end{code} + +@CoParCon@ is the parallel equivalent to the sequential @CoCon@ expression. +They are introduced into the core syntax by a pass of the compiler that +removes the parallel ZF expressions, and {\em vectorises} ordinary sequential +functions. +\begin{code} +#ifdef DPH + | CoParCon Id Int [UniType] [CoreExpr binder bindee] --ToDo:DPH: CoreAtom +#endif {- Data Parallel Haskell -} +\end{code} + +@CoParCommunicate@ constructs are introduced by the desugaring of parallel +ZF expressions. +\begin{code} +#ifdef DPH + | CoParComm + Int + (CoreExpr binder bindee) + (CoreParCommunicate binder bindee) +#endif {- Data Parallel Haskell -} +\end{code} + +@CoParZipWith@ constructs are introduced whenever podization fails during the +desuagring of ZF expressions. These constructs represent zipping the function +represented by the first @CoreExpr@ with the list of @CoreExpr@'s (hopefully +we wont see this that often in the resultant program :-). + +\begin{code} +#ifdef DPH + | CoParZipWith + Int + (CoreExpr binder bindee) + [CoreExpr binder bindee] +#endif {- Data Parallel Haskell -} +\end{code} + +For cost centre scc expressions we introduce a new core construct +@CoSCC@ so transforming passes have to deal with it explicitly. The +alternative of using a new PrimativeOp may result in a bad +transformations of which we are unaware. +\begin{code} + | CoSCC CostCentre -- label of scc + (CoreExpr binder bindee) -- scc expression + +-- end of CoreExpr +\end{code} + + +%************************************************************************ +%* * +\subsection[CoreParQualifiers]{Parallel qualifiers in @CoreExpr@} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH +data CoreParQuals binder bindee + = CoAndQuals (CoreParQuals binder bindee) + (CoreParQuals binder bindee) + | CoParFilter (CoreExpr binder bindee) + | CoDrawnGen [binder] + (binder) + (CoreExpr binder bindee) + | CoIndexGen [CoreExpr binder bindee] + (binder) + (CoreExpr binder bindee) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[ParCommunicate]{Parallel Communication primitives} +%* * +%************************************************************************ +\begin{code} +#ifdef DPH +data CoreParCommunicate binder bindee + = CoParSend [CoreExpr binder bindee] -- fns of form Integer -> Integer + | CoParFetch [CoreExpr binder bindee] -- to determine where moved + | CoToPodized + | CoFromPodized +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[CoreCaseAlternatives]{Case alternatives in @CoreExpr@} +%* * +%************************************************************************ + +We have different kinds of @case@s, the differences being reflected in +the kinds of alternatives a case has. We maintain a distinction +between cases for scrutinising algebraic datatypes, as opposed to +primitive types. In both cases, we carry around a @TyCon@, as a +handle with which we can get info about the case (e.g., total number +of data constructors for this type). + +For example: +\begin{verbatim} +let# x=e in b +\end{verbatim} +becomes +\begin{verbatim} +CoCase e [ CoBindDefaultAlt x -> b ] +\end{verbatim} + +\begin{code} +data CoreCaseAlternatives binder bindee + + = CoAlgAlts [(Id, -- alts: data constructor, + [binder], -- constructor's parameters, + CoreExpr binder bindee)] -- rhs. + (CoreCaseDefault binder bindee) + + | CoPrimAlts [(BasicLit, -- alts: unboxed literal, + CoreExpr binder bindee)] -- rhs. + (CoreCaseDefault binder bindee) +#ifdef DPH + | CoParAlgAlts + TyCon + Int + [binder] + [(Id, + CoreExpr binder bindee)] + (CoreCaseDefault binder bindee) + + | CoParPrimAlts + TyCon + Int + [(BasicLit, + CoreExpr binder bindee)] + (CoreCaseDefault binder bindee) +#endif {- Data Parallel Haskell -} + +-- obvious things: if there are no alts in the list, then the default +-- can't be CoNoDefault. + +data CoreCaseDefault binder bindee + = CoNoDefault -- small con family: all + -- constructor accounted for + | CoBindDefault binder -- form: var -> expr; + (CoreExpr binder bindee) -- "binder" may or may not + -- be used in RHS. +\end{code} + +%************************************************************************ +%* * +\subsection[CoreSyn-arguments]{Core ``argument'' wrapper type} +%* * +%************************************************************************ + +\begin{code} +data CoreArg bindee + = TypeArg UniType + | ValArg (CoreAtom bindee) + +instance Outputable bindee => Outputable (CoreArg bindee) where + ppr sty (ValArg atom) = ppr sty atom + ppr sty (TypeArg ty) = ppr sty ty +\end{code} + +\begin{code} +mkCoTyApp expr ty = CoTyApp expr ty + +{- OLD: unboxed tyapps now allowed! +mkCoTyApp expr ty +#ifdef DEBUG + | isPrimType ty && not (error_app expr) + = pprPanic "mkCoTyApp:" (ppr PprDebug ty) +#endif + | otherwise = ty_app + where + ty_app = CoTyApp expr ty + + error_app (CoVar id) {-| isBottomingId id-} = True -- debugging + -- OOPS! can't do this because it forces + -- the bindee type to be Id (ToDo: what?) WDP 95/02 + error_app _ = False +-} +\end{code} + +\begin{code} +applyToArgs :: CoreExpr binder bindee + -> [CoreArg bindee] + -> CoreExpr binder bindee + +applyToArgs fun [] = fun +applyToArgs fun (ValArg val : args) = applyToArgs (CoApp fun val) args +applyToArgs fun (TypeArg ty : args) = applyToArgs (mkCoTyApp fun ty) args +\end{code} + +@decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block +on the front of the args. Pretty common. + +\begin{code} +decomposeArgs :: [CoreArg bindee] + -> ([UniType], [CoreAtom bindee], [CoreArg bindee]) + +decomposeArgs [] = ([],[],[]) + +decomposeArgs (TypeArg ty : args) + = case (decomposeArgs args) of { (tys, vals, rest) -> + (ty:tys, vals, rest) } + +decomposeArgs (ValArg val : args) + = case (do_vals args) of { (vals, rest) -> + ([], val:vals, rest) } + where + do_vals (ValArg val : args) + = case (do_vals args) of { (vals, rest) -> + (val:vals, rest) } + + do_vals args = ([], args) +\end{code} + +@collectArgs@ takes an application expression, returning the function +and the arguments to which it is applied. + +\begin{code} +collectArgs :: CoreExpr binder bindee + -> (CoreExpr binder bindee, [CoreArg bindee]) + +collectArgs expr + = collect expr [] + where + collect (CoApp fun arg) args = collect fun (ValArg arg : args) + collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args) + collect other_expr args = (other_expr, args) +\end{code} + +%************************************************************************ +%* * +\subsection[CoreSyn-output]{Instance declarations for output} +%* * +%************************************************************************ + +@pprCoreBinding@ and @pprCoreExpr@ let you give special printing +function for ``major'' binders (those next to equal signs :-), +``minor'' ones (lambda-bound, case-bound), and bindees. They would +usually be called through some intermediary. + +\begin{code} +pprCoreBinding + :: PprStyle + -> (PprStyle -> bndr -> Pretty) -- to print "major" binders + -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bdee -> Pretty) -- to print bindees + -> CoreBinding bndr bdee + -> Pretty + +pprCoreBinding sty pbdr1 pbdr2 pbdee (CoNonRec binder expr) + = ppHang (ppCat [pbdr1 sty binder, ppEquals]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) + +pprCoreBinding sty pbdr1 pbdr2 pbdee (CoRec binds) + = ppAboves [ifPprDebug sty (ppStr "{- CoRec -}"), + ppAboves (map ppr_bind binds), + ifPprDebug sty (ppStr "{- end CoRec -}")] + where + ppr_bind (binder, expr) + = ppHang (ppCat [pbdr1 sty binder, ppEquals]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) +\end{code} + +\begin{code} +instance (Outputable bndr, Outputable bdee) + => Outputable (CoreBinding bndr bdee) where + ppr sty bind = pprCoreBinding sty ppr ppr ppr bind + +instance (Outputable bndr, Outputable bdee) + => Outputable (CoreExpr bndr bdee) where + ppr sty expr = pprCoreExpr sty ppr ppr ppr expr + +instance Outputable bdee => Outputable (CoreAtom bdee) where + ppr sty atom = pprCoreAtom sty ppr atom +\end{code} + +\begin{code} +pprCoreAtom + :: PprStyle + -> (PprStyle -> bdee -> Pretty) -- to print bindees + -> CoreAtom bdee + -> Pretty + +pprCoreAtom sty pbdee (CoLitAtom lit) = ppr sty lit +pprCoreAtom sty pbdee (CoVarAtom v) = pbdee sty v +\end{code} + +\begin{code} +pprCoreExpr, pprParendCoreExpr + :: PprStyle + -> (PprStyle -> bndr -> Pretty) -- to print "major" binders + -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bdee -> Pretty) -- to print bindees + -> CoreExpr bndr bdee + -> Pretty + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoVar name) = pbdee sty name + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLit literal) = ppr sty literal + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCon con [] []) = ppr sty con + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCon con types args) + = ppHang (ppBesides [ppr sty con, ppChar '!']) + 4 (ppSep ( (map (pprParendUniType sty) types) + ++ (map (pprCoreAtom sty pbdee) args))) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoPrim prim tys args) + = ppHang (ppBesides [ppr sty prim, ppChar '!']) + 4 (ppSep ( (map (pprParendUniType sty) tys) + ++ (map (pprCoreAtom sty pbdee) args) )) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLam binders expr) + = ppHang (ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) binders), ppStr "->"]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr) + = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars), + ppStr "->", pp_varss var_lists]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after) + where + (tyvars, var_lists, expr_after) = collect_tyvars expr + + collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after ) + where (tyvs, vs, e_after) = collect_tyvars e + collect_tyvars e@(CoLam _ _) = ( [], vss, e_after ) + where (vss, e_after) = collect_vars e + collect_tyvars other_e = ( [], [], other_e ) + + collect_vars (CoLam vars e) = (vars:varss, e_after) + where (varss, e_after) = collect_vars e + collect_vars other_e = ( [], other_e ) + + pp_varss [] = ppNil + pp_varss (vars:varss) + = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars), + ppStr "->", pp_varss varss] + +pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(CoApp fun_expr atom) + = let + (fun, args) = collect_args expr [] + in + ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun) + 4 (ppSep (map (pprCoreAtom sty pbdee) args)) + where + collect_args (CoApp fun arg) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty) + = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr)) + 4 (pprParendUniType sty ty) + where + pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ") + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCase expr alts) + = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr), + ppStr "of {"], + ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts), + ppStr "}"] + +-- special cases: let ... in let ... +-- ("disgusting" SLPJ) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind@(CoNonRec binder rhs@(CoLet _ _)) body) + = ppAboves [ + ppCat [ppStr "let {", pbdr1 sty binder, ppEquals], + ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs), + ppStr "} in", + pprCoreExpr sty pbdr1 pbdr2 pbdee body ] + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind@(CoNonRec binder rhs) expr@(CoLet _ _)) + = ppAbove + (ppHang (ppStr "let {") + 2 (ppCat [ppHang (ppCat [pbdr1 sty binder, ppEquals]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs), + ppStr "} in"])) + (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) + +-- general case (recursive case, too) +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind expr) + = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind), + ppHang (ppStr "} in ") 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)] + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoSCC cc expr) + = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)], + pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] +#ifdef DPH +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoZfExpr expr quals) + = ppHang (ppCat [ppStr "<<" , pprCoreExpr sty pbdr1 pbdr2 pbdee expr , ppStr "|"]) + 4 (ppSep [pprParQuals sty pbdr1 pbdr2 pbdee quals, ppStr ">>"]) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoParCon con dim types args) + = ppHang (ppBesides [ppr sty con, ppStr "!<<" , ppr sty dim , ppStr ">>"]) + 4 (ppSep ( (map (pprParendUniType sty) types) + ++ (map (pprParendCoreExpr sty pbdr1 pbdr2 pbdee) args) )) + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoParComm dim expr comType) + = ppSep [ppSep [ppStr "COMM", + ppNest 2 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),ppStr "{"], + ppNest 2 (ppr sty comType), + ppStr "}"] + +pprCoreExpr sty pbdr1 pbdr2 pbdee (CoParZipWith dim expr exprs) + = ppHang (ppBesides [ ppStr "CoParZipWith {" , ppr sty dim , ppStr "}", + pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr]) + 4 (ppr sty exprs) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(CoVar _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e +pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(CoLit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e +pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e + = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen] +\end{code} + +\begin{code} +instance (Outputable bndr, Outputable bdee) + => Outputable (CoreCaseAlternatives bndr bdee) where + ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts +\end{code} + +\begin{code} +pprCoreCaseAlts + :: PprStyle + -> (PprStyle -> bndr -> Pretty) -- to print "major" binders + -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bdee -> Pretty) -- to print bindees + -> CoreCaseAlternatives bndr bdee + -> Pretty + +pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoAlgAlts alts deflt) + = ppAboves [ ppAboves (map ppr_alt alts), + pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ] + where + ppr_alt (con, params, expr) + = ppHang (ppCat [ppr_con con, + ppInterleave ppSP (map (pbdr2 sty) params), + ppStr "->"]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) + where + ppr_con con + = if isOpLexeme con + then ppBesides [ppLparen, ppr sty con, ppRparen] + else ppr sty con + +pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoPrimAlts alts deflt) + = ppAboves [ ppAboves (map ppr_alt alts), + pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ] + where + ppr_alt (lit, expr) + = ppHang (ppCat [ppr sty lit, ppStr "->"]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) + +#ifdef DPH +-- ToDo: niceties of printing +-- using special binder/bindee printing funs, rather than just "ppr" + +pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoParAlgAlts tycon dim params alts deflt) + = ppAboves [ ifPprShowAll sty (ppr sty tycon), + ppBeside (ppCat (map (ppr sty) params)) + (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]), + ppAboves (map (ppr_alt sty) alts), + ppr sty deflt ] + where + ppr_alt sty (con, expr) + = ppHang (ppCat [ppStr "\\/", ppr_con sty con, ppStr "->"]) + 4 (ppr sty expr) + where + ppr_con sty con + = if isOpLexeme con + then ppBesides [ppLparen, ppr sty con, ppRparen] + else ppr sty con + +pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoParPrimAlts tycon dim alts deflt) + = ppAboves [ ifPprShowAll sty (ppr sty tycon), + ppCat [ppStr "|" , ppr sty dim , ppStr "|"], + ppAboves (map (ppr_alt sty) alts), + ppr sty deflt ] + where + ppr_alt sty (lit, expr) + = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr) + +#endif /* Data Parallel Haskell */ +\end{code} + +\begin{code} +instance (Outputable bndr, Outputable bdee) + => Outputable (CoreCaseDefault bndr bdee) where + ppr sty deflt = pprCoreCaseDefault sty ppr ppr ppr deflt +\end{code} + +\begin{code} +pprCoreCaseDefault + :: PprStyle + -> (PprStyle -> bndr -> Pretty) -- to print "major" binders + -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bdee -> Pretty) -- to print bindees + -> CoreCaseDefault bndr bdee + -> Pretty + +pprCoreCaseDefault sty pbdr1 pbdr2 pbdee CoNoDefault = ppNil + +pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (CoBindDefault binder expr) + = ppHang (ppCat [pbdr2 sty binder, ppStr "->"]) + 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) +\end{code} + +\begin{code} +#ifdef DPH +instance (Outputable bndr, Outputable bdee) + => Outputable (CoreParQuals bndr bdee) where + ppr sty qual = pprParQuals sty ppr ppr ppr qual + +pprParQuals sty pbdr1 pbdr2 pbdee (CoAndQuals x y) + = ppAboves [(ppBesides [pprParQuals sty pbdr1 pbdr2 pbdee x , ppComma]) , pprParQuals sty pbdr1 pbdr2 pbdee y] + +pprParQuals sty pbdr1 pbdr2 pbdee (CoDrawnGen pats pat expr) + = ppCat [ppStr "(|", + ppInterleave ppComma (map (ppr sty) pats), + ppSemi, ppr sty pat,ppStr "|)", + ppStr "<<-", pprCoreExpr sty pbdr1 pbdr2 pbdee expr] + +pprParQuals sty pbdr1 pbdr2 pbdee (CoIndexGen exprs pat expr) + = ppCat [ppStr "(|", + ppInterleave ppComma (map (pprCoreExpr sty pbdr1 pbdr2 pbdee) exprs), + ppSemi, ppr sty pat,ppStr "|)", + ppStr "<<=", pprCoreExpr sty pbdr1 pbdr2 pbdee expr] + +pprParQuals sty pbdr1 pbdr2 pbdee (CoParFilter expr) + = pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifdef DPH +instance (Outputable bndr, Outputable bdee) + => Outputable (CoreParCommunicate bndr bdee) where + ppr sty c = pprCoreParCommunicate sty ppr ppr ppr c + +pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoParSend fns) + = ppHang + (ppStr "SEND") + 4 + (ppAboves (zipWith ppSendFns fns ([1..]::[Int]))) + where + ppSendFns expr dim + = ppCat [ppStr "Dim" , ppr sty dim , ppStr "=" , + pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] + +pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoParFetch fns) + = ppHang + (ppStr "FETCH") + 4 + (ppAboves (zipWith ppSendFns fns ([1..]::[Int]))) + where + ppSendFns expr dim + = ppCat [ppStr "Dim" , ppr sty dim , ppStr "=" , + pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] + +pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoToPodized) + = ppStr "ConvertToPodized" + +pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoFromPodized) + = ppStr "ConvertFromPodized" +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi b/ghc/compiler/coreSyn/CoreUnfold.hi new file mode 100644 index 0000000..41c263d --- /dev/null +++ b/ghc/compiler/coreSyn/CoreUnfold.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreUnfold where +import Class(Class) +import CoreSyn(CoreExpr) +import Id(Id) +import Pretty(PrettyRep) +import SimplEnv(UnfoldingGuidance) +import TyCon(TyCon) +calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-} +mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs new file mode 100644 index 0000000..7a2f380 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -0,0 +1,569 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[CoreUnfold]{Core-syntax functions to do with unfoldings} + +\begin{code} +#include "HsVersions.h" + +module CoreUnfold ( + calcUnfoldingGuidance, + + pprCoreUnfolding, + mentionedInUnfolding + + ) where + +import AbsPrel ( primOpCanTriggerGC, PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( getMentionedTyConsAndClassesFromUniType, + getUniDataTyCon, getTyConFamilySize, + pprParendUniType, Class, TyCon, TyVar, + UniType, TauType(..) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Bag +import BasicLit ( isNoRepLit, isLitLitLit, BasicLit(..){-.. is for pragmas-} ) +import CgCompInfo ( uNFOLDING_CHEAP_OP_COST, + uNFOLDING_DEAR_OP_COST, + uNFOLDING_NOREP_LIT_COST + ) +import CoreFuns ( digForLambdas, typeOfCoreExpr ) +import CoreSyn -- mostly re-exporting this stuff +import CostCentre ( showCostCentre, noCostCentreAttached, + currentOrSubsumedCosts, ccMentionsId, CostCentre + ) +import Id ( pprIdInUnfolding, getIdUniType, + whatsMentionedInId, Id, DataCon(..) + ) +import IdInfo +import Maybes +import Outputable +import PlainCore ( instCoreExpr ) +import Pretty +import SimplEnv ( UnfoldingGuidance(..) ) +import UniqSet +import Unique ( uniqSupply_u, UniqueSupply ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression} +%* * +%************************************************************************ + +\begin{code} +calcUnfoldingGuidance + :: Bool -- True <=> OK if _scc_s appear in expr + -> Int -- bomb out if size gets bigger than this + -> PlainCoreExpr -- expression to look at + -> UnfoldingGuidance + +calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr + = let + (ty_binders, val_binders, body) = digForLambdas expr + in + case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of + + Nothing -> UnfoldNever + + Just (size, cased_args) + -> let + uf = UnfoldIfGoodArgs + (length ty_binders) + (length val_binders) + [ b `is_elem` cased_args | b <- val_binders ] + size + in + -- pprTrace "calcUnfold:" (ppAbove (ppr PprDebug uf) (ppr PprDebug expr)) + uf + where + is_elem = isIn "calcUnfoldingGuidance" +\end{code} + +\begin{code} +sizeExpr :: Bool -- True <=> _scc_s OK + -> Int -- Bomb out if it gets bigger than this + -> [Id] -- Arguments; we're interested in which of these + -- get case'd + -> PlainCoreExpr + -> Maybe (Int, -- Size + [Id] -- Subset of args which are cased + ) + +sizeExpr scc_s_OK bOMB_OUT_SIZE args expr + = size_up expr + where + size_up (CoVar v) = sizeOne + size_up (CoApp fun arg) = size_up fun `addSizeN` 1 + size_up (CoTyApp fun ty) = size_up fun -- They're free + size_up (CoLit lit) = if isNoRepLit lit + then sizeN uNFOLDING_NOREP_LIT_COST + else sizeOne + + size_up (CoSCC _ (CoCon _ _ _)) = Nothing -- **** HACK ***** + size_up (CoSCC lbl body) + = if scc_s_OK then size_up body else Nothing + + size_up (CoCon con tys args) = sizeN (length args + 1) + size_up (CoPrim op tys args) = sizeN op_cost -- NB: no charge for PrimOp args + where + op_cost = if primOpCanTriggerGC op + then uNFOLDING_DEAR_OP_COST + -- these *tend* to be more expensive; + -- number chosen to avoid unfolding (HACK) + else uNFOLDING_CHEAP_OP_COST + + size_up (CoLam binders body) = size_up body `addSizeN` length binders + size_up (CoTyLam tyvar body) = size_up body + + size_up (CoLet (CoNonRec binder rhs) body) + = size_up rhs + `addSize` + size_up body + `addSizeN` + 1 + + size_up (CoLet (CoRec pairs) body) + = foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs] + `addSize` + size_up body + `addSizeN` + length pairs + + size_up (CoCase scrut alts) + = size_up_scrut scrut + `addSize` + size_up_alts (typeOfCoreExpr scrut) alts + -- We charge for the "case" itself in "size_up_alts" + + ------------ + size_up_alts scrut_ty (CoAlgAlts alts deflt) + = foldr (addSize . size_alg_alt) (size_up_deflt deflt) alts + `addSizeN` + (case (getTyConFamilySize tycon) of { Just n -> n }) + -- 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 + -- think the "case" is likely to go away.) + where + size_alg_alt (con,args,rhs) = size_up rhs + -- Don't charge for args, so that wrappers look cheap + + (tycon, _, _) = getUniDataTyCon scrut_ty + + + size_up_alts _ (CoPrimAlts alts deflt) + = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts + -- *no charge* for a primitive "case"! + where + size_prim_alt (lit,rhs) = size_up rhs + + ------------ + size_up_deflt CoNoDefault = sizeZero + size_up_deflt (CoBindDefault binder rhs) = size_up rhs + + ------------ + -- Scrutinees. There are two things going on here. + -- First, we want to record if we're case'ing an argument + -- Second, we want to charge nothing for the srutinee if it's just + -- a variable. That way wrapper-like things look cheap. + size_up_scrut (CoVar v) | v `is_elem` args = Just (0, [v]) + | otherwise = Just (0, []) + size_up_scrut other = size_up other + + is_elem = isIn "size_up_scrut" + + ------------ + sizeZero = Just (0, []) + sizeOne = Just (1, []) + sizeN n = Just (n, []) + sizeVar v = Just (0, [v]) + + addSizeN Nothing _ = Nothing + addSizeN (Just (n, xs)) m + | tot < bOMB_OUT_SIZE = Just (tot, xs) + | otherwise = -- pprTrace "bomb1:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr]) + Nothing + where + tot = n+m + + addSize Nothing _ = Nothing + addSize _ Nothing = Nothing + addSize (Just (n, xs)) (Just (m, ys)) + | tot < bOMB_OUT_SIZE = Just (tot, xys) + | otherwise = -- pprTrace "bomb2:" (ppCat [ppInt tot, ppInt bOMB_OUT_SIZE, ppr PprDebug expr]) + Nothing + where + tot = n+m + xys = xs ++ ys +\end{code} + +%************************************************************************ +%* * +\subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces} +%* * +%************************************************************************ + +Of course, the main thing we do to unfoldings-for-interfaces is {\em +print} them. But, while we're at it, we collect info about +``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway. + +%************************************************************************ +%* * +\subsubsection{Monad stuff for the unfolding-generation game} +%* * +%************************************************************************ + +\begin{code} +type UnfoldM bndr thing + = IdSet -- in-scope Ids (passed downwards only) + -> (bndr -> Id) -- to extract an Id from a binder (down only) + + -> (Bag Id, -- mentioned global vars (ditto) + Bag TyCon, -- ditto, tycons + Bag Class, -- ditto, classes + Bool) -- True <=> mentions something litlit-ish + + -> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated... +\end{code} + +A little stuff for in-scopery: +\begin{code} +no_in_scopes :: IdSet +add1 :: IdSet -> Id -> IdSet +add_some :: IdSet -> [Id] -> IdSet + +no_in_scopes = emptyUniqSet +in_scopes `add1` x = in_scopes `unionUniqSets` singletonUniqSet x +in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs +\end{code} + +The can-see-inside-monad functions are the usual sorts of things. + +\begin{code} +thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b +thenUf m k in_scopes get_id mentioneds + = case m in_scopes get_id mentioneds of { (v, mentioneds1) -> + k v in_scopes get_id mentioneds1 } + +thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b +thenUf_ m k in_scopes get_id mentioneds + = case m in_scopes get_id mentioneds of { (_, mentioneds1) -> + k in_scopes get_id mentioneds1 } + +mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b] +mapUf f [] = returnUf [] +mapUf f (x:xs) + = f x `thenUf` \ r -> + mapUf f xs `thenUf` \ rs -> + returnUf (r:rs) + +returnUf :: a -> UnfoldM bndr a +returnUf v in_scopes get_id mentioneds = (v, mentioneds) + +addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a +addInScopesUf more_in_scopes m in_scopes get_id mentioneds + = m (in_scopes `add_some` more_in_scopes) get_id mentioneds + +getInScopesUf :: UnfoldM bndr IdSet +getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds) + +extractIdsUf :: [bndr] -> UnfoldM bndr [Id] +extractIdsUf binders in_scopes get_id mentioneds + = (map get_id binders, mentioneds) + +consider_Id :: Id -> UnfoldM bndr () +consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit) + = let + (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var + in + ((), (ids `unionBags` ids2, + tcs `unionBags` tcs2, + clss `unionBags`clss2, + has_litlit)) +\end{code} + +\begin{code} +addToMentionedIdsUf :: Id -> UnfoldM bndr () +addToMentionedTyConsUf :: Bag TyCon -> UnfoldM bndr () +addToMentionedClassesUf :: Bag Class -> UnfoldM bndr () +litlit_oops :: UnfoldM bndr () + +addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit) + = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit)) + +addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit) + = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit)) + +addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit) + = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit)) + +litlit_oops in_scopes get_id (ids, tcs, clss, _) + = ((), (ids, tcs, clss, True)) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Gathering up info for an interface-unfolding} +%* * +%************************************************************************ + +\begin{code} +mentionedInUnfolding + :: (bndr -> Id) -- so we can get Ids out of binders + -> CoreExpr bndr Id -- input expression + -> ([Id], [TyCon], [Class], + -- what we found mentioned in the expr + Bool -- True <=> mentions a ``litlit''-ish thing + -- (the guy on the other side of an interface + -- may not be able to handle it) + ) + +mentionedInUnfolding get_id expr + = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of + (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) -> + (bagToList ids_bag, bagToList tcs_bag, bagToList clss_bag, has_litlit) +\end{code} + +\begin{code} +ment_expr :: CoreExpr bndr Id -> UnfoldM bndr () + +ment_expr (CoVar v) = consider_Id v +ment_expr (CoLit l) = consider_lit l + +ment_expr (CoLam bs body) + = extractIdsUf bs `thenUf` \ bs_ids -> + addInScopesUf bs_ids ( + -- this considering is just to extract any mentioned types/classes + mapUf consider_Id bs_ids `thenUf_` + ment_expr body + ) + +ment_expr (CoTyLam _ body) = ment_expr body + +ment_expr (CoApp fun arg) + = ment_expr fun `thenUf_` + ment_atom arg + +ment_expr (CoTyApp expr ty) + = ment_ty ty `thenUf_` + ment_expr expr + +ment_expr (CoCon c ts as) + = consider_Id c `thenUf_` + mapUf ment_ty ts `thenUf_` + mapUf ment_atom as `thenUf_` + returnUf () + +ment_expr (CoPrim op ts as) + = ment_op op `thenUf_` + mapUf ment_ty ts `thenUf_` + mapUf ment_atom as `thenUf_` + returnUf () + where + ment_op (CCallOp str is_asm may_gc arg_tys res_ty) + = mapUf ment_ty arg_tys `thenUf_` + ment_ty res_ty + ment_op other_op = returnUf () + +ment_expr (CoCase scrutinee alts) + = ment_expr scrutinee `thenUf_` + ment_alts alts + +ment_expr (CoLet (CoNonRec bind rhs) body) + = ment_expr rhs `thenUf_` + extractIdsUf [bind] `thenUf` \ bi@[bind_id] -> + addInScopesUf bi ( + ment_expr body `thenUf_` + consider_Id bind_id ) + +ment_expr (CoLet (CoRec pairs) body) + = let + binders = map fst pairs + rhss = map snd pairs + in + extractIdsUf binders `thenUf` \ binder_ids -> + addInScopesUf binder_ids ( + mapUf ment_expr rhss `thenUf_` + mapUf consider_Id binder_ids `thenUf_` + ment_expr body ) + +ment_expr (CoSCC cc expr) + = (case (ccMentionsId cc) of + Just id -> consider_Id id + Nothing -> returnUf () + ) + `thenUf_` ment_expr expr + +------------- +ment_ty ty + = let + (tycons, clss) = getMentionedTyConsAndClassesFromUniType ty + in + addToMentionedTyConsUf tycons `thenUf_` + addToMentionedClassesUf clss + +------------- + +ment_alts alg_alts@(CoAlgAlts alts deflt) + = mapUf ment_alt alts `thenUf_` + ment_deflt deflt + where + ment_alt alt@(con, params, rhs) + = consider_Id con `thenUf_` + extractIdsUf params `thenUf` \ param_ids -> + addInScopesUf param_ids ( + -- "consider" them so we can chk out their types... + mapUf consider_Id param_ids `thenUf_` + ment_expr rhs ) + +ment_alts (CoPrimAlts alts deflt) + = mapUf ment_alt alts `thenUf_` + ment_deflt deflt + where + ment_alt alt@(lit, rhs) = ment_expr rhs + +---------------- +ment_deflt CoNoDefault + = returnUf () + +ment_deflt d@(CoBindDefault b rhs) + = extractIdsUf [b] `thenUf` \ bi@[b_id] -> + addInScopesUf bi ( + consider_Id b_id `thenUf_` + ment_expr rhs ) + +----------- +ment_atom (CoVarAtom v) = consider_Id v +ment_atom (CoLitAtom l) = consider_lit l + +----------- +consider_lit lit + | isLitLitLit lit = litlit_oops `thenUf_` returnUf () + | otherwise = returnUf () +\end{code} + +%************************************************************************ +%* * +\subsubsection{Printing unfoldings in interfaces} +%* * +%************************************************************************ + +Printing Core-expression unfoldings is sufficiently delicate that we +give it its own function. +\begin{code} +pprCoreUnfolding + :: PlainCoreExpr + -> Pretty + +pprCoreUnfolding expr + = let + (_, renamed) = instCoreExpr uniqSupply_u expr + -- We rename every unfolding with a "steady" unique supply, + -- so that the names won't constantly change. + -- One place we *MUST NOT* use a splittable UniqueSupply! + in + ppr_uf_Expr emptyUniqSet renamed + +ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding") +\end{code} + +\begin{code} +ppr_uf_Expr in_scopes (CoVar v) = pprIdInUnfolding in_scopes v +ppr_uf_Expr in_scopes (CoLit l) = ppr ppr_Unfolding l + +ppr_uf_Expr in_scopes (CoCon c ts as) + = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP, + ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack, + ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack] +ppr_uf_Expr in_scopes (CoPrim op ts as) + = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP, + ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack, + ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack] + +ppr_uf_Expr in_scopes (CoLam binders body) + = ppCat [ppChar '\\', ppIntersperse ppSP (map ppr_uf_Binder binders), + ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add_some` binders) body] + +ppr_uf_Expr in_scopes (CoTyLam tyvar expr) + = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->", + ppr_uf_Expr in_scopes body] + where + (tyvars, body) = collect_tyvars expr + + collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after ) + where (tyvs, e_after) = collect_tyvars e + collect_tyvars other_e = ( [], other_e ) + +ppr_uf_Expr in_scopes expr@(CoApp fun_expr atom) + = let + (fun, args) = collect_args expr [] + in + ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack, + ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack] + where + collect_args (CoApp fun arg) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_uf_Expr in_scopes (CoTyApp expr ty) + = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr, + ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}'] + +ppr_uf_Expr in_scopes (CoCase scrutinee alts) + = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {", + pp_alts alts, ppChar '}'] + where + pp_alts (CoAlgAlts alts deflt) + = ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt] + pp_alts (CoPrimAlts alts deflt) + = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt] + + pp_alg (con, params, rhs) + = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP, + ppIntersperse ppSP (map ppr_uf_Binder params), + ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi] + + pp_prim (lit, rhs) + = ppBesides [ppr ppr_Unfolding lit, + ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi] + + pp_deflt CoNoDefault = ppPStr SLIT("_NO_DEFLT_") + pp_deflt (CoBindDefault binder rhs) + = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "), + ppr_uf_Expr (in_scopes `add1` binder) rhs] + +ppr_uf_Expr in_scopes (CoLet (CoNonRec binder rhs) body) + = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs, + ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body] + +ppr_uf_Expr in_scopes (CoLet (CoRec pairs) body) + = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs), + ppStr "} in ", ppr_uf_Expr new_in_scopes body] + where + sep = ppBeside ppSemi ppSP + new_in_scopes = in_scopes `add_some` map fst pairs + + pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs] + +ppr_uf_Expr in_scopes (CoSCC cc body) + = ASSERT(not (noCostCentreAttached cc)) + ASSERT(not (currentOrSubsumedCosts cc)) + ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body] +\end{code} + +\begin{code} +ppr_uf_Binder :: Id -> Pretty +ppr_uf_Binder v + = ppBesides [ppLparen, pprIdInUnfolding (singletonUniqSet v) v, ppPStr SLIT(" :: "), + ppr ppr_Unfolding (getIdUniType v), ppRparen] + +ppr_uf_Atom in_scopes (CoLitAtom l) = ppr ppr_Unfolding l +ppr_uf_Atom in_scopes (CoVarAtom v) = pprIdInUnfolding in_scopes v +\end{code} diff --git a/ghc/compiler/coreSyn/FreeVars.hi b/ghc/compiler/coreSyn/FreeVars.hi new file mode 100644 index 0000000..ca22a00 --- /dev/null +++ b/ghc/compiler/coreSyn/FreeVars.hi @@ -0,0 +1,41 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface FreeVars where +import AnnCoreSyn(AnnCoreBinding, AnnCoreCaseAlternatives, AnnCoreCaseDefault, AnnCoreExpr', AnnCoreExpr(..)) +import BasicLit(BasicLit) +import Class(Class) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PrimOps(PrimOp) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import UniqSet(IdSet(..), TyVarSet(..), UniqSet(..)) +import Unique(Unique) +data AnnCoreBinding a b c {-# GHC_PRAGMA AnnCoNonRec a (c, AnnCoreExpr' a b c) | AnnCoRec [(a, (c, AnnCoreExpr' a b c))] #-} +data AnnCoreCaseAlternatives a b c {-# GHC_PRAGMA AnnCoAlgAlts [(Id, [a], (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) | AnnCoPrimAlts [(BasicLit, (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) #-} +data AnnCoreCaseDefault a b c {-# GHC_PRAGMA AnnCoNoDefault | AnnCoBindDefault a (c, AnnCoreExpr' a b c) #-} +type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c) +data AnnCoreExpr' a b c {-# GHC_PRAGMA AnnCoVar b | AnnCoLit BasicLit | AnnCoCon Id [UniType] [CoreAtom b] | AnnCoPrim PrimOp [UniType] [CoreAtom b] | AnnCoLam [a] (c, AnnCoreExpr' a b c) | AnnCoTyLam TyVar (c, AnnCoreExpr' a b c) | AnnCoApp (c, AnnCoreExpr' a b c) (CoreAtom b) | AnnCoTyApp (c, AnnCoreExpr' a b c) UniType | AnnCoCase (c, AnnCoreExpr' a b c) (AnnCoreCaseAlternatives a b c) | AnnCoLet (AnnCoreBinding a b c) (c, AnnCoreExpr' a b c) | AnnCoSCC CostCentre (c, AnnCoreExpr' a b c) #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +type CoreExprWithFVs = (FVInfo, AnnCoreExpr' Id Id FVInfo) +type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id +type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id +data FVInfo = FVInfo (UniqFM Id) (UniqFM TyVar) LeakInfo +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +type IdSet = UniqFM Id +data LeakInfo = MightLeak | LeakFree Int +type TyVarSet = UniqFM TyVar +type UniqSet a = UniqFM a +addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +freeTyVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(ASA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM TyVar) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: (FVInfo, AnnCoreExpr' Id Id FVInfo)) -> case u0 of { _ALG_ _TUP_2 (u1 :: FVInfo) (u2 :: AnnCoreExpr' Id Id FVInfo) -> case u1 of { _ALG_ _ORIG_ FreeVars FVInfo (u3 :: UniqFM Id) (u4 :: UniqFM TyVar) (u5 :: LeakInfo) -> u4; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +freeVars :: CoreExpr Id Id -> (FVInfo, AnnCoreExpr' Id Id FVInfo) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +freeVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(SAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM Id) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: (FVInfo, AnnCoreExpr' Id Id FVInfo)) -> case u0 of { _ALG_ _TUP_2 (u1 :: FVInfo) (u2 :: AnnCoreExpr' Id Id FVInfo) -> case u1 of { _ALG_ _ORIG_ FreeVars FVInfo (u3 :: UniqFM Id) (u4 :: UniqFM TyVar) (u5 :: LeakInfo) -> u3; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs new file mode 100644 index 0000000..54a2426 --- /dev/null +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -0,0 +1,609 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +Taken quite directly from the Peyton Jones/Lester paper. + +\begin{code} +#include "HsVersions.h" + +module FreeVars ( + freeVars, + +#ifdef DPH +-- ToDo: DPH: you should probably use addExprFVs now... [WDP] + freeStuff, -- Need a function that gives fvs of + -- an expression. I therefore need a + -- way of passing in candidates or top + -- level will always be empty. +#endif {- Data Parallel Haskell -} + + -- cheap and cheerful variant... + addTopBindsFVs, + + freeVarsOf, freeTyVarsOf, + FVCoreExpr(..), FVCoreBinding(..), + + CoreExprWithFVs(..), -- For the above functions + AnnCoreExpr(..), -- Dito + FVInfo(..), LeakInfo(..), + + -- and to make the interface self-sufficient... + CoreExpr, Id, IdSet(..), TyVarSet(..), UniqSet(..), UniType, + AnnCoreExpr', AnnCoreBinding, AnnCoreCaseAlternatives, + AnnCoreCaseDefault + ) where + + +import PlainCore -- input +import AnnCoreSyn -- output + +import AbsPrel ( PrimOp(..), PrimKind -- for CCallOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( extractTyVarsFromTy ) +import BasicLit ( typeOfBasicLit ) +import Id ( getIdUniType, getIdArity, toplevelishId, isBottomingId ) +import IdInfo -- Wanted for arityMaybe, but it seems you have + -- to import it all... (Death to the Instance Virus!) +import Maybes +import UniqSet +import Util +\end{code} + +%************************************************************************ +%* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression +%* * +%************************************************************************ + +The free variable pass annotates every node in the expression with its +NON-GLOBAL free variables and type variables. + +The ``free type variables'' are defined to be those which are mentioned +in type applications, {\em not} ones which lie buried in the types of Ids. + +*** ALAS: we *do* need to collect tyvars from lambda-bound ids. *** +I've half-convinced myself we don't for case- and letrec bound ids +but I might be wrong. (SLPJ, date unknown) + +\begin{code} +type CoreExprWithFVs = AnnCoreExpr Id Id FVInfo + +type TyVarCands = TyVarSet -- for when we carry around lists of +type IdCands = IdSet -- "candidate" TyVars/Ids. +noTyVarCands = emptyUniqSet +noIdCands = emptyUniqSet + +data FVInfo = FVInfo + IdSet -- Free ids + TyVarSet -- Free tyvars + LeakInfo + +noFreeIds = emptyUniqSet +noFreeTyVars = emptyUniqSet +aFreeId i = singletonUniqSet i +aFreeTyVar t = singletonUniqSet t +is_among = elementOfUniqSet +combine = unionUniqSets +munge_id_ty i = mkUniqSet (extractTyVarsFromTy (getIdUniType i)) + +combineFVInfo (FVInfo fvs1 tfvs1 leak1) (FVInfo fvs2 tfvs2 leak2) + = FVInfo (fvs1 `combine` fvs2) + (tfvs1 `combine` tfvs2) + (leak1 `orLeak` leak2) +\end{code} + +Leak-free-ness is based only on the value, not the type. +In particular, nested collections of constructors are guaranteed leak free. +Function applications are not, except for PAPs. + +Applications of error gets (LeakFree bigArity) -- a hack! + +\begin{code} +data LeakInfo + = MightLeak + | LeakFree Int -- Leak free, and guarantees to absorb this # of + -- args before becoming leaky. + +lEAK_FREE_0 = LeakFree 0 +lEAK_FREE_BIG = LeakFree bigArity + where + bigArity = 1000::Int -- NB: arbitrary + +orLeak :: LeakInfo -> LeakInfo -> LeakInfo +orLeak MightLeak _ = MightLeak +orLeak _ MightLeak = MightLeak +orLeak (LeakFree n) (LeakFree m) = LeakFree (n `min` m) +\end{code} + +Main public interface: +\begin{code} +freeVars :: PlainCoreExpr -> CoreExprWithFVs + +freeVars expr = fvExpr noIdCands noTyVarCands expr +\end{code} + +\subsection{Free variables (and types)} + +We do the free-variable stuff by passing around ``candidates lists'' +of @Ids@ and @TyVars@ that may be considered free. This is useful, +e.g., to avoid considering top-level binders as free variables---don't +put them on the candidates list. + +\begin{code} + +fvExpr :: IdCands -- In-scope Ids + -> TyVarCands -- In-scope tyvars + -> PlainCoreExpr + -> CoreExprWithFVs + +fvExpr id_cands tyvar_cands (CoVar v) + = (FVInfo (if (v `is_among` id_cands) + then aFreeId v + else noFreeIds) + noFreeTyVars + leakiness, + AnnCoVar v) + where + leakiness + | isBottomingId v = lEAK_FREE_BIG -- Hack + | otherwise = case arityMaybe (getIdArity v) of + Nothing -> lEAK_FREE_0 + Just arity -> LeakFree arity + +fvExpr id_cands tyvar_cands (CoLit k) + = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnCoLit k) + +fvExpr id_cands tyvar_cands (CoCon c tys args) + = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoCon c tys args) + where + args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args + tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys + +fvExpr id_cands tyvar_cands (CoPrim op@(CCallOp _ _ _ _ res_ty) tys args) + = ASSERT (null tys) + (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args) + where + args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args + tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars (res_ty:tys) + +fvExpr id_cands tyvar_cands (CoPrim op tys args) + = (FVInfo args_fvs tfvs lEAK_FREE_0, AnnCoPrim op tys args) + where + args_fvs = foldr (combine . freeAtom id_cands) noFreeIds args + tfvs = foldr (combine . freeTy tyvar_cands) noFreeTyVars tys + +fvExpr id_cands tyvar_cands (CoLam binders body) + = (FVInfo (freeVarsOf body2 `minusUniqSet` mkUniqSet binders) + (freeTyVarsOf body2 `combine` binder_ftvs) + leakiness, + AnnCoLam binders body2) + where + -- We need to collect free tyvars from the binders + body2 = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands body + + binder_ftvs + = foldr (combine . munge_id_ty) noFreeTyVars binders + + no_args = length binders + leakiness = case leakinessOf body2 of + MightLeak -> LeakFree no_args + LeakFree n -> LeakFree (n + no_args) + +fvExpr id_cands tyvar_cands (CoTyLam tyvar body) + = (FVInfo (freeVarsOf body2) + (freeTyVarsOf body2 `minusUniqSet` aFreeTyVar tyvar) + (leakinessOf body2), + AnnCoTyLam tyvar body2) + where + body2 = fvExpr id_cands (aFreeTyVar tyvar `combine` tyvar_cands) body + +fvExpr id_cands tyvar_cands (CoApp fun arg) + = (FVInfo (freeVarsOf fun2 `combine` fvs_arg) + (freeTyVarsOf fun2) + leakiness, + AnnCoApp fun2 arg) + where + fun2 = fvExpr id_cands tyvar_cands fun + fvs_arg = freeAtom id_cands arg + + leakiness = case leakinessOf fun2 of + LeakFree n | n>1 -> LeakFree (n-1) -- Note > not >= + other -> MightLeak + +fvExpr id_cands tyvar_cands (CoTyApp expr ty) + = (FVInfo (freeVarsOf expr2) + (freeTyVarsOf expr2 `combine` tfvs_arg) + (leakinessOf expr2), + AnnCoTyApp expr2 ty) + where + expr2 = fvExpr id_cands tyvar_cands expr + tfvs_arg = freeTy tyvar_cands ty + +fvExpr id_cands tyvar_cands (CoCase expr alts) + = (combineFVInfo expr_fvinfo alts_fvinfo, + AnnCoCase expr2 alts') + where + expr2@(expr_fvinfo,_) = fvExpr id_cands tyvar_cands expr + (alts_fvinfo, alts') = annotate_alts alts + + annotate_alts (CoAlgAlts alts deflt) + = (fvinfo, AnnCoAlgAlts alts' deflt') + where + (alts_fvinfo_s, alts') = unzip (map ann_boxed_alt alts) + (deflt_fvinfo, deflt') = annotate_default deflt + fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s + + ann_boxed_alt (con, params, rhs) + = (FVInfo (freeVarsOf rhs' `minusUniqSet` mkUniqSet params) + (freeTyVarsOf rhs' `combine` param_ftvs) + (leakinessOf rhs'), + (con, params, rhs')) + where + rhs' = fvExpr (mkUniqSet params `combine` id_cands) tyvar_cands rhs + param_ftvs = foldr (combine . munge_id_ty) noFreeTyVars params + -- We need to collect free tyvars from the binders + + annotate_alts (CoPrimAlts alts deflt) + = (fvinfo, AnnCoPrimAlts alts' deflt') + where + (alts_fvinfo_s, alts') = unzip (map ann_unboxed_alt alts) + (deflt_fvinfo, deflt') = annotate_default deflt + fvinfo = foldr combineFVInfo deflt_fvinfo alts_fvinfo_s + + ann_unboxed_alt (lit, rhs) = (rhs_info, (lit, rhs')) + where + rhs'@(rhs_info,_) = fvExpr id_cands tyvar_cands rhs + +#ifdef DPH + annotate_alts id_cands tyvar_cands (CoParAlgAlts tycon ctxt binders alts deflt) + = ((alts_fvs `minusUniqSet` (mkUniqSet binders)) `combine` deflt_fvs, + AnnCoParAlgAlts tycon ctxt binders alts' deflt') + where + (alts_fvs_sets, alts') = unzip (map (ann_boxed_par_alt id_cands tyvar_cands) alts) + alts_fvs = unionManyUniqSets alts_fvs_sets + (deflt_fvs, ???ToDo:DPH, deflt') = annotate_default deflt + + ann_boxed_par_alt id_cands tyvar_cands (con, rhs) + = (rhs_fvs, (con, rhs')) + where + rhs' = fvExpr (mkUniqSet binders `combine` id_cands) tyvar_cands rhs + rhs_fvs = freeVarsOf rhs' + + annotate_alts id_cands tyvar_cands (CoParPrimAlts tycon ctxt alts deflt) + = (alts_fvs `combine` deflt_fvs, + AnnCoParPrimAlts tycon ctxt alts' deflt') + where + (alts_fvs_sets, alts') = unzip (map (ann_unboxed_par_alt id_cands tyvar_cands) alts) + alts_fvs = unionManyUniqSets alts_fvs_sets + (deflt_fvs, ??? ToDo:DPH, deflt') = annotate_default deflt + + ann_unboxed_par_alt id_cands tyvar_cands (lit, rhs) + = (rhs_fvs, (lit, rhs')) + where + rhs' = fvExpr id_cands tyvar_cands rhs + rhs_fvs = freeVarsOf rhs' +#endif {- Data Parallel Haskell -} + + annotate_default CoNoDefault = (FVInfo noFreeIds noFreeTyVars lEAK_FREE_BIG, + AnnCoNoDefault) + + annotate_default (CoBindDefault binder rhs) + = (FVInfo (freeVarsOf rhs' `minusUniqSet` aFreeId binder) + (freeTyVarsOf rhs' `combine` binder_ftvs) + (leakinessOf rhs'), + AnnCoBindDefault binder rhs') + where + rhs' = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands rhs + binder_ftvs = munge_id_ty binder + -- We need to collect free tyvars from the binder + +fvExpr id_cands tyvar_cands (CoLet (CoNonRec binder rhs) body) + = (FVInfo (freeVarsOf rhs' `combine` body_fvs) + (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs) + (leakinessOf rhs' `orLeak` leakinessOf body2), + AnnCoLet (AnnCoNonRec binder rhs') body2) + where + rhs' = fvExpr id_cands tyvar_cands rhs + body2 = fvExpr (aFreeId binder `combine` id_cands) tyvar_cands body + body_fvs = freeVarsOf body2 `minusUniqSet` aFreeId binder + binder_ftvs = munge_id_ty binder + -- We need to collect free tyvars from the binder + +fvExpr id_cands tyvar_cands (CoLet (CoRec binds) body) + = (FVInfo (binds_fvs `combine` body_fvs) + (rhss_tfvs `combine` freeTyVarsOf body2 `combine` binders_ftvs) + (leakiness_of_rhss `orLeak` leakinessOf body2), + AnnCoLet (AnnCoRec (binders `zip` rhss')) body2) + where + (binders, rhss) = unzip binds + new_id_cands = binders_set `combine` id_cands + binders_set = mkUniqSet binders + rhss' = map (fvExpr new_id_cands tyvar_cands) rhss + + FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss + = foldr1 combineFVInfo [info | (info,_) <- rhss'] + + binds_fvs = rhss_fvs `minusUniqSet` binders_set + body2 = fvExpr new_id_cands tyvar_cands body + body_fvs = freeVarsOf body2 `minusUniqSet` binders_set + binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders + -- We need to collect free tyvars from the binders + +fvExpr id_cands tyvar_cands (CoSCC label expr) + = (fvinfo, AnnCoSCC label expr2) + where + expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr + +#ifdef DPH +fvExpr id_cands tyvar_cands e@(CoParCon c ctxt tys args) + = ((args_fvs, typeOfCoreExpr e), AnnCoParCon c ctxt tys args') + where + args' = map (fvExpr id_cands tyvar_cands) args + args_fvs = unionManyUniqSets [ fvs | ((fvs,_), _) <- args' ] + +fvExpr id_cands tyvar_cands e@(CoParComm ctxt expr comm) + = ((expr_fvs `combine` comm_fvs, tyOf expr2), AnnCoParComm ctxt expr2 comm') + where + expr2 = fvExpr id_cands tyvar_cands expr + expr_fvs = freeVarsOf expr2 + (comm_fvs,comm') = free_stuff_comm id_cands tyvar_cands comm + + free_stuff_comm id_cands tyvar_cands (CoParSend exprs) + = let exprs' = map (fvExpr id_cands tyvar_cands) exprs in + let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ] in + (exprs_fvs,AnnCoParSend exprs') + + free_stuff_comm id_cands tyvar_cands (CoParFetch exprs) + = let exprs' = map (fvExpr id_cands tyvar_cands) exprs in + let exprs_fvs = unionManyUniqSets [fvs | ((fvs,_), _) <- exprs' ] in + (exprs_fvs,AnnCoParFetch exprs') + + free_stuff_comm id_cands tyvar_cands (CoToPodized) + = (emptyUniqSet, AnnCoToPodized) + + free_stuff_comm id_cands tyvar_cands (CoFromPodized) + = (emptyUniqSet, AnnCoFromPodized) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +freeAtom :: IdCands -> PlainCoreAtom -> IdSet + +freeAtom cands (CoLitAtom k) = noFreeIds +freeAtom cands (CoVarAtom v) | v `is_among` cands = aFreeId v + | otherwise = noFreeIds + +freeTy :: TyVarCands -> UniType -> TyVarSet + +freeTy cands ty = mkUniqSet (extractTyVarsFromTy ty) `intersectUniqSets` cands + +freeVarsOf :: CoreExprWithFVs -> IdSet +freeVarsOf (FVInfo free_vars _ _, _) = free_vars + +freeTyVarsOf :: CoreExprWithFVs -> TyVarSet +freeTyVarsOf (FVInfo _ free_tyvars _, _) = free_tyvars + +leakinessOf :: CoreExprWithFVs -> LeakInfo +leakinessOf (FVInfo _ _ leakiness, _) = leakiness +\end{code} + + +%************************************************************************ +%* * +\section[freevars-binders]{Attaching free variables to binders +%* * +%************************************************************************ + + +Here's an variant of the free-variable pass, which pins free-variable +information on {\em binders} rather than every single jolly +expression! +\begin{itemize} +\item + The free vars attached to a lambda binder are the free vars of the + whole lambda abstraction. If there are multiple binders, they are + each given the same free-var set. +\item + The free vars attached to a let(rec) binder are the free vars of the + rhs of the binding. In the case of letrecs, this set excludes the + binders themselves. +\item + The free vars attached to a case alternative binder are the free + vars of the alternative, excluding the alternative's binders. +\end{itemize} + +There's a predicate carried in which tells what is a free-var +candidate. It is passed the Id and a set of in-scope Ids. + +(Global) constructors used on the rhs in a CoCon are also treated as +potential free-var candidates (though they will not be recorded in the +in-scope set). The predicate must decide if they are to be recorded as +free-vars. + +As it happens this is only ever used by the Specialiser! + +\begin{code} +type FVCoreBinder = (Id, IdSet) +type FVCoreExpr = CoreExpr FVCoreBinder Id +type FVCoreBinding = CoreBinding FVCoreBinder Id + +type InterestingIdFun + = IdSet -- Non-top-level in-scope variables + -> Id -- The Id being looked at + -> Bool -- True <=> interesting +\end{code} + +\begin{code} +addExprFVs :: InterestingIdFun -- "Interesting id" predicate + -> IdSet -- In scope ids + -> PlainCoreExpr + -> (FVCoreExpr, IdSet) + +addExprFVs fv_cand in_scope (CoVar v) + = (CoVar v, if fv_cand in_scope v + then aFreeId v + else noFreeIds) + +addExprFVs fv_cand in_scope (CoLit lit) = (CoLit lit, noFreeIds) + +addExprFVs fv_cand in_scope (CoCon con tys args) + = (CoCon con tys args, + if fv_cand in_scope con + then aFreeId con + else noFreeIds + `combine` + unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args)) + +addExprFVs fv_cand in_scope (CoPrim op tys args) + = (CoPrim op tys args, + unionManyUniqSets (map (fvsOfAtom fv_cand in_scope) args)) + +addExprFVs fv_cand in_scope (CoLam binders body) + = (CoLam (binders `zip` (repeat lam_fvs)) new_body, lam_fvs) + where + binder_set = mkUniqSet binders + new_in_scope = in_scope `combine` binder_set + (new_body, body_fvs) = addExprFVs fv_cand new_in_scope body + lam_fvs = body_fvs `minusUniqSet` binder_set + +addExprFVs fv_cand in_scope (CoTyLam tyvar body) + = (CoTyLam tyvar body2, body_fvs) + where + (body2, body_fvs) = addExprFVs fv_cand in_scope body + +addExprFVs fv_cand in_scope (CoApp fun arg) + = (CoApp fun2 arg, fun_fvs `combine` fvsOfAtom fv_cand in_scope arg) + where + (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun + +addExprFVs fv_cand in_scope (CoTyApp fun ty) + = (CoTyApp fun2 ty, fun_fvs) + where + (fun2, fun_fvs) = addExprFVs fv_cand in_scope fun + +addExprFVs fv_cand in_scope (CoCase scrut alts) + = (CoCase scrut' alts', scrut_fvs `combine` alts_fvs) + where + (scrut', scrut_fvs) = addExprFVs fv_cand in_scope scrut + + (alts', alts_fvs) + = case alts of + CoAlgAlts alg_alts deflt -> (CoAlgAlts alg_alts' deflt', fvs) + where + (alg_alts', alt_fvs) = unzip (map do_alg_alt alg_alts) + (deflt', deflt_fvs) = do_deflt deflt + fvs = unionManyUniqSets (deflt_fvs : alt_fvs) + + CoPrimAlts prim_alts deflt -> (CoPrimAlts prim_alts' deflt', fvs) + where + (prim_alts', alt_fvs) = unzip (map do_prim_alt prim_alts) + (deflt', deflt_fvs) = do_deflt deflt + fvs = unionManyUniqSets (deflt_fvs : alt_fvs) + + do_alg_alt :: (Id, [Id], PlainCoreExpr) + -> ((Id, [FVCoreBinder], FVCoreExpr), IdSet) + + do_alg_alt (con, args, rhs) = ((con, args `zip` (repeat fvs), rhs'), fvs) + where + new_in_scope = in_scope `combine` arg_set + (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs + fvs = rhs_fvs `minusUniqSet` arg_set + arg_set = mkUniqSet args + + do_prim_alt (lit, rhs) = ((lit, rhs'), rhs_fvs) + where + (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs + + do_deflt CoNoDefault = (CoNoDefault, noFreeIds) + do_deflt (CoBindDefault var rhs) + = (CoBindDefault (var,fvs) rhs', fvs) + where + new_in_scope = in_scope `combine` var_set + (rhs', rhs_fvs) = addExprFVs fv_cand new_in_scope rhs + fvs = rhs_fvs `minusUniqSet` var_set + var_set = aFreeId var + +addExprFVs fv_cand in_scope (CoLet binds body) + = (CoLet binds' body2, fvs_binds `combine` (fvs_body `minusUniqSet` binder_set)) + where + (binds', fvs_binds, new_in_scope, binder_set) + = addBindingFVs fv_cand in_scope binds + + (body2, fvs_body) = addExprFVs fv_cand new_in_scope body + +addExprFVs fv_cand in_scope (CoSCC label expr) + = (CoSCC label expr2, expr_fvs) + where + (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr + +-- ToDo: DPH: add stuff here +\end{code} + +\begin{code} +addBindingFVs + :: InterestingIdFun -- "Interesting id" predicate + -> IdSet -- In scope ids + -> PlainCoreBinding + -> (FVCoreBinding, + IdSet, -- Free vars of binding group + IdSet, -- Augmented in-scope Ids + IdSet) -- Set of Ids bound by this binding + +addBindingFVs fv_cand in_scope (CoNonRec binder rhs) + = (CoNonRec binder' rhs', fvs, new_in_scope, binder_set) + where + ((binder', rhs'), fvs) = do_pair fv_cand in_scope binder_set (binder, rhs) + new_in_scope = in_scope `combine` binder_set + binder_set = aFreeId binder + +addBindingFVs fv_cand in_scope (CoRec pairs) + = (CoRec pairs', unionManyUniqSets fvs_s, new_in_scope, binder_set) + where + binders = [binder | (binder,_) <- pairs] + binder_set = mkUniqSet binders + new_in_scope = in_scope `combine` binder_set + (pairs', fvs_s) = unzip (map (do_pair fv_cand new_in_scope binder_set) pairs) +\end{code} + +\begin{code} +addTopBindsFVs + :: InterestingIdFun -- "Interesting id" predicate + -> [PlainCoreBinding] + -> ([FVCoreBinding], + IdSet) + +addTopBindsFVs fv_cand [] = ([], noFreeIds) +addTopBindsFVs fv_cand (b:bs) + = let + (b', fvs_b, _, _) = addBindingFVs fv_cand noFreeIds b + (bs', fvs_bs) = addTopBindsFVs fv_cand bs + in + (b' : bs', fvs_b `combine` fvs_bs) +\end{code} + +\begin{code} +fvsOfAtom :: InterestingIdFun -- "Interesting id" predicate + -> IdSet -- In scope ids + -> PlainCoreAtom + -> IdSet + +fvsOfAtom fv_cand in_scope (CoVarAtom v) + = if fv_cand in_scope v + then aFreeId v + else noFreeIds +fvsOfAtom _ _ _ = noFreeIds -- if a literal... + +do_pair :: InterestingIdFun -- "Interesting id" predicate + -> IdSet -- In scope ids + -> IdSet + -> (Id, PlainCoreExpr) + -> ((FVCoreBinder, FVCoreExpr), IdSet) + +do_pair fv_cand in_scope binder_set (binder,rhs) + = (((binder, fvs), rhs'), fvs) + where + (rhs', rhs_fvs) = addExprFVs fv_cand in_scope rhs + fvs = rhs_fvs `minusUniqSet` binder_set +\end{code} diff --git a/ghc/compiler/coreSyn/Jmakefile b/ghc/compiler/coreSyn/Jmakefile new file mode 100644 index 0000000..3e0bd41 --- /dev/null +++ b/ghc/compiler/coreSyn/Jmakefile @@ -0,0 +1,11 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) +HaskellSuffixRules() + +/* LIT2LATEX_OPTS=-tbird */ + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTargetWithNamedOutput(root,lit,root-standalone) diff --git a/ghc/compiler/coreSyn/PlainCore.hi b/ghc/compiler/coreSyn/PlainCore.hi new file mode 100644 index 0000000..842fb14 --- /dev/null +++ b/ghc/compiler/coreSyn/PlainCore.hi @@ -0,0 +1,357 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PlainCore where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CharSeq(CSeq) +import Class(Class, ClassOp, cmpClass) +import CmdLineOpts(GlobalSwitch) +import CoreFuns(atomToExpr, bindersOf, coreExprArity, digForLambdas, escErrorMsg, exprSmallEnoughToDup, instCoreBindings, instCoreExpr, isWrapperFor, manifestlyBottom, manifestlyWHNF, maybeErrorApp, mkCoApps, mkCoLam, mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, mkCoLetrecAny, mkCoLetrecNoUnboxed, mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, mkCoTyApps, mkCoTyLam, mkCoreIfThenElse, mkErrorCoApp, mkFunction, nonErrorRHSs, pairsFromCoreBinds, squashableDictishCcExpr, substCoreExpr, substCoreExprUS, typeOfCoreAlts, typeOfCoreExpr) +import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs, mkCoTyApp, pprCoreExpr) +import CoreUnfold(calcUnfoldingGuidance, mentionedInUnfolding, pprCoreUnfolding) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import FreeVars(FVCoreBinding(..), FVCoreExpr(..), addTopBindsFVs) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo) +import InstEnv(InstTemplate) +import Maybes(Labda) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SimplEnv(UnfoldingDetails, UnfoldingGuidance) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TyVarEnv(..), TypeEnv(..)) +import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType, cmpUniType) +import UniqFM(UniqFM) +import UniqSet(IdSet(..), UniqSet(..)) +import Unique(UniqSM(..), Unique, UniqueSupply, initUs) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data CoreArg a = TypeArg UniType | ValArg (CoreAtom a) +data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit +data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] +data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) +data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b) +data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id +type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +type PlainCoreArg = CoreArg Id +type PlainCoreAtom = CoreAtom Id +type PlainCoreBinding = CoreBinding Id Id +type PlainCoreCaseAlternatives = CoreCaseAlternatives Id Id +type PlainCoreCaseDefault = CoreCaseDefault Id Id +type PlainCoreExpr = CoreExpr Id Id +type PlainCoreProgram = [CoreBinding Id Id] +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +type TyVarEnv a = UniqFM a +type TypeEnv = UniqFM UniType +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type IdSet = UniqFM Id +type UniqSet a = UniqFM a +type UniqSM a = UniqueSupply -> (UniqueSupply, a) +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +cmpClass :: Class -> Class -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +atomToExpr :: CoreAtom b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: CoreAtom u1) -> case u2 of { _ALG_ _ORIG_ CoreSyn CoVarAtom (u3 :: u1) -> _!_ _ORIG_ CoreSyn CoVar [u0, u1] [u3]; _ORIG_ CoreSyn CoLitAtom (u4 :: BasicLit) -> _!_ _ORIG_ CoreSyn CoLit [u0, u1] [u4]; _NO_DEFLT_ } _N_ #-} +bindersOf :: CoreBinding b a -> [b] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +escErrorMsg :: [Char] -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +exprSmallEnoughToDup :: CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +isWrapperFor :: CoreExpr Id Id -> Id -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +manifestlyBottom :: CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +manifestlyWHNF :: CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ #-} +mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetAny, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetNoUnboxed, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetUnboxedToCase, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-} +mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-} +mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pprBigCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +pprPlainCoreBinding :: PprStyle -> CoreBinding Id Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +pprTypedCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LSLL" _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: UniqueSupply) (u1 :: UniqFM (CoreExpr Id Id)) (u2 :: UniqFM UniType) (u3 :: CoreExpr Id Id) -> _APP_ _ORIG_ CoreFuns substCoreExprUS [ u1, u2, u3, u0 ] _N_ #-} +substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id) + {-# GHC_PRAGMA _A_ 3 _U_ 2222 _N_ _S_ "SLL" _N_ _N_ #-} +typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfCoreExpr :: CoreExpr Id Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 2 2 XX 3 _/\_ u0 u1 -> \ (u2 :: CoreExpr u0 u1) (u3 :: UniType) -> _!_ _ORIG_ CoreSyn CoTyApp [u0, u1] [u2, u3] _N_ #-} +pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-} +calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-} +mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +initUs :: UniqueSupply -> (UniqueSupply -> (UniqueSupply, a)) -> (UniqueSupply, a) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: UniqueSupply) (u2 :: UniqueSupply -> (UniqueSupply, u0)) -> _APP_ u2 [ u1 ] _N_ #-} +instance Eq Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Demand -> Demand -> Bool), (Demand -> Demand -> Bool)] [_CONSTM_ Eq (==) (Demand), _CONSTM_ Eq (/=) (Demand)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Demand}}, (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Demand), (Demand -> Demand -> Demand), (Demand -> Demand -> _CMP_TAG)] [_DFUN_ Eq (Demand), _CONSTM_ Ord (<) (Demand), _CONSTM_ Ord (<=) (Demand), _CONSTM_ Ord (>=) (Demand), _CONSTM_ Ord (>) (Demand), _CONSTM_ Ord max (Demand), _CONSTM_ Ord min (Demand), _CONSTM_ Ord _tagCmp (Demand)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable a => Outputable (CoreArg a) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (CoreAtom a) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreBinding a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreBinding u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreBinding { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreExpr a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreExpr u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreExpr { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Demand) _N_ + ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Text Demand + {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Demand, [Char])]), (Int -> Demand -> [Char] -> [Char]), ([Char] -> [([Demand], [Char])]), ([Demand] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Demand), _CONSTM_ Text showsPrec (Demand), _CONSTM_ Text readList (Demand), _CONSTM_ Text showList (Demand)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Demand, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Demand) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> Demand -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_, + readList = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + showList = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/coreSyn/PlainCore.lhs b/ghc/compiler/coreSyn/PlainCore.lhs new file mode 100644 index 0000000..4aaf948 --- /dev/null +++ b/ghc/compiler/coreSyn/PlainCore.lhs @@ -0,0 +1,185 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[PlainCore]{``Plain'' core syntax: the usual parameterisation} + +This module defines a particular parameterisation of the @CoreSyntax@ +data type. Both binders and bindees are just @Ids@. This is the +normal thing. + +\begin{code} +#include "HsVersions.h" + +module PlainCore ( + PlainCoreProgram(..), PlainCoreBinding(..), PlainCoreExpr(..), + PlainCoreAtom(..), PlainCoreCaseAlternatives(..), + PlainCoreCaseDefault(..), PlainCoreArg(..), +#ifdef DPH + PlainCoreParQuals(..), + PlainCoreParCommunicate(..), + CoreParCommunicate(..), + CoreParQuals(..), + isParCoreCaseAlternative, + mkNonRecBinds, +#endif + pprPlainCoreBinding, + pprBigCoreBinder, pprTypedCoreBinder, -- not exported: pprBabyCoreBinder, + + CoreBinding(..), CoreExpr(..), CoreAtom(..), -- re-exported + CoreCaseAlternatives(..), CoreCaseDefault(..), + pprCoreExpr, + + CoreArg(..), applyToArgs, decomposeArgs, collectArgs, + + -- and the related utility functions from CoreFuns... + + typeOfCoreExpr, typeOfCoreAlts, + instCoreExpr, substCoreExpr, -- UNUSED: cloneCoreExpr, + substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS, + instCoreBindings, + mkCoLam, mkCoreIfThenElse, +-- mkCoApp, mkCoCon, mkCoPrim, -- no need for export + mkCoApps, + mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, + mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, + mkCoLetrecAny, mkCoLetrecNoUnboxed, + mkCoTyLam, mkCoTyApp, mkCoTyApps, + mkErrorCoApp, escErrorMsg, + pairsFromCoreBinds, + mkFunction, atomToExpr, + digForLambdas, + exprSmallEnoughToDup, + manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs, + coreExprArity, + isWrapperFor, + maybeErrorApp, +--UNUSED: boilsDownToConApp, + nonErrorRHSs, bindersOf, + squashableDictishCcExpr, + + calcUnfoldingGuidance, + pprCoreUnfolding, + mentionedInUnfolding, + + -- and one variant of free-var-finding stuff: + addTopBindsFVs, FVCoreExpr(..), FVCoreBinding(..), + + -- and to make the interface self-sufficient ... + Outputable(..), NamedThing(..), + ExportFlag, SrcLoc, Unique, + Pretty(..), PprStyle, PrettyRep, + + BasicLit, BinderInfo, Class, Id, Demand, IdInfo, FullName, + UnfoldingGuidance, UniType, TauType(..), ThetaType(..), + SigmaType(..), TyVar, TyCon, CostCentre, PrimOp, UniqueSupply, + UniqSM(..), IdEnv(..), UniqFM, + TyVarEnv(..), TypeEnv(..), IdSet(..), UniqSet(..), + Maybe, Bag + IF_ATTACK_PRAGMAS(COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + IF_ATTACK_PRAGMAS(COMMA initUs) -- profiling + +-- NOTE(hilly) Added UniqSM for cloneFunctions + + ) where + +--IMPORT_Trace -- ToDo: rm (debugging) + +import CoreSyn -- mostly re-exporting this stuff +import CoreFuns +import CoreUnfold + +import AbsUniType ( TauType(..), ThetaType(..), SigmaType(..), + Class, UniType, FullName + IF_ATTACK_PRAGMAS(COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import FreeVars +import Id ( getIdUniType, getIdStrictness, getIdInfo, + Id, TypeEnv(..) + ) +import IdEnv -- ( nullIdEnv, IdEnv ) +import IdInfo +import Maybes ( Maybe(..) ) +import Outputable +import Pretty +import Unique ( UniqSM(..), Unique + IF_ATTACK_PRAGMAS(COMMA initUs) + ) +import Util + +infixr 9 `thenUf`, `thenUf_` +\end{code} + +The ``Core things'' just described are parameterised with respect to +the information kept about binding occurrences and bound occurrences +of variables. + +The ``Plain Core things'' are instances of the ``Core things'' in +which nothing but a name is kept, for both binders and variables. +\begin{code} +type PlainCoreProgram = [CoreBinding Id Id] +type PlainCoreBinding = CoreBinding Id Id +type PlainCoreExpr = CoreExpr Id Id +type PlainCoreAtom = CoreAtom Id +#ifdef DPH +type PlainCoreParQuals = CoreParQuals Id Id +type PlainCoreParCommunicate = CoreParCommunicate Id Id +#endif {- Data Parallel Haskell -} +type PlainCoreCaseAlternatives = CoreCaseAlternatives Id Id +type PlainCoreCaseDefault = CoreCaseDefault Id Id + +type PlainCoreArg = CoreArg Id +\end{code} + +%************************************************************************ +%* * +\subsection[printing-PlainCore]{Printing @PlainCore@ things} +%* * +%************************************************************************ + +The most common core-printing interface: +\begin{code} +pprPlainCoreBinding :: PprStyle -> PlainCoreBinding -> Pretty + +pprPlainCoreBinding sty (CoNonRec binder expr) + = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) + 4 (pprCoreExpr sty pprBigCoreBinder pprBabyCoreBinder ppr expr) + +pprPlainCoreBinding sty (CoRec binds) + = ppAboves [ifPprDebug sty (ppStr "{- plain CoRec -}"), + ppAboves (map ppr_bind binds), + ifPprDebug sty (ppStr "{- end plain CoRec -}")] + where + ppr_bind (binder, expr) + = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) + 4 (pprCoreExpr sty pprBigCoreBinder pprBabyCoreBinder ppr expr) +\end{code} + +Other printing bits-and-bobs used with the general @pprCoreBinding@ +and @pprCoreExpr@ functions. +\begin{code} +pprBigCoreBinder sty binder + = ppAboves [sig, pragmas, ppr sty binder] + where + sig = ifnotPprShowAll sty ( + ppHang (ppCat [ppr sty binder, ppStr "::"]) + 4 (ppr sty (getIdUniType binder))) + + pragmas = ifnotPprForUser sty ( + ppIdInfo sty binder True{-specs, please-} id nullIdEnv (getIdInfo binder)) + +pprBabyCoreBinder sty binder + = ppCat [ppr sty binder, pp_strictness] + where + pp_strictness + = case (getIdStrictness binder) of + NoStrictnessInfo -> ppNil + BottomGuaranteed -> ppStr "{- _!_ -}" + StrictnessInfo xx _ -> ppStr ("{- " ++ (showList xx "") ++ " -}") + +pprTypedCoreBinder sty binder + = ppBesides [ppLparen, ppCat [ppr sty binder, + ppStr "::", ppr sty (getIdUniType binder)], + ppRparen] +\end{code} diff --git a/ghc/compiler/coreSyn/TaggedCore.hi b/ghc/compiler/coreSyn/TaggedCore.hi new file mode 100644 index 0000000..dab7658 --- /dev/null +++ b/ghc/compiler/coreSyn/TaggedCore.hi @@ -0,0 +1,130 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TaggedCore where +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import CoreFuns(unTagBinders, unTagBindersAlts) +import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName, ShortName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CoreArg a = TypeArg UniType | ValArg (CoreAtom a) +data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit +data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] +data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) +data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b) +data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +type SimplifiableBinder = (Id, BinderInfo) +type SimplifiableCoreAtom = CoreAtom Id +type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id +type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives (Id, BinderInfo) Id +type SimplifiableCoreCaseDefault = CoreCaseDefault (Id, BinderInfo) Id +type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +type TaggedBinder a = (Id, a) +type TaggedCoreAtom a = CoreAtom Id +type TaggedCoreBinding a = CoreBinding (Id, a) Id +type TaggedCoreCaseAlternatives a = CoreCaseAlternatives (Id, a) Id +type TaggedCoreCaseDefault a = CoreCaseDefault (Id, a) Id +type TaggedCoreExpr a = CoreExpr (Id, a) Id +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable BinderInfo + {-# GHC_PRAGMA _M_ BinderInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BinderInfo) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable a => Outputable (CoreArg a) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable a => Outputable (CoreAtom a) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreBinding a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreBinding u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreBinding { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b) => Outputable (CoreExpr a b) + {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreExpr u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreExpr { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/coreSyn/TaggedCore.lhs b/ghc/compiler/coreSyn/TaggedCore.lhs new file mode 100644 index 0000000..9af8bb1 --- /dev/null +++ b/ghc/compiler/coreSyn/TaggedCore.lhs @@ -0,0 +1,93 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TaggedCore]{``Tagged binder'' core syntax (including \tr{Simplifiable*})} + +This module defines a particular parameterisation of the @CoreSyntax@ +data type. For ``binders,'' we use a pair: an @Id@ (the actual +binder) and a ``tag''---any old thing we want to pin on. +Bindees are @Ids@, as usual. + +By far the prevalent use is with a ``tag'' of a @BinderInfo@, as used +in the simplifier. So we have a full swatch of synonyms for +\tr{Simplifiable} this and that. + +\begin{code} +#include "HsVersions.h" + +module TaggedCore ( + TaggedBinder(..), TaggedCoreBinding(..), TaggedCoreExpr(..), + TaggedCoreAtom(..), TaggedCoreCaseAlternatives(..), + TaggedCoreCaseDefault(..), +#ifdef DPH + TaggedCoreParQuals(..), + TaggedCoreParCommunicate(..), + CoreParCommunicate(..), + CoreParQuals(..), +#endif + unTagBinders, unTagBindersAlts, + + CoreArg(..), applyToArgs, decomposeArgs, collectArgs, + + SimplifiableBinder(..), SimplifiableCoreBinding(..), + SimplifiableCoreExpr(..), SimplifiableCoreAtom(..), + SimplifiableCoreCaseAlternatives(..), + SimplifiableCoreCaseDefault(..), +#ifdef DPH + SimplifiableCoreParQuals(..), + SimplifiableCoreParCommunicate(..), +#endif + + CoreBinding(..), CoreExpr(..), CoreAtom(..), -- re-exported + CoreCaseAlternatives(..), CoreCaseDefault(..), + + -- and to make the interface self-sufficient ... + Outputable(..), NamedThing(..), + ExportFlag, Pretty(..), PprStyle, PrettyRep, + + BasicLit, BinderInfo, GlobalSwitch, Id, PrimOp, CostCentre, + SrcLoc, TyCon, TyVar, UniType, Unique + ) where + +import CoreFuns ( unTagBinders, unTagBindersAlts, digForLambdas ) +import CoreSyn -- mostly re-exporting this stuff +import BinderInfo ( BinderInfo ) +import Outputable +import Util +\end{code} + +\begin{code} +type TaggedBinder tag = (Id, tag) + +type TaggedCoreProgram tag = [CoreBinding (TaggedBinder tag) Id] +type TaggedCoreBinding tag = CoreBinding (TaggedBinder tag) Id +type TaggedCoreExpr tag = CoreExpr (TaggedBinder tag) Id +type TaggedCoreAtom tag = CoreAtom Id + +#ifdef DPH +type TaggedCoreParQuals tag = CoreParQuals (TaggedBinder tag) Id +type TaggedCoreParCommunicate tag + = CoreParCommunicate (TaggedBinder tag) Id +#endif {- Data Parallel Haskell -} + +type TaggedCoreCaseAlternatives tag = CoreCaseAlternatives (TaggedBinder tag) Id +type TaggedCoreCaseDefault tag = CoreCaseDefault (TaggedBinder tag) Id +\end{code} + +\begin{code} +type SimplifiableBinder = (Id, BinderInfo) + +type SimplifiableCoreProgram = [CoreBinding SimplifiableBinder Id] +type SimplifiableCoreBinding = CoreBinding SimplifiableBinder Id +type SimplifiableCoreExpr = CoreExpr SimplifiableBinder Id +type SimplifiableCoreAtom = CoreAtom Id + +#ifdef DPH +type SimplifiableCoreParQuals = CoreParQuals SimplifiableBinder Id +type SimplifiableCoreParCommunicate + = CoreParCommunicate SimplifiableBinder Id +#endif {- Data Parallel Haskell -} + +type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives SimplifiableBinder Id +type SimplifiableCoreCaseDefault = CoreCaseDefault SimplifiableBinder Id +\end{code} diff --git a/ghc/compiler/coreSyn/root.lit b/ghc/compiler/coreSyn/root.lit new file mode 100644 index 0000000..caea1a6 --- /dev/null +++ b/ghc/compiler/coreSyn/root.lit @@ -0,0 +1,41 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{CoreSyntax} +\author{} +\date{2 February 1994} +\maketitle +\tableofcontents +\end{onlystandalone} + +\begin{onlypartofdoc} +\section{Core Syntax} +\downsection +\end{onlypartofdoc} + +\input{CoreSyn.lhs} +\input{AnnCoreSyn.lhs} + +\input{CoreFuns.lhs} + +\input{CoreLint.lhs} + +\section{Instances} +\downsection +\input{PlainCore.lhs} +\input{TaggedCore.lhs} +\input{TmplCore.lhs} +\upsection + +\section{Utilities} +\downsection +\input{FreeVars.lhs} +\upsection + +\begin{onlypartofdoc} +\upsection +\end{onlypartofdoc} +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/count_bytes b/ghc/compiler/count_bytes new file mode 100644 index 0000000..bf62402 --- /dev/null +++ b/ghc/compiler/count_bytes @@ -0,0 +1,43 @@ +#! /usr/local/bin/perl +# +%DirCount = (); +%ModCount = (); + +foreach $f ( @ARGV ) { + die "Not an .lhs file: $f\n" if $f !~ /\.lhs$/; + $f =~ s/\.lhs$/.o/; + + $f_size = `size $f`; + die "Size failed?\n" if $? != 0; + + if ( $f_size =~ /(\S+)\s*(\S+)\s*(\S+)\s*(\d+)\s*(\S+)/ ) { + $totsz = $4; + + if ( $f =~ /(.*)\/(.*)/ ) { + local($dir) = $1; + local($mod) = $2; + $DirCount{$dir} += $totsz; + $ModCount{$mod} += $totsz; + } else { + print STDERR "not counted in a directory: $f\n"; + $ModCount{$f} += $totsz; + } + } else { + die "Can't figure out size: $f_size\n"; + } +} + +# print the info +$tot = 0; +foreach $d (sort (keys %DirCount)) { + printf "%-20s %6d\n", $d, $DirCount{$d}; + $tot += $DirCount{$d}; +} +printf "\n%-20s %6d\n\n\n", 'TOTAL:', $tot; + +$tot = 0; +foreach $m (sort (keys %ModCount)) { + printf "%-20s %6d\n", $m, $ModCount{$m}; + $tot += $ModCount{$m}; +} +printf "\n%-20s %6d\n", 'TOTAL:', $tot; diff --git a/ghc/compiler/count_lines b/ghc/compiler/count_lines new file mode 100644 index 0000000..cbf6503 --- /dev/null +++ b/ghc/compiler/count_lines @@ -0,0 +1,62 @@ +#! /usr/local/bin/perl +# +%DirCount = (); +%ModCount = (); +%DirComments = (); +%ModComments = (); + +foreach $f ( @ARGV ) { + + if ( $f =~ /\.lhs$/ ) { + open(INF, "unlit $f - |") || die "Couldn't unlit $f!\n"; + } else { + open(INF, "< $f") || die "Couldn't open $f!\n"; + } + $cnt = 0; + while () { + s/--.*//; + s/{-.*-}//; + next if /^\s*$/; + $cnt++; + } + close(INF); + + $f_wc = `wc $f`; die "wc failed: $f\n" if $? != 0; + if ( $f_wc =~ /\s*(\d+)\s*(\d+)\s*(\d+)/ ) { + $comments = $1 - $cnt; + } else { + die "Can't grok wc format: $f_wc"; + } + + if ( $f =~ /(.*)\/(.*)/ ) { + local($dir) = $1; + local($mod) = $2; + $DirCount{$dir} += $cnt; + $ModCount{$mod} += $cnt; + $DirComments{$dir} += $comments; + $ModComments{$mod} += $comments; + } else { + print STDERR "not counted in a directory: $f\n"; + $ModCount{$f} += $cnt; + $ModComments{$mod} += $comments; + } +} + +# print the info +$tot = 0; +$totcmts = 0; +foreach $d (sort (keys %DirCount)) { + printf "%-20s %6d %6d\n", $d, $DirCount{$d}, $DirComments{$d}; + $tot += $DirCount{$d}; + $totcmts += $DirComments{$d}; +} +printf "\n%-20s %6d %6d\n\n\n", 'TOTAL:', $tot, $totcmts; + +$tot = 0; +$totcmts = 0; +foreach $m (sort (keys %ModCount)) { + printf "%-20s %6d %6d\n", $m, $ModCount{$m}, $ModComments{$m}; + $tot += $ModCount{$m}; + $totcmts += $ModComments{$m}; +} +printf "\n%-20s %6d %6d\n", 'TOTAL:', $tot, $totcmts; diff --git a/ghc/compiler/deSugar/Desugar.hi b/ghc/compiler/deSugar/Desugar.hi new file mode 100644 index 0000000..457c148 --- /dev/null +++ b/ghc/compiler/deSugar/Desugar.hi @@ -0,0 +1,36 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Desugar where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreBinding, CoreExpr) +import DsMonad(DsMatchContext, DsMatchKind) +import HsBinds(Bind, Binds, Sig) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsLit(Literal) +import HsMatches(Match) +import HsPat(TypecheckedPat) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Inst(Inst) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data DsMatchContext {-# GHC_PRAGMA DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext #-} +data DsMatchKind {-# GHC_PRAGMA FunMatch Id | CaseMatch | LambdaMatch | PatBindMatch #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +deSugar :: SplitUniqSupply -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]) -> ([CoreBinding Id Id], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 4 _U_ 1221 _N_ _S_ "LLLU(LLLL)" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs new file mode 100644 index 0000000..da0b92a --- /dev/null +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -0,0 +1,96 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Desugar]{@deSugar@: the main function} + +\begin{code} +#include "HsVersions.h" + +module Desugar ( + deSugar, + + -- and to make the interface self-sufficient... + SplitUniqSupply, Binds, Expr, Id, TypecheckedPat, + CoreBinding, GlobalSwitch, SwitchResult, + Bag, DsMatchContext, DsMatchKind + ) where + + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import Bag ( unionBags, Bag ) +import CmdLineOpts ( switchIsOn, GlobalSwitch(..), SwitchResult ) +import CoreLift ( liftCoreBindings ) +import CoreLint ( lintCoreBindings ) +import DsBinds ( dsBinds, dsInstBinds ) +import IdEnv +import Pretty ( PprStyle(..) ) +import SplitUniq +import Util +\end{code} + +The only trick here is to get the @DesugarMonad@ stuff off to a good +start. + +\begin{code} +deSugar :: SplitUniqSupply -- name supply + -> (GlobalSwitch->SwitchResult) -- switch looker upper + -> FAST_STRING -- module name + + -> (TypecheckedBinds, -- input: class, instance, and value + TypecheckedBinds, -- bindings; see "tcModule" (which produces + TypecheckedBinds, -- them) + [(Inst, TypecheckedExpr)]) +-- ToDo: handling of const_inst thingies is certainly WRONG *************************** + + -> ([PlainCoreBinding], -- output + Bag DsMatchContext) -- Shadowing complaints + +deSugar us sw_chkr mod_name (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 + + ((core_const_prs, consts_pairs), shadows1) + = initDs us0 nullIdEnv sw_chkr mod_name (dsInstBinds [] const_inst_pairs) + + consts_env = mkIdEnv consts_pairs + + (core_clas_binds, shadows2) + = initDs us1 consts_env sw_chkr mod_name (dsBinds clas_binds) + core_clas_prs = pairsFromCoreBinds core_clas_binds + + (core_inst_binds, shadows3) + = initDs us2 consts_env sw_chkr mod_name (dsBinds inst_binds) + core_inst_prs = pairsFromCoreBinds core_inst_binds + + (core_val_binds, shadows4) + = initDs us3 consts_env sw_chkr mod_name (dsBinds val_binds) + core_val_pairs = pairsFromCoreBinds core_val_binds + + final_binds + = if (null core_clas_prs && null core_inst_prs && 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) + [CoRec (core_clas_prs ++ core_inst_prs ++ core_const_prs ++ core_val_pairs)] + + lift_final_binds = {-if switchIsOn sw_chkr GlasgowExts + then-} liftCoreBindings us4 final_binds + -- else final_binds + + really_final_binds = if switchIsOn sw_chkr DoCoreLinting + then lintCoreBindings PprDebug "Desugarer" False lift_final_binds + else lift_final_binds + + shadows = shadows1 `unionBags` shadows2 `unionBags` shadows3 `unionBags` shadows4 + in + (really_final_binds, shadows) +\end{code} diff --git a/ghc/compiler/deSugar/DsBinds.hi b/ghc/compiler/deSugar/DsBinds.hi new file mode 100644 index 0000000..8fbdc3c --- /dev/null +++ b/ghc/compiler/deSugar/DsBinds.hi @@ -0,0 +1,21 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsBinds where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreBinding, CoreExpr) +import DsMonad(DsMatchContext) +import HsBinds(Binds) +import HsExpr(Expr) +import HsPat(TypecheckedPat) +import Id(Id) +import Inst(Inst) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyVar(TyVar) +import UniqFM(UniqFM) +dsBinds :: Binds Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([CoreBinding Id Id], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} +dsInstBinds :: [TyVar] -> [(Inst, Expr Id TypecheckedPat)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([(Id, CoreExpr Id Id)], [(Id, CoreExpr Id Id)]), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs new file mode 100644 index 0000000..f9e3bf2 --- /dev/null +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -0,0 +1,612 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DsBinds]{Pattern-matching bindings (Binds and MonoBinds)} + +Handles @Binds@; those at the top level require different handling, in +that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower +levels it is preserved with @let@/@letrec@s). + +\begin{code} +#include "HsVersions.h" + +module DsBinds ( + dsBinds, dsInstBinds + ) where + +IMPORT_Trace -- ToDo: rm (debugging only) + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsUniType +import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn ) +import CostCentre ( mkAllDictsCC, preludeDictsCostCentre ) +import Inst ( getInstUniType ) +import DsExpr ( dsExpr ) +import DsGRHSs ( dsGuarded ) +import DsUtils +import Id ( getIdUniType, mkInstId, Inst, Id, DictVar(..) ) +import Match ( matchWrapper ) +import Maybes ( Maybe(..),assocMaybe ) +import Outputable +import Pretty +import Util +import ListSetOps ( minusList, intersectLists ) +\end{code} + + +%************************************************************************ +%* * +\subsection[toplevel-and-regular-DsBinds]{Regular and top-level @dsBinds@} +%* * +%************************************************************************ + +Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be +that some of the binders are of unboxed type. This is sorted out when +the caller wraps the bindings round an expression. + +\begin{code} +dsBinds :: TypecheckedBinds -> DsM [PlainCoreBinding] +\end{code} + +All ``real'' bindings are expressed in terms of the +@AbsBinds@ construct, which is a massively-complicated ``shorthand'', +and its desugaring is the subject of section~9.1 in the static +semantics paper. + +(ToDo) For: +\begin{verbatim} +AbsBinds [a1, ... ,aj] -- type variables + [d1, ... ,dk] -- dict variables + [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...) + [db1=..., ..., dbn=...] -- dict binds + [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i +\end{verbatim} +we want to make, in the general case (non-Fozzie translation): +\begin{verbatim} + -- tupler-upper: + tup a1...aj d1...dk = + let in + let(rec) in (vb1,...,vbm) -- NB: == ... in (l1,...,lm) + + -- a bunch of selectors: + g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1 + ... + gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm +\end{verbatim} +But there are lots of special cases. + + +%============================================== +\subsubsection{Structure cases} +%============================================== + +\begin{code} +dsBinds (BindWith _ _) = panic "dsBinds:BindWith" +dsBinds EmptyBinds = returnDs [] +dsBinds (SingleBind bind) = dsBind [] [] id [] bind + +dsBinds (ThenBinds binds_1 binds_2) + = andDs (++) (dsBinds binds_1) (dsBinds binds_2) +\end{code} + + +%============================================== +\subsubsection{AbsBind case: no overloading} +%============================================== + +Special case: no overloading. +\begin{verbatim} + x1 = e1 + x2 = e2 +\end{verbatim} +We abstract each wrt the type variables, giving +\begin{verbatim} + x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2] + x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2] +\end{verbatim} +There are some complications. + +(i) The @val_binds@ might mention variable not in @local_global_prs@. +In this case we need to make up new polymorphic versions of them. + +(ii) Exactly the same applies to any @inst_binds@ which may be +present. However, here we expect that mostly they will be simple constant +definitions, which don't mention the type variables at all, so making them +polymorphic is really overkill. @dsInstBinds@ deals with this case. + +\begin{code} +dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) + = mapDs mk_poly_private_binder private_binders + `thenDs` \ poly_private_binders -> + let + full_local_global_prs = (private_binders `zip` poly_private_binders) + ++ local_global_prs + in + listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app -> + returnDs (local, app) + | (local,global) <- full_local_global_prs + ] `thenDs` \ env -> + +-- pprTrace "AbsBinds1:" (ppr PprDebug env) $ + + extendEnvDs env ( + + dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) -> + extendEnvDs inst_env ( + + dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds + )) + where + -- "private_binders" is the list of binders in val_binds + -- which don't appear in the local_global_prs list + -- These only really show up in stuff produced from compiling + -- class and instance declarations. + -- We need to add suitable polymorphic versions of them to the + -- local_global_prs. + private_binders = binders `minusList` [local | (local,_) <- local_global_prs] + binders = collectTypedBinders val_binds + mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (getIdUniType id))) + + tyvar_tys = map mkTyVarTy tyvars +\end{code} + + +%============================================== +\subsubsection{AbsBind case: overloading} +%============================================== + +If there is overloading we go for the general case. + +We want the global identifiers to be abstracted wrt all types and +dictionaries; and the local identifiers wrt the non-overloaded types. +That is, we try to avoid global scoping of type abstraction. Example + + f :: Eq a => a -> [(a,b)] -> b + f = ...f... + +Here, f is fully polymorphic in b. So we generate + + f ab d = let ...dict defns... + in + letrec f' b = ...(f' b)... + in f' b + +*Notice* that we don't clone type variables, and *do* make use of +shadowing. It is possible to do cloning, but it makes the code quite +a bit more complicated, and the simplifier will clone it all anyway. + +Why bother with this gloss? Because it makes it more likely that +the defn of f' can get floated out, notably if f gets specialised +to a particular type for a. + +\begin{code} +dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) + = -- If there is any non-overloaded polymorphism, make new locals with + -- appropriate polymorphism + (if null non_overloaded_tyvars + then + -- No non-overloaded polymorphism, so stay with current envt + returnDs (id, [], []) + else + -- Some local, non-overloaded polymorphism + cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars -> + + mapDs mk_binder binders `thenDs` \ new_binders -> + let + old_new_pairs = binders `zip` new_binders + in + + listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app -> + returnDs (old, app) + | (old,new) <- old_new_pairs + ] `thenDs` \ extra_env -> + let + local_binds = [CoNonRec old app | (old,app) <- extra_env, old `is_elem` locals] + is_elem = isIn "dsBinds" + in + returnDs (lookupId old_new_pairs, extra_env, local_binds) + ) + `thenDs` \ (binder_subst_fn, local_env, local_binds) -> + +-- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $ + + extendEnvDs local_env ( + + dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) -> + + extendEnvDs inst_env ( + + dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds + )) `thenDs` \ core_binds -> + + let + tuple_rhs = mkCoLetsAny core_binds ( + mkCoLetsAny local_binds ( + mkTupleExpr locals )) + in + mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs -> + + returnDs [ CoNonRec binder rhs | (binder,rhs) <- core_bind_prs ] + where + locals = [local | (local,global) <- local_global_prs] + non_ov_tyvar_tys = map mkTyVarTy non_overloaded_tyvars + + overloaded_tyvars = extractTyVarsFromTys (map getIdUniType dicts) + non_overloaded_tyvars = all_tyvars `minusList` overloaded_tyvars + + binders = collectTypedBinders val_binds + mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (getIdUniType id))) +\end{code} + +@mkSatTyApp id tys@ constructs an expression whose value is (id tys). +However, sometimes id takes more type args than are in tys, and the +specialiser hates that, so we have to eta expand, to +(/\ a b -> id tys a b) + +\begin{code} +mkSatTyApp :: Id -- Id to apply to the types + -> [UniType] -- Types to apply it to + -> DsM PlainCoreExpr + +mkSatTyApp id [] = returnDs (CoVar id) + +mkSatTyApp id tys + | null tyvar_templates + = returnDs (mkCoTyApps (CoVar id) tys) -- Common case + + | otherwise + = newTyVarsDs (drop (length tys) tyvar_templates) `thenDs` \ tyvars -> +-- pprTrace "mkSatTyApp:" (ppCat [ppr PprDebug id, ppr PprDebug tyvar_templates, ppr PprDebug tyvars, ppr PprDebug theta, ppr PprDebug tau_ty, ppr PprDebug tys]) $ + returnDs (mkCoTyLam tyvars (mkCoTyApps (mkCoTyApps (CoVar id) tys) + (map mkTyVarTy tyvars))) + where + (tyvar_templates, theta, tau_ty) = splitType (getIdUniType id) +\end{code} + +There are several places where we encounter ``inst binds,'' +@(Inst, TypecheckedExpr)@ pairs. Many of these are ``trivial'' binds +(a var to a var or literal), which we want to substitute away; so we +return both some desugared bindings {\em and} a substitution +environment for the subbed-away ones. + +These dictionary bindings are non-recursive, and ordered, so that +later ones may mention earlier ones, but not vice versa. + +\begin{code} +dsInstBinds :: [TyVar] -- Abstract wrt these + -> [(Inst, TypecheckedExpr)] -- From AbsBinds + -> DsM ([(Id,PlainCoreExpr)], -- Non-trivial bindings + [(Id,PlainCoreExpr)]) -- Trivial ones to be substituted away + +do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh) +prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto + +dsInstBinds tyvars [] + = returnDs do_nothing + +dsInstBinds tyvars ((inst, expr@(Var _)) : bs) + = dsExpr expr `thenDs` ( \ rhs -> + let -- Need to apply dsExpr to the variable in case it + -- has a substitution in the current environment + subst_item = (mkInstId inst, rhs) + in + extendEnvDs [subst_item] ( + dsInstBinds tyvars bs + ) `thenDs` (\ (binds, subst_env) -> + returnDs (binds, subst_item : subst_env) + )) + +dsInstBinds tyvars ((inst, expr@(Lit _)) : bs) + = dsExpr expr `thenDs` ( \ core_lit -> + let + subst_item = (mkInstId inst, core_lit) + in + extendEnvDs [subst_item] ( + dsInstBinds tyvars bs + ) `thenDs` (\ (binds, subst_env) -> + returnDs (binds, subst_item : subst_env) + )) + +dsInstBinds tyvars ((inst, expr) : bs) + | null abs_tyvars + = dsExpr expr `thenDs` \ core_expr -> + ds_dict_cc core_expr `thenDs` \ dict_expr -> + dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) -> + returnDs ((mkInstId inst, dict_expr) : core_rest, subst_env) + + | otherwise + = -- Obscure case. + -- The inst mentions the type vars wrt which we are abstracting, + -- so we have to invent a new polymorphic version, and substitute + -- appropriately. + -- This can occur in, for example: + -- leftPoll :: [FeedBack a] -> FeedBack a + -- leftPoll xs = take poll xs + -- Here there is an instance of take at the type of elts of xs, + -- as well as the type of poll. + + dsExpr expr `thenDs` \ core_expr -> + ds_dict_cc core_expr `thenDs` \ dict_expr -> + newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id -> + let + subst_item = (mkInstId inst, mkCoTyApps (CoVar poly_inst_id) abs_tys) + in + extendEnvDs [subst_item] ( + dsInstBinds tyvars bs + ) `thenDs` \ (core_rest, subst_env) -> + returnDs ((poly_inst_id, mkCoTyLam abs_tyvars dict_expr) : core_rest, + subst_item : subst_env) + where + inst_ty = getInstUniType inst + abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars + abs_tys = map mkTyVarTy abs_tyvars + (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty + + ------------------------ + -- Wrap a desugared expression in `_scc_ "DICT" ' if + -- appropriate. Uses "inst"'s type. + + ds_dict_cc expr + = -- if profiling, wrap the dict in "_scc_ DICT ": + getSwitchCheckerDs `thenDs` \ sw_chkr -> + let + doing_profiling = sw_chkr SccProfilingOn + compiling_prelude = sw_chkr CompilingPrelude + in + if not doing_profiling + || not (isDictTy inst_ty) then -- that's easy: do nothing + returnDs expr + else if compiling_prelude then + returnDs (CoSCC prel_dicts_cc expr) + else + getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) -> + -- ToDo: do -dicts-all flag (mark dict things + -- with individual CCs) + let + dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-} + in + returnDs (CoSCC dict_cc expr) +\end{code} + +%************************************************************************ +%* * +\subsection[dsBind]{Desugaring a @Bind@} +%* * +%************************************************************************ + +Like @dsBinds@, @dsBind@ returns a @[PlainCoreBinding]@, but it may be that +some of the binders are of unboxed type. + +For an explanation of the first three args, see @dsMonoBinds@. + +\begin{code} +dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these + -> (Id -> Id) -- Binder substitution + -> [(Id,PlainCoreExpr)] -- Inst bindings already dealt with + -> TypecheckedBind + -> DsM [PlainCoreBinding] + +dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind + = returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs] + +dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) + = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs -> + returnDs [CoNonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] ) + +dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) + = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs -> + returnDs [CoRec (inst_bind_pairs ++ val_bind_pairs)] ) +\end{code} + + +%************************************************************************ +%* * +\subsection[dsMonoBinds]{Desugaring a @MonoBinds@} +%* * +%************************************************************************ + +@dsMonoBinds@ transforms @TypecheckedMonoBinds@ into @PlainCoreBinds@. +In addition to desugaring pattern matching, @dsMonoBinds@ takes +a list of type variables and dicts, and adds abstractions for these +to the front of every binding. That requires that the +binders be altered too (their type has changed, +so @dsMonoBinds@ also takes a function which maps binders into binders. +This mapping gives the binder the correct new type. + +Remember, there's also a substitution in the monad which maps occurrences +of these binders into applications of the new binder to suitable type variables +and dictionaries. + +\begin{code} +dsMonoBinds :: Bool -- True <=> recursive binding group + -> [TyVar] -> [DictVar] -- Abstract wrt these + -> (Id -> Id) -- Binder substitution + -> TypecheckedMonoBinds + -> DsM [(Id,PlainCoreExpr)] +\end{code} + + + +%============================================== +\subsubsection{Structure cases} +%============================================== + +\begin{code} +dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] + +dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1) + (dsMonoBinds is_rec tyvars dicts binder_subst binds_2) +\end{code} + + +%============================================== +\subsubsection{Simple base cases: function and variable bindings} +%============================================== + +For the simplest bindings, we just heave them in the substitution env: + +\begin{code} +{- THESE TWO ARE PLAIN WRONG. + The extendEnvDs only scopes over the nested call! + Let the simplifier do this. + +dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (Var new_var)) + | not (is_rec || isExported was_var) + = extendEnvDs [(was_var, CoVar new_var)] ( + returnDs [] ) + +dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _)) + | not (isExported was_var) + = dsExpr expr `thenDs` ( \ core_lit -> + extendEnvDs [(was_var, core_lit)] ( + returnDs [] )) +-} + +dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) + = dsExpr expr `thenDs` ( \ core_expr -> + returnDs [(binder_subst var, mkCoTyLam tyvars (mkCoLam dicts core_expr))] ) +\end{code} + +\begin{code} +dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn) + = putSrcLocDs locn ( + let + new_fun = binder_subst fun + in + matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) -> + returnDs [(new_fun, + mkCoTyLam tyvars (mkCoLam dicts (mkCoLam args body)))] + ) + where + error_msg fun = "%F" -- "incomplete pattern(s) to match in function \"" + ++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\"" + +dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) + = putSrcLocDs locn ( + dsGuarded grhss_and_binds locn `thenDs` \ body_expr -> + returnDs [(binder_subst v, mkCoTyLam tyvars (mkCoLam dicts body_expr))] + ) +\end{code} + +%============================================== +\subsubsection{The general base case} +%============================================== + +Now the general case of a pattern binding. The monomorphism restriction +should ensure that if there is a non-simple pattern binding in the +group, then there is no overloading involved, so the dictionaries should +be empty. (Simple pattern bindings were handled above.) +First, the paranoia check. + +\begin{code} +dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) + = panic "Non-empty dict list in for pattern binding" +\end{code} + +We handle three cases for the binding + pat = rhs + +\begin{description} +\item[pat has no binders.] +Then all this is dead code and we return an empty binding. + +\item[pat has exactly one binder, v.] +Then we can transform to: +\begin{verbatim} + v' = /\ tyvars -> case rhs of { pat -> v } +\end{verbatim} +where \tr{v'} is gotten by looking up \tr{v} in the \tr{binder_subst}. + +\item[pat has more than one binder.] +Then we transform to: +\begin{verbatim} + t = /\ tyvars -> case rhs of { pat -> (v1, ..., vn) } + + vi = /\ tyvars -> case (t tyvars) of { (v1, ..., vn) -> vi } +\end{verbatim} +\end{description} + +\begin{code} +dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) + = putSrcLocDs locn ( + + dsGuarded grhss_and_binds locn `thenDs` \ body_expr -> + +{- KILLED by Sansom. 95/05 + -- make *sure* there are no primitive types in the pattern + if any_con_w_prim_arg pat then + error ( "ERROR: Pattern-bindings cannot involve unboxed/primitive types!\n\t" + ++ (ppShow 80 (ppr PprForUser pat)) ++ "\n" + ++ "(We apologise for not reporting this more `cleanly')\n" ) + + -- Check whether the pattern already is a simple tuple; if so, + -- we can just use the rhs directly + else +-} + mkSelectorBinds tyvars pat + [(binder, binder_subst binder) | binder <- pat_binders] + body_expr + ) + where + pat_binders = collectTypedPatBinders pat + -- NB For a simple tuple pattern, these binders + -- will appear in the right order! + +{- UNUSED, post-Sansom: + any_con_w_prim_arg :: TypecheckedPat -> Bool + + any_con_w_prim_arg (WildPat ty) = isPrimType ty + any_con_w_prim_arg (VarPat v) = isPrimType (getIdUniType v) + any_con_w_prim_arg (LazyPat pat) = any_con_w_prim_arg pat + any_con_w_prim_arg (AsPat _ pat) = any_con_w_prim_arg pat + any_con_w_prim_arg p@(ConPat _ _ args) = any any_con_w_prim_arg args + any_con_w_prim_arg (ConOpPat a1 _ a2 _) = any any_con_w_prim_arg [a1,a2] + any_con_w_prim_arg (ListPat _ args) = any any_con_w_prim_arg args + any_con_w_prim_arg (TuplePat args) = any any_con_w_prim_arg args + any_con_w_prim_arg (LitPat _ ty) = isPrimType ty + any_con_w_prim_arg (NPat _ _ _) = False -- be more paranoid? + any_con_w_prim_arg (NPlusKPat _ _ _ _ _ _) = False -- ditto + +#ifdef DPH + -- Should be more efficient to find type of pid than pats + any_con_w_prim_arg (ProcessorPat pats _ pat) + = error "any_con_w_prim_arg:ProcessorPat (DPH)" +#endif {- Data Parallel Haskell -} +-} + +{- OLD ... removed 6 Feb 95 + + -- we allow it if the constructor has *only one* + -- argument and that is unboxed, as in + -- + -- let (I# i#) = ... in ... + -- + prim_args args + = let + no_of_prim_args + = length [ a | a <- args, isPrimType (typeOfPat a) ] + in + if no_of_prim_args == 0 then + False + else if no_of_prim_args == 1 && length args == 1 then + False -- special case we let through + else + True + +-} +\end{code} + +Wild-card patterns could be made acceptable here, but it involves some +extra work to benefit only rather unusual constructs like +\begin{verbatim} + let (_,a,b) = ... in ... +\end{verbatim} +Better to extend the whole thing for any irrefutable constructor, at least. + + diff --git a/ghc/compiler/deSugar/DsCCall.hi b/ghc/compiler/deSugar/DsCCall.hi new file mode 100644 index 0000000..33faf57 --- /dev/null +++ b/ghc/compiler/deSugar/DsCCall.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsCCall where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniType(UniType) +import UniqFM(UniqFM) +dsCCall :: _PackedString -> [CoreExpr Id Id] -> Bool -> Bool -> UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 11 _U_ 22222122222 _N_ _S_ "LLLLSU(ALS)LLLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs new file mode 100644 index 0000000..87a834e --- /dev/null +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -0,0 +1,295 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s} + +\begin{code} +#include "HsVersions.h" + +module DsCCall ( dsCCall ) where + +IMPORT_Trace + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring +import DsMonad -- the monadery used in the desugarer + +import AbsPrel +import TysPrim -- ****** ToDo: PROPERLY +import TysWiredIn +import AbsUniType +import DsUtils +import Id ( getInstantiatedDataConSig, mkTupleCon, DataCon(..) ) +import Maybes ( maybeToBool, Maybe(..) ) +import Pretty +#if USE_ATTACK_PRAGMAS +import Unique +#endif +import Util +\end{code} + +Desugaring of @ccall@s consists of adding some state manipulation, +unboxing any boxed primitive arguments and boxing the result if +desired. + +The state stuff just consists of adding in +@\ s -> case s of { S# s# -> ... }@ in an appropriate place. + +The unboxing is straightforward, as all information needed to unbox is +available from the type. For each boxed-primitive argument, we +transform: +\begin{verbatim} + _ccall_ foo [ r, t1, ... tm ] e1 ... em + | + | + V + case e1 of { T1# x1# -> + ... + case em of { Tm# xm# -> xm# + ccall# foo [ r, t1#, ... tm# ] x1# ... xm# + } ... } +\end{verbatim} + +The reboxing of a @_ccall_@ result is a bit tricker: the types don't +contain information about the state-pairing functions so we have to +keep a list of \tr{(type, s-p-function)} pairs. We transform as +follows: +\begin{verbatim} + ccall# foo [ r, t1#, ... tm# ] e1# ... em# + | + | + V + \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of + (StateAnd# result# state#) -> (R# result#, realWorld#) +\end{verbatim} + +\begin{code} +dsCCall :: FAST_STRING -- C routine to invoke + -> [PlainCoreExpr] -- Arguments (desugared) + -> Bool -- True <=> might cause Haskell GC + -> Bool -- True <=> really a "_casm_" + -> UniType -- Type of the result (a boxed-prim type) + -> DsM PlainCoreExpr + +dsCCall label args may_gc is_asm result_ty + = newSysLocalDs realWorldStateTy `thenDs` \ old_s -> + + mapAndUnzipDs unboxArg (CoVar old_s : args) `thenDs` \ (final_args, arg_wrappers) -> + + boxResult result_ty `thenDs` \ (final_result_ty, res_wrapper) -> + + let + the_ccall_op = CCallOp label is_asm may_gc + (map typeOfCoreExpr final_args) + final_result_ty + in + mkCoPrimDs the_ccall_op + [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op. + final_args `thenDs` \ the_prim_app -> + let + the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers + in + returnDs (CoLam [old_s] the_body) + where + apply f x = f x +\end{code} + +\begin{code} +unboxArg :: PlainCoreExpr -- The supplied argument + -> DsM (PlainCoreExpr, -- To pass as the actual argument + PlainCoreExpr -> PlainCoreExpr -- Wrapper to unbox the arg + ) +unboxArg arg + + -- Primitive types + -- ADR Question: can this ever be used? None of the PrimTypes are + -- instances of the _CCallable class. + | isPrimType arg_ty + = returnDs (arg, \body -> body) + + -- Strings + | arg_ty == stringTy + -- ToDo (ADR): - allow synonyms of Strings too? + = newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg -> + mkCoAppDs (CoVar packStringForCId) arg `thenDs` \ pack_appn -> + returnDs (CoVar prim_arg, + \body -> CoCase pack_appn (CoPrimAlts [] + (CoBindDefault prim_arg body)) + ) + + | null data_cons + -- oops: we can't see the data constructors!!! + = can't_see_datacons_error "argument" arg_ty + + -- Byte-arrays, both mutable and otherwise + -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10] + | is_data_type && + length data_con_arg_tys == 2 && + not (isPrimType data_con_arg_ty1) && + isPrimType data_con_arg_ty2 + -- and, of course, it is an instance of _CCallable +-- ( tycon == byteArrayTyCon || +-- tycon == mutableByteArrayTyCon ) + = newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] -> + returnDs (CoVar arr_cts_var, + \ body -> CoCase arg (CoAlgAlts [(the_data_con,vars,body)] + CoNoDefault) + ) + + -- Data types with a single constructor, which has a single, primitive-typed arg + | maybeToBool maybe_boxed_prim_arg_ty + = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg -> + returnDs (CoVar prim_arg, + \ body -> CoCase arg (CoAlgAlts [(box_data_con,[prim_arg],body)] + CoNoDefault) + ) + -- ... continued below .... +\end{code} + +As an experiment, I'm going to unpack any "acceptably small" +enumeration. This code will never get used in the main version +because enumerations would have triggered type errors but I've +disabled type-checking in my version. ADR + +To Will: It might be worth leaving this in (but commented out) until +we decide what's happening with enumerations. ADR + +\begin{code} +#if 0 + -- MAYBE LATER: + -- Data types with a nullary constructors (enumeration) + | isEnumerationType arg_ty && -- enumeration + (length data_cons) <= 5 -- "acceptably short" + = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg -> + + let + alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ] + arg_tag = CoCase arg (CoAlgAlts alts) CoNoDefault + in + + returnDs (CoVar prim_arg, + \ body -> CoCase arg_tag (CoPrimAlts [(prim_arg, body)] CoNoDefault) + ) +#endif +\end{code} + +\begin{code} + -- ... continued from above .... + | otherwise + = pprPanic "unboxArg: " (ppr PprDebug arg_ty) + where + arg_ty = typeOfCoreExpr arg + + maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty + (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty + + maybe_data_type = getUniDataTyCon_maybe arg_ty + is_data_type = maybeToBool maybe_data_type + (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type + (the_data_con : other_data_cons) = data_cons + + (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys + (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])) +\end{code} + + +\begin{code} +tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh) +covar_tuple_con_0 = CoVar (mkTupleCon 0) -- ditto + +boxResult :: UniType -- Type of desired result + -> DsM (UniType, -- Type of the result of the ccall itself + PlainCoreExpr -> PlainCoreExpr) -- Wrapper for the ccall + -- to box the result +boxResult result_ty + | null data_cons + -- oops! can't see the data constructors + = can't_see_datacons_error "result" result_ty + + -- Data types with a single constructor, which has a single, primitive-typed arg + | (maybeToBool maybe_data_type) && -- Data type + (null other_data_cons) && -- Just one constr + not (null data_con_arg_tys) && null other_args_tys && -- Just one arg + isPrimType the_prim_result_ty -- of primitive type + = + newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> + newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id -> + + mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id] `thenDs` \ new_state -> + mkCoConDs the_data_con tycon_arg_tys [CoVar prim_result_id] `thenDs` \ the_result -> + + mkCoConDs tuple_con_2 + [result_ty, realWorldStateTy] + [the_result, new_state] `thenDs` \ the_pair -> + let + the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair) + in + returnDs (state_and_prim_ty, + \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault) + ) + + -- Data types with a single nullary constructor + | (maybeToBool maybe_data_type) && -- Data type + (null other_data_cons) && -- Just one constr + (null data_con_arg_tys) + = + newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> + + mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id] `thenDs` \ new_state -> + + mkCoConDs tuple_con_2 + [result_ty, realWorldStateTy] + [covar_tuple_con_0, new_state] `thenDs` \ the_pair -> + + let + the_alt = (stateDataCon, [prim_state_id], the_pair) + in + returnDs (realWorldStateTy, + \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault) + ) + +#if 0 + -- MAYBE LATER??? + + -- Data types with several nullary constructors (Enumerated types) + | isEnumerationType result_ty && -- Enumeration + (length data_cons) <= 5 -- fairly short + = + newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id -> + newSysLocalDs intPrimTy `thenDs` \ prim_result_id -> + + mkCoConDs stateDataCon [realWorldTy] [CoVar prim_state_id] `thenDs` \ new_state -> + + let + alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ] + the_result = CoCase prim_result_id (CoPrimAlts alts) CoNoDefault + in + + mkCoConDs (mkTupleCon 2) + [result_ty, realWorldStateTy] + [the_result, new_state] `thenDs` \ the_pair -> + let + the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair) + in + returnDs (state_and_prim_ty, + \prim_app -> CoCase prim_app (CoAlgAlts [the_alt] CoNoDefault) + ) +#endif + + | otherwise + = pprPanic "boxResult: " (ppr PprDebug result_ty) + + where + maybe_data_type = getUniDataTyCon_maybe result_ty + Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type + (the_data_con : other_data_cons) = data_cons + + (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys + (the_prim_result_ty : other_args_tys) = data_con_arg_tys + + (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty +\end{code} + diff --git a/ghc/compiler/deSugar/DsExpr.hi b/ghc/compiler/deSugar/DsExpr.hi new file mode 100644 index 0000000..84b0490 --- /dev/null +++ b/ghc/compiler/deSugar/DsExpr.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsExpr where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext) +import HsExpr(Expr) +import HsPat(TypecheckedPat) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniqFM(UniqFM) +dsExpr :: Expr Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs new file mode 100644 index 0000000..9e44415 --- /dev/null +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -0,0 +1,514 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DsExpr]{Matching expressions (Exprs)} + +\begin{code} +#include "HsVersions.h" + +module DsExpr ( dsExpr ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty +import Outputable + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsPrel ( mkTupleTy, unitTy, nilDataCon, consDataCon, + charDataCon, charTy, + mkFunTy, mkBuild -- LATER: , foldrId +#ifdef DPH + ,fromDomainId, toDomainId +#endif {- Data Parallel Haskell -} + ) +import PrimKind ( PrimKind(..) ) -- rather ugly import *** ToDo??? +import AbsUniType ( alpha, alpha_tv, beta, beta_tv, splitType, + splitTyArgs, mkTupleTyCon, mkTyVarTy, mkForallTy, + kindFromType, maybeBoxedPrimType, + TyVarTemplate, TyCon, Arity(..), Class, + TauType(..), UniType + ) +import BasicLit ( mkMachInt, BasicLit(..) ) +import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn ) +import CostCentre ( mkUserCC ) +import DsBinds ( dsBinds ) +import DsCCall ( dsCCall ) +import DsListComp ( dsListComp ) +import DsUtils ( mkCoAppDs, mkCoConDs, mkCoPrimDs, dsExprToAtom ) +import Id +import IdEnv +import IdInfo +import Match ( matchWrapper ) +import Maybes ( Maybe(..) ) +import TaggedCore ( TaggedBinder(..), unTagBinders ) +import TyVarEnv +import Util + +#ifdef DPH +import DsParZF ( dsParallelZF ) +#endif {- Data Parallel Haskell -} +\end{code} + +The funny business to do with variables is that we look them up in the +Id-to-Id and Id-to-Id maps that the monadery is carrying +around; if we get hits, we use the value accordingly. + +%************************************************************************ +%* * +\subsection[DsExpr-vars-and-cons]{Variables and constructors} +%* * +%************************************************************************ + +\begin{code} +dsExpr :: TypecheckedExpr -> DsM PlainCoreExpr + +dsExpr (Var var) = dsApp (Var var) [] +\end{code} + +%************************************************************************ +%* * +\subsection[DsExpr-literals]{Literals} +%* * +%************************************************************************ + +We give int/float literals type Integer and Rational, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting "i" +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(Int, Float, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] +Otherwise, we punt, putting in a "NoRep" Core literal (where the +representation decisions are delayed)... + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. + +\begin{code} +dsExpr (Lit (StringLit s)) + | _NULL_ s + = returnDs ( CoCon nilDataCon [charTy] [] ) + + | _LENGTH_ s == 1 + = let + the_char = CoCon charDataCon [] [CoLitAtom (MachChar (_HEAD_ s))] + the_nil = CoCon nilDataCon [charTy] [] + in + mkCoConDs consDataCon [charTy] [the_char, the_nil] + +-- "_" => build (\ c n -> c 'c' n) -- LATER + +-- "str" ==> build (\ c n -> foldr charTy T c n "str") + +{- LATER: +dsExpr (Lit (StringLit str)) = + newTyVarsDs [alpha_tv] `thenDs` \ [new_tyvar] -> + let + new_ty = mkTyVarTy new_tyvar + in + newSysLocalsDs [ + charTy `mkFunTy` (new_ty `mkFunTy` new_ty), + new_ty, + mkForallTy [alpha_tv] + ((charTy `mkFunTy` (alpha `mkFunTy` alpha)) + `mkFunTy` (alpha `mkFunTy` alpha)) + ] `thenDs` \ [c,n,g] -> + returnDs (mkBuild charTy new_tyvar c n g ( + foldl CoApp + (CoTyApp (CoTyApp (CoVar foldrId) charTy) new_ty) *** ensure non-prim type *** + [CoVarAtom c,CoVarAtom n,CoLitAtom (NoRepStr str)])) +-} + +-- otherwise, leave it as a NoRepStr; +-- the Core-to-STG pass will wrap it in an application of "unpackCStringId". + +dsExpr (Lit (StringLit str)) + = returnDs (CoLit (NoRepStr str)) + +dsExpr (Lit (LitLitLit s ty)) + = returnDs ( CoCon data_con [] [CoLitAtom (MachLitLit s kind)] ) + where + (data_con, kind) + = case (maybeBoxedPrimType ty) of + Nothing + -> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty))) + Just (boxing_data_con, prim_ty) + -> (boxing_data_con, kindFromType prim_ty) + +dsExpr (Lit (IntLit i)) + = returnDs (CoLit (NoRepInteger i)) + +dsExpr (Lit (FracLit r)) + = returnDs (CoLit (NoRepRational r)) + +-- others where we know what to do: + +dsExpr (Lit (IntPrimLit i)) + = if (i >= toInteger minInt && i <= toInteger maxInt) then + returnDs (CoLit (mkMachInt i)) + else + error ("ERROR: Int constant " ++ show i ++ out_of_range_msg) + +dsExpr (Lit (FloatPrimLit f)) + = returnDs (CoLit (MachFloat f)) + -- ToDo: range checking needed! + +dsExpr (Lit (DoublePrimLit d)) + = returnDs (CoLit (MachDouble d)) + -- ToDo: range checking needed! + +dsExpr (Lit (CharLit c)) + = returnDs ( CoCon charDataCon [] [CoLitAtom (MachChar c)] ) + +dsExpr (Lit (CharPrimLit c)) + = returnDs (CoLit (MachChar c)) + +dsExpr (Lit (StringPrimLit s)) + = returnDs (CoLit (MachStr s)) + +-- end of literals magic. -- + +dsExpr expr@(Lam a_Match) + = let + error_msg = "%L" --> "pattern-matching failed in lambda" + in + matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) -> + returnDs ( mkCoLam binders matching_code ) + +dsExpr expr@(App e1 e2) = dsApp expr [] + +dsExpr expr@(OpApp e1 op e2) = dsApp expr [] +\end{code} + +Operator sections. At first it looks as if we can convert +\begin{verbatim} + (expr op) +\end{verbatim} +to +\begin{verbatim} + \x -> op expr x +\end{verbatim} + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider +\begin{verbatim} + map (expr op) xs +\end{verbatim} +for example. So we convert instead to +\begin{verbatim} + let y = expr in \x -> op y x +\end{verbatim} +If \tr{expr} is actually just a variable, say, then the simplifier +will sort it out. + +\begin{code} +dsExpr (SectionL expr op) + = dsExpr op `thenDs` \ core_op -> + dsExpr expr `thenDs` \ core_expr -> + dsExprToAtom core_expr ( \ y_atom -> + + -- for the type of x, we need the type of op's 2nd argument + let + x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) -> + case (splitTyArgs tau_ty) of { + ((_:arg2_ty:_), _) -> arg2_ty; + _ -> panic "dsExpr:SectionL:arg 2 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty])) + }} + in + newSysLocalDs x_ty `thenDs` \ x_id -> + returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op y_atom) (CoVarAtom x_id)) )) + +-- dsExpr (SectionR op expr) -- \ x -> op x expr +dsExpr (SectionR op expr) + = dsExpr op `thenDs` \ core_op -> + dsExpr expr `thenDs` \ core_expr -> + dsExprToAtom core_expr (\ y_atom -> + + -- for the type of x, we need the type of op's 1st argument + let + x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) -> + case (splitTyArgs tau_ty) of { + ((arg1_ty:_), _) -> arg1_ty; + _ -> panic "dsExpr:SectionR:arg 1 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty])) + }} + in + newSysLocalDs x_ty `thenDs` \ x_id -> + returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op (CoVarAtom x_id)) y_atom) )) + +dsExpr (CCall label args may_gc is_asm result_ty) + = mapDs dsExpr args `thenDs` \ core_args -> + dsCCall label core_args may_gc is_asm result_ty + -- dsCCall does all the unboxification, etc. + +dsExpr (SCC cc expr) + = dsExpr expr `thenDs` \ core_expr -> + getModuleAndGroupDs `thenDs` \ (mod_name, group_name) -> + returnDs ( CoSCC (mkUserCC cc mod_name group_name) core_expr) + +dsExpr expr@(Case discrim matches) + = dsExpr discrim `thenDs` \ core_discrim -> + let + error_msg = "%C" --> "pattern-matching failed in case" + in + matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) -> + returnDs ( mkCoLetAny (CoNonRec discrim_var core_discrim) matching_code ) + +dsExpr (ListComp expr quals) + = dsExpr expr `thenDs` \ core_expr -> + dsListComp core_expr quals + +dsExpr (Let binds expr) + = dsBinds binds `thenDs` \ core_binds -> + dsExpr expr `thenDs` \ core_expr -> + returnDs ( mkCoLetsAny core_binds core_expr ) + +dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList -- not translated" + +dsExpr (ExplicitListOut ty xs) + = case xs of + [] -> returnDs ( CoCon nilDataCon [ty] [] ) + (y:ys) -> + dsExpr y `thenDs` \ core_hd -> + dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl -> + mkCoConDs consDataCon [ty] [core_hd, core_tl] + +dsExpr (ExplicitTuple expr_list) + = mapDs dsExpr expr_list `thenDs` \ core_exprs -> + mkCoConDs (mkTupleCon (length expr_list)) + (map typeOfCoreExpr core_exprs) + core_exprs + +dsExpr (ExprWithTySig expr sig) = panic "dsExpr: ExprWithTySig" + +dsExpr (If guard_expr then_expr else_expr) + = dsExpr guard_expr `thenDs` \ core_guard -> + dsExpr then_expr `thenDs` \ core_then -> + dsExpr else_expr `thenDs` \ core_else -> + returnDs (mkCoreIfThenElse core_guard core_then core_else) + +dsExpr (ArithSeqIn info) = panic "dsExpr.ArithSeqIn" + +dsExpr (ArithSeqOut expr (From from)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + mkCoAppDs expr2 from2 + +dsExpr (ArithSeqOut expr (FromTo from two)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr two `thenDs` \ two2 -> + mkCoAppDs expr2 from2 `thenDs` \ app1 -> + mkCoAppDs app1 two2 + +dsExpr (ArithSeqOut expr (FromThen from thn)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr thn `thenDs` \ thn2 -> + mkCoAppDs expr2 from2 `thenDs` \ app1 -> + mkCoAppDs app1 thn2 + +dsExpr (ArithSeqOut expr (FromThenTo from thn two)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr thn `thenDs` \ thn2 -> + dsExpr two `thenDs` \ two2 -> + mkCoAppDs expr2 from2 `thenDs` \ app1 -> + mkCoAppDs app1 thn2 `thenDs` \ app2 -> + mkCoAppDs app2 two2 + +#ifdef DPH +dsExpr (ParallelZF expr quals) + = dsParallelZF expr quals + +dsExpr (ExplicitPodIn _) + = panic "dsExpr:ExplicitPodIn -- not translated" + +dsExpr (ExplicitPodOut _ _) + = panic "dsExpr:ExplicitPodOut should remove this." + +dsExpr (ExplicitProcessor exprs expr) + = mapDs dsExpr exprs `thenDs` \ core_exprs -> + dsExpr expr `thenDs` \ core_expr -> + mkCoConDs (mkProcessorCon (length exprs)) + ((map typeOfCoreExpr core_exprs)++[typeOfCoreExpr core_expr]) + (core_exprs++[core_expr]) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +dsExpr (TyLam tyvars expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs( foldr CoTyLam core_expr tyvars) + +dsExpr expr@(TyApp e tys) = dsApp expr [] +\end{code} + +@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. +\begin{code} +dsExpr (DictLam dictvars expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs( mkCoLam dictvars core_expr ) + +------------------ + +dsExpr expr@(DictApp e dicts) -- becomes a curried application + = dsApp expr [] +\end{code} + +@SingleDicts@ become @Locals@; @Dicts@ turn into tuples, unless +of length 0 or 1. +@ClassDictLam dictvars methods expr@ is ``the opposite'': +\begin{verbatim} +\ x -> case x of ( dictvars-and-methods-tuple ) -> expr +\end{verbatim} +\begin{code} +dsExpr (SingleDict dict) -- just a local + = lookupEnvWithDefaultDs dict (CoVar dict) + +dsExpr (Dictionary dicts methods) + = -- hey, these things may have been substituted away... + zipWithDs lookupEnvWithDefaultDs + dicts_and_methods dicts_and_methods_exprs + `thenDs` \ core_d_and_ms -> + + (case num_of_d_and_ms of + 0 -> returnDs cocon_unit -- unit + + 1 -> returnDs (head core_d_and_ms) -- just a single Id + + _ -> -- tuple 'em up + mkCoConDs (mkTupleCon num_of_d_and_ms) + (map typeOfCoreExpr core_d_and_ms) + core_d_and_ms + ) + where + dicts_and_methods = dicts ++ methods + dicts_and_methods_exprs = map CoVar dicts_and_methods + num_of_d_and_ms = length dicts_and_methods + +dsExpr (ClassDictLam dicts methods expr) + = dsExpr expr `thenDs` \ core_expr -> + case num_of_d_and_ms of + 0 -> newSysLocalDs unitTy `thenDs` \ new_x -> + returnDs (CoLam [new_x] core_expr) + + 1 -> -- no untupling + returnDs (CoLam dicts_and_methods core_expr) + + _ -> -- untuple it + newSysLocalDs tuple_ty `thenDs` \ new_x -> + returnDs ( + CoLam [new_x] + (CoCase (CoVar new_x) + (CoAlgAlts + [(tuple_con, dicts_and_methods, core_expr)] + CoNoDefault))) + where + dicts_and_methods = dicts ++ methods + num_of_d_and_ms = length dicts_and_methods + tuple_ty = mkTupleTy num_of_d_and_ms (map getIdUniType dicts_and_methods) + tuple_tycon = mkTupleTyCon num_of_d_and_ms + tuple_con = mkTupleCon num_of_d_and_ms + +cocon_unit = CoCon (mkTupleCon 0) [] [] -- out here to avoid CAF (sigh) +out_of_range_msg -- ditto + = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n" +\end{code} + +%-------------------------------------------------------------------- + +@(dsApp e [t_1,..,t_n, e_1,..,e_n])@ returns something with the same +value as: +\begin{verbatim} +e t_1 ... t_n e_1 .. e_n +\end{verbatim} + +We're doing all this so we can saturate constructors (as painlessly as +possible). + +\begin{code} +data DsCoreArg + = DsTypeArg UniType + | DsValArg PlainCoreExpr + +dsApp :: TypecheckedExpr -- expr to desugar + -> [DsCoreArg] -- accumulated ty/val args: NB: + -> DsM PlainCoreExpr -- final result + +dsApp (App e1 e2) args + = dsExpr e2 `thenDs` \ core_e2 -> + dsApp e1 (DsValArg core_e2 : args) + +dsApp (OpApp e1 op e2) args + = dsExpr e1 `thenDs` \ core_e1 -> + dsExpr e2 `thenDs` \ core_e2 -> + dsApp op (DsValArg core_e1 : DsValArg core_e2 : args) + +dsApp (DictApp expr dicts) args + = -- now, those dicts may have been substituted away... + zipWithDs lookupEnvWithDefaultDs dicts (map CoVar dicts) + `thenDs` \ core_dicts -> + dsApp expr (map DsValArg core_dicts ++ args) + +dsApp (TyApp expr tys) args + = dsApp expr (map DsTypeArg tys ++ args) + +-- we might should look out for SectionLs, etc., here, but we don't + +dsApp (Var v) args + = lookupEnvDs v `thenDs` \ maybe_expr -> + case maybe_expr of + Just expr -> apply_to_args expr args + + Nothing -> -- we're only saturating constructors and PrimOps + case getIdUnfolding v of + GeneralForm _ _ the_unfolding EssentialUnfolding + -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args + + _ -> apply_to_args (CoVar v) args + + +dsApp anything_else args + = dsExpr anything_else `thenDs` \ core_expr -> + apply_to_args core_expr args + +-- a DsM version of applyToArgs: +apply_to_args :: PlainCoreExpr -> [DsCoreArg] -> DsM PlainCoreExpr + +apply_to_args fun [] = returnDs fun + +apply_to_args fun (DsValArg expr : args) + = mkCoAppDs fun expr `thenDs` \ fun2 -> + apply_to_args fun2 args + +apply_to_args fun (DsTypeArg ty : args) + = apply_to_args (mkCoTyApp fun ty) args +\end{code} + +\begin{code} +do_unfold ty_env val_env (CoTyLam tyvar body) (DsTypeArg ty : args) + = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args + +do_unfold ty_env val_env (CoLam [] body) args + = do_unfold ty_env val_env body args + +do_unfold ty_env val_env (CoLam (binder:binders) body) (DsValArg expr : args) + = dsExprToAtom expr (\ arg_atom -> + do_unfold ty_env (addOneToIdEnv val_env binder (atomToExpr arg_atom)) (CoLam binders body) args + ) + +do_unfold ty_env val_env body args + = -- Clone the remaining part of the template + uniqSMtoDsM (substCoreExprUS val_env ty_env body) `thenDs` \ body' -> + + -- Apply result to remaining arguments + apply_to_args body' args +\end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.hi b/ghc/compiler/deSugar/DsGRHSs.hi new file mode 100644 index 0000000..41bd2c4 --- /dev/null +++ b/ghc/compiler/deSugar/DsGRHSs.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsGRHSs where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext, DsMatchKind) +import DsUtils(MatchResult) +import HsMatches(GRHS, GRHSsAndBinds) +import HsPat(TypecheckedPat) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniType(UniType) +import UniqFM(UniqFM) +dsGRHSs :: UniType -> DsMatchKind -> [TypecheckedPat] -> [GRHS Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 10 _U_ 2221222222 _N_ _S_ "LLLS" _N_ _N_ #-} +dsGuarded :: GRHSsAndBinds Id TypecheckedPat -> SrcLoc -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "SL" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs new file mode 100644 index 0000000..fde76e6 --- /dev/null +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -0,0 +1,104 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)} + +\begin{code} +#include "HsVersions.h" + +module DsGRHSs ( dsGuarded, dsGRHSs ) where + + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsPrel ( stringTy + IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) + ) +import DsBinds ( dsBinds ) +import DsExpr ( dsExpr ) +import DsUtils +import Pretty +import Util +\end{code} + +@dsGuarded@ is used for both @case@ expressions and pattern bindings. +It desugars: +\begin{verbatim} + | g1 -> e1 + ... + | gn -> en + where binds +\end{verbatim} +producing an expression with a runtime error in the corner if +necessary. The type argument gives the type of the ei. + +\begin{code} +dsGuarded :: TypecheckedGRHSsAndBinds + -> SrcLoc + -> DsM PlainCoreExpr + +dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc + = dsBinds binds `thenDs` \ core_binds -> + dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> + case can_it_fail of + CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) + CanFail -> newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String + returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var))) + where + unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc)) + + error_expr :: Id -> PlainCoreExpr + error_expr str_var = mkErrorCoApp err_ty str_var + (unencoded_part_of_msg + ++ "%N") --> ": non-exhaustive guards" +\end{code} + +Desugar a list of (grhs, expr) pairs [grhs = guarded +right-hand-side], as in: +\begin{verbatim} +p | g1 = e1 + | g2 = e2 + ... + | gm = em +\end{verbatim} +We supply a @PlainCoreExpr@ for the case in which all of +the guards fail. + +\begin{code} +dsGRHSs :: UniType -- Type of RHSs + -> DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from + -> [TypecheckedGRHS] -- Guarded RHSs + -> DsM MatchResult + +dsGRHSs ty kind pats [grhs] = dsGRHS ty kind pats grhs + +dsGRHSs ty kind pats (grhs:grhss) + = dsGRHS ty kind pats grhs `thenDs` \ match_result1 -> + dsGRHSs ty kind pats grhss `thenDs` \ match_result2 -> + combineGRHSMatchResults match_result1 match_result2 + +dsGRHS ty kind pats (OtherwiseGRHS expr locn) + = putSrcLocDs locn ( + dsExpr expr `thenDs` \ core_expr -> + let + expr_fn = \ ignore -> core_expr + in + returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn)) + ) + +dsGRHS ty kind pats (GRHS guard expr locn) + = putSrcLocDs locn ( + dsExpr guard `thenDs` \ core_guard -> + dsExpr expr `thenDs` \ core_expr -> + let + expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail + in + returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn)) + ) +\end{code} + + diff --git a/ghc/compiler/deSugar/DsListComp.hi b/ghc/compiler/deSugar/DsListComp.hi new file mode 100644 index 0000000..a6455a0 --- /dev/null +++ b/ghc/compiler/deSugar/DsListComp.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsListComp where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext) +import HsExpr(Qual) +import HsPat(TypecheckedPat) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniqFM(UniqFM) +dsListComp :: CoreExpr Id Id -> [Qual Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs new file mode 100644 index 0000000..51748b6 --- /dev/null +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -0,0 +1,234 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DsListComp]{Desugaring list comprehensions} + +\begin{code} +module DsListComp ( dsListComp ) where + + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsPrel ( mkFunTy, nilDataCon, consDataCon, listTyCon, + mkBuild, mkFoldr + ) +import AbsUniType ( alpha_tv, alpha, mkTyVarTy, mkForallTy ) +import CmdLineOpts ( GlobalSwitch(..) ) +import DsExpr ( dsExpr ) +import DsUtils +import Id ( getIdInfo, replaceIdInfo ) +import IdInfo +import Match ( matchSimply ) +import Util +\end{code} + +List comprehensions may be desugared in one of two ways: ``ordinary'' +(as you would expect if you read SLPJ's book) and ``with foldr/build +turned on'' (if you read Gill {\em et al.}'s paper on the subject). + +There will be at least one ``qualifier'' in the input. + +\begin{code} +dsListComp :: PlainCoreExpr -> [TypecheckedQual] -> DsM PlainCoreExpr + +dsListComp expr quals + = let expr_ty = typeOfCoreExpr expr + in + ifSwitchSetDs FoldrBuildOn ( + new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) -> + let + c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty) + g_ty = mkForallTy [alpha_tv] ( + (expr_ty `mkFunTy` (alpha `mkFunTy` alpha)) + `mkFunTy` (alpha `mkFunTy` alpha)) + in + newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> + + dfListComp expr expr_ty + c_ty c + n_ty n + quals `thenDs` \ result -> + + returnDs (mkBuild expr_ty n_tyvar c n g result) + + ) {-else be boring-} ( + deListComp expr quals (nIL_EXPR expr_ty) + ) + where + nIL_EXPR ty = CoCon nilDataCon [ty] [] + + new_alpha_tyvar :: DsM (TyVar, UniType) + new_alpha_tyvar + = newTyVarsDs [alpha_tv] `thenDs` \ [new_ty] -> + returnDs (new_ty,mkTyVarTy new_ty) +\end{code} + +%************************************************************************ +%* * +\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions} +%* * +%************************************************************************ + +Just as in Phil's chapter~7 in SLPJ, using the rules for +optimally-compiled list comprehensions. This is what Kevin followed +as well, and I quite happily do the same. The TQ translation scheme +transforms a list of qualifiers (either boolean expressions or +generators) into a single expression which implements the list +comprehension. Because we are generating 2nd-order polymorphic +lambda-calculus, calls to NIL and CONS must be applied to a type +argument, as well as their usual value arguments. +\begin{verbatim} +TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >> + +(Rule C) +TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <> TE <> + +(Rule B) +TQ << [ e | b , qs ] ++ L >> = + if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >> + +(Rule A') +TQ << [ e | p <- L1, qs ] ++ L2 >> = + letrec + h = \ u1 -> + case u1 of + [] -> TE << L2 >> + (u2 : u3) -> + (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2) + [] (h u3) + in + h ( TE << L1 >> ) + +"h", "u1", "u2", and "u3" are new variables. +\end{verbatim} + +@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@ +is the TE translation scheme. Note that we carry around the @L@ list +already desugared. @dsListComp@ does the top TE rule mentioned above. + +\begin{code} +deListComp :: PlainCoreExpr -> [TypecheckedQual] -> PlainCoreExpr -> DsM PlainCoreExpr + +deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above + = mkCoConDs consDataCon [typeOfCoreExpr expr] [expr, list] + +deListComp expr ((FilterQual filt): quals) list -- rule B above + = dsExpr filt `thenDs` \ core_filt -> + deListComp expr quals list `thenDs` \ core_rest -> + returnDs ( mkCoreIfThenElse core_filt core_rest list ) + +deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above + = dsExpr list1 `thenDs` \ core_list1 -> + let + u3_ty@u1_ty = typeOfCoreExpr core_list1 -- two names, same thing + + -- u1_ty is a [alpha] type, and u2_ty = alpha + u2_ty = typeOfPat pat + + res_ty = typeOfCoreExpr core_list2 + h_ty = mkFunTy u1_ty res_ty + in + newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] + `thenDs` \ [h', u1, u2, u3] -> + {- + Make the function h unfoldable by the deforester. + Since it only occurs once in the body, we can't get + an increase in code size by unfolding it. + -} +-- getSwitchCheckerDs `thenDs` \ sw_chkr -> + let + h = if False -- LATER: sw_chkr DoDeforest??? + then replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest) + else h' + in + -- the "fail" value ... + mkCoAppDs (CoVar h) (CoVar u3) `thenDs` \ core_fail -> + + deListComp expr quals core_fail `thenDs` \ rest_expr -> + + matchSimply (CoVar u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> + + mkCoAppDs (CoVar h) core_list1 `thenDs` \ letrec_body -> + + returnDs ( + mkCoLetrecAny [ + ( h, + (CoLam [ u1 ] + (CoCase (CoVar u1) + (CoAlgAlts + [(nilDataCon, [], core_list2), + (consDataCon, [u2, u3], core_match)] + CoNoDefault))) + )] letrec_body + ) +\end{code} + +%************************************************************************ +%* * +\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} +%* * +%************************************************************************ + +@dfListComp@ are the rules used with foldr/build turned on: +\begin{verbatim} +TE < [ e | ] >> c n = c e n +TE << [ e | b , q ] >> c n = if b then TE << [ e | q ] >> c n else n +TE << [ e | p <- l , q ] c n = foldr + (\ TE << p >> b -> TE << [ e | q ] >> c b + _ b -> b) n l +\end{verbatim} +\begin{code} +dfListComp :: PlainCoreExpr -- the inside of the comp + -> UniType -- the type of the inside + -> UniType -> Id -- 'c'; its type and id + -> UniType -> Id -- 'n'; its type and id + -> [TypecheckedQual] -- the rest of the qual's + -> DsM PlainCoreExpr + +dfListComp expr expr_ty c_ty c_id n_ty n_id [] + = mkCoAppDs (CoVar c_id) expr `thenDs` \ inner -> + mkCoAppDs inner (CoVar n_id) + +dfListComp expr expr_ty c_ty c_id n_ty n_id ((FilterQual filt) : quals) + = dsExpr filt `thenDs` \ core_filt -> + dfListComp expr expr_ty c_ty c_id n_ty n_id quals + `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_filt core_rest (CoVar n_id)) + +dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals) + -- evaluate the two lists + = dsExpr list1 `thenDs` \ core_list1 -> + + -- find the required type + + let p_ty = typeOfPat pat + b_ty = n_ty -- alias b_ty to n_ty + fn_ty = p_ty `mkFunTy` (b_ty `mkFunTy` b_ty) + lst_ty = typeOfCoreExpr core_list1 + in + + -- create some new local id's + + newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty] `thenDs` \ [b,p,fn,lst] -> + + -- build rest of the comprehesion + + dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest -> + -- build the pattern match + + matchSimply (CoVar p) pat b_ty core_rest (CoVar b) `thenDs` \ core_expr -> + + -- now build the outermost foldr, and return + + returnDs ( + mkCoLetsAny + [CoNonRec fn (CoLam [p,b] core_expr), + CoNonRec lst core_list1] + (mkFoldr p_ty n_ty fn n_id lst) + ) +\end{code} + diff --git a/ghc/compiler/deSugar/DsMonad.hi b/ghc/compiler/deSugar/DsMonad.hi new file mode 100644 index 0000000..8ffc667 --- /dev/null +++ b/ghc/compiler/deSugar/DsMonad.hi @@ -0,0 +1,118 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsMonad where +import Bag(Bag) +import BasicLit(BasicLit) +import Class(Class) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import HsPat(TypecheckedPat) +import Id(DataCon(..), Id, IdDetails, mkIdWithNewUniq, mkSysLocal) +import IdEnv(lookupIdEnv) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(ShortName) +import Outputable(NamedThing) +import PlainCore(PlainCoreExpr(..)) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply, getSUnique, splitUniqSupply) +import SrcLoc(SrcLoc, unpackSrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType) +import UniqFM(UniqFM, lookupUFM) +import Unique(UniqSM(..), Unique, UniqueSupply, mkUniqueGrimily, mkUniqueSupplyGrimily) +infixr 9 `thenDs` +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +type DataCon = Id +type DsIdEnv = UniqFM (CoreExpr Id Id) +type DsM a = SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) +data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext +data DsMatchKind = FunMatch Id | CaseMatch | LambdaMatch | PatBindMatch +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreExpr = CoreExpr Id Id +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +type UniqSM a = UniqueSupply -> (UniqueSupply, a) +andDs :: (a -> a -> a) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 9 _U_ 111122222 _N_ _S_ "LSSU(ALL)LLLLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0 -> u0 -> u0) (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) (u6 :: GlobalSwitch -> SwitchResult) (u7 :: (_PackedString, _PackedString)) (u8 :: UniqFM (CoreExpr Id Id)) (u9 :: Bag DsMatchContext) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ ub, u5, u6, u7, u8, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag DsMatchContext) -> case _APP_ u3 [ uc, u5, u6, u7, u8, ue ] of { _ALG_ _TUP_2 (uf :: u0) (ug :: Bag DsMatchContext) -> let {(uh :: u0) = _APP_ u1 [ ud, uf ]} in _!_ _TUP_2 [u0, (Bag DsMatchContext)] [uh, ug]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +cloneTyVarsDs :: [TyVar] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 2200002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +dsShadowError :: DsMatchContext -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 2000002 _N_ _S_ "LAAAAAL" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 9 \ (u0 :: DsMatchContext) (u1 :: SplitUniqSupply) (u2 :: SrcLoc) (u3 :: GlobalSwitch -> SwitchResult) (u4 :: (_PackedString, _PackedString)) (u5 :: UniqFM (CoreExpr Id Id)) (u6 :: Bag DsMatchContext) -> let {(u7 :: ()) = _!_ _TUP_0 [] []} in let {(u8 :: Bag DsMatchContext) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { DsMatchContext } [ u6, u0 ]} in _!_ _TUP_2 [(), (Bag DsMatchContext)] [u7, u8] _N_ #-} +duplicateLocalDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 1100002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +extendEnvDs :: [(Id, CoreExpr Id Id)] -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 8 _U_ 11122222 _N_ _S_ "SSU(ALL)LLLLL" _N_ _N_ #-} +getModuleAndGroupDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((_PackedString, _PackedString), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 6 _U_ 000202 _N_ _S_ "AAALAL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: (_PackedString, _PackedString)) (u1 :: Bag DsMatchContext) -> _!_ _TUP_2 [(_PackedString, _PackedString), (Bag DsMatchContext)] [u0, u1] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 3 \ (u0 :: SplitUniqSupply) (u1 :: SrcLoc) (u2 :: GlobalSwitch -> SwitchResult) (u3 :: (_PackedString, _PackedString)) (u4 :: UniqFM (CoreExpr Id Id)) (u5 :: Bag DsMatchContext) -> _!_ _TUP_2 [(_PackedString, _PackedString), (Bag DsMatchContext)] [u3, u5] _N_ #-} +mkIdWithNewUniq :: Id -> Unique -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLL)L" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkSysLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +lookupIdEnv :: UniqFM a -> Id -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSUnique :: SplitUniqSupply -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getSrcLocDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Char], [Char]), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 6 _U_ 010002 _N_ _S_ "ASAAAL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSwitchCheckerDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (GlobalSwitch -> Bool, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 6 _U_ 002002 _N_ _S_ "AALAAL" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 8 \ (u0 :: SplitUniqSupply) (u1 :: SrcLoc) (u2 :: GlobalSwitch -> SwitchResult) (u3 :: (_PackedString, _PackedString)) (u4 :: UniqFM (CoreExpr Id Id)) (u5 :: Bag DsMatchContext) -> let {(u7 :: GlobalSwitch -> Bool) = \ (u6 :: GlobalSwitch) -> _APP_ _TYAPP_ _ORIG_ CmdLineOpts switchIsOn { GlobalSwitch } [ u2, u6 ]} in _!_ _TUP_2 [(GlobalSwitch -> Bool), (Bag DsMatchContext)] [u7, u5] _N_ #-} +ifSwitchSetDs :: GlobalSwitch -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 9 _U_ 211222222 _N_ _S_ "LLLLLSLLL" _N_ _N_ #-} +initDs :: SplitUniqSupply -> UniqFM (CoreExpr Id Id) -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLS" _N_ _N_ #-} +listDs :: [SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([a], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 1122222 _N_ _S_ "SLLLLLL" _N_ _N_ #-} +lookupEnvDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Labda (CoreExpr Id Id), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 1000022 _N_ _S_ "LAAAALL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 CXXXXXX 9 \ (u0 :: Id) (u1 :: SplitUniqSupply) (u2 :: SrcLoc) (u3 :: GlobalSwitch -> SwitchResult) (u4 :: (_PackedString, _PackedString)) (u5 :: UniqFM (CoreExpr Id Id)) (u6 :: Bag DsMatchContext) -> let {(uc :: Labda (CoreExpr Id Id)) = case u0 of { _ALG_ _ORIG_ Id Id (u7 :: Unique) (u8 :: UniType) (u9 :: IdInfo) (ua :: IdDetails) -> case u7 of { _ALG_ _ORIG_ Unique MkUnique (ub :: Int#) -> _APP_ _TYAPP_ _WRKR_ _ORIG_ IdEnv lookupIdEnv { (CoreExpr Id Id) } [ u5, ub ]; _NO_DEFLT_ }; _NO_DEFLT_ }} in _!_ _TUP_2 [(Labda (CoreExpr Id Id)), (Bag DsMatchContext)] [uc, u6] _N_ #-} +lookupEnvWithDefaultDs :: Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 8 _U_ 11000022 _N_ _S_ "LLAAAALL" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupId :: [(Id, a)] -> Id -> a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: [(Id, u0)]) (u2 :: Id) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Util assoc [ (Id), _N_ ] { u0 } [ _NOREP_S_ "lookupId", u1, u2 ] _N_ #-} +lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +mapAndUnzipDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((b, c), Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([b], [c]), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +mapDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([b], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +mkUniqueGrimily :: Int# -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-} +mkUniqueSupplyGrimily :: SplitUniqSupply -> UniqueSupply + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: SplitUniqSupply) -> _!_ _ORIG_ Unique MkNewSupply [] [u0] _N_ #-} +newFailLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 2120002 _N_ _N_ _N_ _N_ #-} +newSysLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 2120002 _N_ _N_ _N_ _N_ #-} +newSysLocalsDs :: [UniType] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _N_ _N_ _N_ #-} +newTyVarsDs :: [TyVarTemplate] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 2200002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +putSrcLocDs :: SrcLoc -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 8 _U_ 21202222 _N_ _S_ "LSLALLLL" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: SplitUniqSupply) (u4 :: GlobalSwitch -> SwitchResult) (u5 :: (_PackedString, _PackedString)) (u6 :: UniqFM (CoreExpr Id Id)) (u7 :: Bag DsMatchContext) -> _APP_ u2 [ u3, u1, u4, u5, u6, u7 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: SplitUniqSupply) (u4 :: SrcLoc) (u5 :: GlobalSwitch -> SwitchResult) (u6 :: (_PackedString, _PackedString)) (u7 :: UniqFM (CoreExpr Id Id)) (u8 :: Bag DsMatchContext) -> _APP_ u2 [ u3, u1, u5, u6, u7, u8 ] _N_ #-} +returnDs :: a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 2000002 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) (u3 :: SrcLoc) (u4 :: GlobalSwitch -> SwitchResult) (u5 :: (_PackedString, _PackedString)) (u6 :: UniqFM (CoreExpr Id Id)) (u7 :: Bag DsMatchContext) -> _!_ _TUP_2 [u0, (Bag DsMatchContext)] [u1, u7] _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +thenDs :: (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 8 _U_ 11122222 _N_ _S_ "SSU(ALL)LLLLL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: u0 -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u1, Bag DsMatchContext)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) (u6 :: GlobalSwitch -> SwitchResult) (u7 :: (_PackedString, _PackedString)) (u8 :: UniqFM (CoreExpr Id Id)) (u9 :: Bag DsMatchContext) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ ub, u5, u6, u7, u8, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag DsMatchContext) -> _APP_ u3 [ ud, uc, u5, u6, u7, u8, ue ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +uniqSMtoDsM :: (UniqueSupply -> (UniqueSupply, a)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 7 _U_ 1200002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +unpackSrcLoc :: SrcLoc -> (_PackedString, _PackedString) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +zipWithDs :: (a -> b -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (c, Bag DsMatchContext)) -> [a] -> [b] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([c], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 211222222 _N_ _S_ "LSS" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs new file mode 100644 index 0000000..9a01390 --- /dev/null +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -0,0 +1,309 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DesugarMonad]{@DesugarMonad@: monadery used in desugaring} + +\begin{code} +#include "HsVersions.h" + +module DsMonad ( + DsM(..), + initDs, returnDs, thenDs, andDs, mapDs, listDs, + mapAndUnzipDs, zipWithDs, + uniqSMtoDsM, + newTyVarsDs, cloneTyVarsDs, + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, + newFailLocalDs, + getSrcLocDs, putSrcLocDs, + getSwitchCheckerDs, ifSwitchSetDs, + getModuleAndGroupDs, + extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs, + DsIdEnv(..), + lookupId, + + dsShadowError, + DsMatchContext(..), DsMatchKind(..), pprDsWarnings, + +#ifdef DPH + listDs, +#endif + + -- and to make the interface self-sufficient... + Id, DataCon(..), SrcLoc, TyVar, TyVarTemplate, UniType, TauType(..), + ThetaType(..), SigmaType(..), SplitUniqSupply, UniqSM(..), + PlainCoreExpr(..), CoreExpr, GlobalSwitch, SwitchResult + + IF_ATTACK_PRAGMAS(COMMA lookupUFM COMMA lookupIdEnv) + IF_ATTACK_PRAGMAS(COMMA mkIdWithNewUniq COMMA mkSysLocal) + IF_ATTACK_PRAGMAS(COMMA unpackSrcLoc COMMA mkUniqueSupplyGrimily) + IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily) + IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique) + ) where + +import AbsSyn +import AbsUniType ( cloneTyVarFromTemplate, cloneTyVar, + TyVar, TyVarTemplate, UniType, TauType(..), + ThetaType(..), SigmaType(..), Class + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + ) +import Bag +import CmdLineOpts -- ( GlobalSwitch(..), SwitchResult(..), switchIsOn ) +import Id ( mkIdWithNewUniq, mkSysLocal, Id, DataCon(..) ) +import IdEnv -- ( mkIdEnv, IdEnv ) +import Maybes ( assocMaybe, Maybe(..) ) +import Outputable +import PlainCore +import Pretty +import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc ) +import TyVarEnv -- ( nullTyVarEnv, TyVarEnv ) +import SplitUniq +import Unique +import Util + +infixr 9 `thenDs` +\end{code} + +Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around +a @UniqueSupply@ and some annotations, which +presumably include source-file location information: +\begin{code} +type DsM result = + SplitUniqSupply + -> SrcLoc -- to put in pattern-matching error msgs + -> (GlobalSwitch -> SwitchResult) -- so we can consult global switches + -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling + -> DsIdEnv + -> DsWarnings + -> (result, DsWarnings) + +type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are + -- completely shadowed + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE andDs #-} +{-# INLINE thenDs #-} +{-# INLINE returnDs #-} +#endif + +-- initDs returns the UniqSupply out the end (not just the result) + +initDs :: SplitUniqSupply + -> DsIdEnv + -> (GlobalSwitch -> SwitchResult) + -> FAST_STRING -- module name: for profiling; (group name: from switches) + -> DsM a + -> (a, DsWarnings) + +initDs init_us env sw_chkr mod_name action + = action init_us mkUnknownSrcLoc sw_chkr module_and_group env emptyBag + where + module_and_group = (mod_name, grp_name) + grp_name = case (stringSwitchSet sw_chkr SccGroup) of + Just xx -> _PK_ xx + Nothing -> mod_name -- default: module name + +thenDs :: DsM a -> (a -> DsM b) -> DsM b +andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a + +thenDs expr cont us loc sw_chkr mod_and_grp env warns + = case splitUniqSupply us of { (s1, s2) -> + case (expr s1 loc sw_chkr mod_and_grp env warns) of { (result, warns1) -> + cont result s2 loc sw_chkr mod_and_grp env warns1}} + +andDs combiner m1 m2 us loc sw_chkr mod_and_grp env warns + = case splitUniqSupply us of { (s1, s2) -> + case (m1 s1 loc sw_chkr mod_and_grp env warns) of { (result1, warns1) -> + case (m2 s2 loc sw_chkr mod_and_grp env warns1) of { (result2, warns2) -> + (combiner result1 result2, warns2) }}} + +returnDs :: a -> DsM a +returnDs result us loc sw_chkr mod_and_grp env warns = (result, warns) + +listDs :: [DsM a] -> DsM [a] +listDs [] = returnDs [] +listDs (x:xs) + = x `thenDs` \ r -> + listDs xs `thenDs` \ rs -> + returnDs (r:rs) + +mapDs :: (a -> DsM b) -> [a] -> DsM [b] + +mapDs f [] = returnDs [] +mapDs f (x:xs) + = f x `thenDs` \ r -> + mapDs f xs `thenDs` \ rs -> + returnDs (r:rs) + +mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c]) + +mapAndUnzipDs f [] = returnDs ([], []) +mapAndUnzipDs f (x:xs) + = f x `thenDs` \ (r1, r2) -> + mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) -> + returnDs (r1:rs1, r2:rs2) + +zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c] + +zipWithDs f [] [] = returnDs [] +zipWithDs f (x:xs) (y:ys) + = f x y `thenDs` \ r -> + zipWithDs f xs ys `thenDs` \ rs -> + returnDs (r:rs) +\end{code} + +And all this mysterious stuff is so we can occasionally reach out and +grab one or more names. @newLocalDs@ isn't exported---exported +functions are defined with it. The difference in name-strings makes +it easier to read debugging output. +\begin{code} +newLocalDs :: FAST_STRING -> UniType -> DsM Id +newLocalDs nm ty us loc sw_chkr mod_and_grp env warns + = case (getSUnique us) of { assigned_uniq -> + (mkSysLocal nm assigned_uniq ty loc, warns) } + +newSysLocalDs = newLocalDs SLIT("ds") +newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys +newFailLocalDs = newLocalDs SLIT("fail") + +duplicateLocalDs :: Id -> DsM Id +duplicateLocalDs old_local us loc sw_chkr mod_and_grp env warns + = case (getSUnique us) of { assigned_uniq -> + (mkIdWithNewUniq old_local assigned_uniq, warns) } + +cloneTyVarsDs :: [TyVar] -> DsM [TyVar] +cloneTyVarsDs tyvars us loc sw_chkr mod_and_grp env warns + = case (getSUniques (length tyvars) us) of { uniqs -> + (zipWith cloneTyVar tyvars uniqs, warns) } +\end{code} + +\begin{code} +newTyVarsDs :: [TyVarTemplate] -> DsM [TyVar] + +newTyVarsDs tyvar_tmpls us loc sw_chkr mod_and_grp env warns + = case (getSUniques (length tyvar_tmpls) us) of { uniqs -> + (zipWith cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) } +\end{code} + +We can also reach out and either set/grab location information from +the @SrcLoc@ being carried around. +\begin{code} +uniqSMtoDsM :: UniqSM a -> DsM a + +uniqSMtoDsM u_action us loc sw_chkr mod_and_grp env warns + = let + us_to_use = mkUniqueSupplyGrimily us + in + (snd (u_action us_to_use), warns) + +getSrcLocDs :: DsM (String, String) +getSrcLocDs us loc sw_chkr mod_and_grp env warns + = case (unpackSrcLoc loc) of { (x,y) -> + ((_UNPK_ x, _UNPK_ y), warns) } + +putSrcLocDs :: SrcLoc -> DsM a -> DsM a +putSrcLocDs new_loc expr us old_loc sw_chkr mod_and_grp env warns + = expr us new_loc sw_chkr mod_and_grp env warns + +dsShadowError :: DsMatchContext -> DsM () +dsShadowError cxt us loc sw_chkr mod_and_grp env warns + = ((), warns `snocBag` cxt) +\end{code} + +\begin{code} +getSwitchCheckerDs :: DsM (GlobalSwitch -> Bool) +getSwitchCheckerDs us loc sw_chkr mod_and_grp env warns + = (switchIsOn sw_chkr, warns) + +ifSwitchSetDs :: GlobalSwitch -> DsM a -> DsM a -> DsM a +ifSwitchSetDs switch then_ else_ us loc sw_chkr mod_and_grp env warns + = (if switchIsOn sw_chkr switch then then_ else else_) + us loc sw_chkr mod_and_grp env warns + +getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING) +getModuleAndGroupDs us loc sw_chkr mod_and_grp env warns + = (mod_and_grp, warns) +\end{code} + +\begin{code} +type DsIdEnv = IdEnv PlainCoreExpr + +extendEnvDs :: [(Id, PlainCoreExpr)] -> DsM a -> DsM a + +extendEnvDs pairs expr us loc sw_chkr mod_and_grp old_env warns + = case splitUniqSupply us of { (s1, s2) -> + case (mapAccumL subst s1 pairs) of { (_, revised_pairs) -> + expr s2 loc sw_chkr mod_and_grp (growIdEnvList old_env revised_pairs) warns + }} + where + subst us (v, expr) + = case splitUniqSupply us of { (s1, s2) -> + let + us_to_use = mkUniqueSupplyGrimily s1 + in + case (substCoreExpr us_to_use old_env nullTyVarEnv expr) of { (_, expr2) -> + (s2, (v, expr2)) }} + +lookupEnvDs :: Id -> DsM (Maybe PlainCoreExpr) +lookupEnvDs id us loc sw_chkr mod_and_grp env warns + = (lookupIdEnv env id, warns) + -- Note: we don't assert anything about the Id + -- being looked up. There's not really anything + -- much to say about it. (WDP 94/06) + +lookupEnvWithDefaultDs :: Id -> PlainCoreExpr -> DsM PlainCoreExpr +lookupEnvWithDefaultDs id deflt us loc sw_chkr mod_and_grp env warns + = (case (lookupIdEnv env id) of + Nothing -> deflt + Just xx -> xx, + warns) + +lookupId :: [(Id, a)] -> Id -> a +lookupId env id + = assoc "lookupId" env id +\end{code} + +%************************************************************************ +%* * +%* type synonym EquationInfo and access functions for its pieces * +%* * +%************************************************************************ + +\begin{code} +data DsMatchContext + = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc + | NoMatchContext + +data DsMatchKind + = FunMatch Id + | CaseMatch + | LambdaMatch + | PatBindMatch + +pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty +pprDsWarnings sty warns + = ppAboves (map pp_cxt (bagToList warns)) + where + pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what") + pp_cxt (DsMatchContext kind pats loc) + = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) + 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:")) + 4 (pp_match kind pats)) + + pp_match (FunMatch fun) pats + = ppHang (ppr sty fun) + 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")]) + + pp_match CaseMatch pats + = ppHang (ppPStr SLIT("in a case alternative:")) + 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + + pp_match PatBindMatch pats + = ppHang (ppPStr SLIT("in a pattern binding:")) + 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + + pp_match LambdaMatch pats + = ppHang (ppPStr SLIT("in a lambda abstraction:")) + 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + + pp_arrow_dotdotdot = ppPStr SLIT("-> ...") +\end{code} diff --git a/ghc/compiler/deSugar/DsParZF.lhs b/ghc/compiler/deSugar/DsParZF.lhs new file mode 100644 index 0000000..0f8ff6d --- /dev/null +++ b/ghc/compiler/deSugar/DsParZF.lhs @@ -0,0 +1,233 @@ +%************************************************************************ +%* * +\section[DsParZF]{Desugaring Parallel ZF expressisions} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" +module DsParZF where + +IMPORT_Trace -- ToDo: rm + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer +import AbsPrel ( mkFunTy , eRROR_ID , integerTy, + fromDomainId , toDomainId) +import DsExpr ( dsExpr ) +import DsUtils ( mkSelectorBinds , EquationInfo(..)) +import Match ( match ) +import FiniteMap -- WAS: Set +import FreeVars +import SrcLoc +import BasicLit ( BasicLit(..) ) +import Util +\end{code} + +The purpose of the module is to convert the abstract syntax representation +of parallel ZF expressions into the core syntax representation. The two +representations differ in that the core syntax only contains binders in +drawn and index from generators. + +\begin{description} +\item[The ``Idea''] For each pattern in a generator we apply the function +$\lambda hole\ .\ {\cal D}[[{\tt (\\pat ->}\ hole {\tt )x}]]$ to +{\em every} expression in an inner scope than that of the definition of +the pattern; {\tt x} represents the binder in the generator after translation, +${\cal D}[[exp]]$ represents the desugaring of the expression $exp$. + +\item[Optimising the ``Idea''] We catagorise each pattern into two types; +simple patterns in which their are no binders, and complex patterns. We +only apply simple patterns to the left handside of a ZF expressions, and +complex patterns to expressions in which the intersection of the free +variables of the expression, and the binders of the pattern is non-empty. +\end{description} + +%************************************************************************ +%* * +\subsection[dsParallelZF]{Interface to the outside world} +%* * +%************************************************************************ + +\begin{code} +dsParallelZF::TypecheckedExpr -> TypecheckedParQuals -> DsM PlainCoreExpr +dsParallelZF expr quals + = dsParQuals quals `thenDs` (\ (quals',hf) -> + dsExpr expr `thenDs` ( \ expr' -> + let_1_0 (typeOfCoreExpr expr') ( \ ty -> + returnDs (CoZfExpr (applyHoleLhsExpr ty expr' hf) quals') ))) +\end{code} + +%************************************************************************ +%* * +\subsection[dsZF_datatype]{DataType used to represent ``HoleFunction''} +%* * +%************************************************************************ + +\begin{code} +type HoleFunction = (UniType -> PlainCoreExpr -> PlainCoreExpr, + [(PlainCoreExpr -> Bool, + UniType -> PlainCoreExpr -> PlainCoreExpr)]) +\end{code} + +\begin{code} +combine fn fn' = \t e -> fn t (fn' t e) +\end{code} + +\begin{code} +combineHoles:: HoleFunction -> HoleFunction -> HoleFunction +combineHoles (lhs,rhs) (lhs',rhs') + = (combine lhs lhs',rhs++rhs') +\end{code} + +\begin{code} +identityHole::HoleFunction +identityHole = (\t e -> e,[]) +\end{code} + +\begin{code} +applyHoleLhsExpr:: UniType + -> PlainCoreExpr + -> HoleFunction + -> PlainCoreExpr +applyHoleLhsExpr ty expr (lhs,rhs) + = (combine lhs (foldr combine (\t e -> e) (map snd rhs))) ty expr +\end{code} + +\begin{code} +applyHoleRhsExpr ty expr (_,rhs) + = (foldr combine (\t e -> e) [ y | (x,y) <- rhs, (x expr)]) ty expr +\end{code} + +\begin{code} +applyHoleFunction :: PlainCoreParQuals + -> HoleFunction + -> PlainCoreParQuals +applyHoleFunction (CoAndQuals left right) hf + = CoAndQuals (applyHoleFunction left hf) (applyHoleFunction right hf) + +applyHoleFunction (CoParFilter expr) hf + = CoParFilter (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf) + +applyHoleFunction (CoDrawnGen pats pat expr) hf + = CoDrawnGen pats pat (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf) + +applyHoleFunction (CoIndexGen exprs pat expr) hf + = CoIndexGen (map (\x -> applyHoleRhsExpr (typeOfCoreExpr x) x hf) exprs) + pat + (applyHoleRhsExpr (typeOfCoreExpr expr) expr hf) +\end{code} + +%************************************************************************ +%* * +\subsection[dsParQuals]{Desugaring the qualifiers} +%* * +%************************************************************************ + +\begin{code} +dsParQuals::TypecheckedParQuals + -> DsM (PlainCoreParQuals,HoleFunction) +\end{code} + +\begin{code} +dsParQuals (AndParQuals left right) + = dsParQuals left `thenDs` (\ (left', hfleft) -> + dsParQuals right `thenDs` (\ (right',hfright) -> + returnDs (CoAndQuals left' (applyHoleFunction right' hfleft), + combineHoles hfleft hfright) )) + +\end{code} + +\begin{code} +dsParQuals (ParFilter expr) + = dsExpr expr `thenDs` (\ expr' -> + returnDs (CoParFilter expr', identityHole) ) + +dsParQuals (DrawnGenOut pats convs pat dRHS) + = listDs (map dsExpr convs) `thenDs` (\ convs' -> + listDs (map prettyNewLocalDs pats) + `thenDs` (\ binders -> + listDs (zipWith3 dsPid pats binders convs') + `thenDs` (\ hfList -> + let_1_0 (foldr1 (combineHoles) hfList) (\ hf -> + prettyNewLocalDs pat `thenDs` (\ iden -> + duplicateLocalDs iden `thenDs` (\ binder -> + dsPid pat binder (CoLam [iden] (CoVar iden)) + `thenDs` (\ hf' -> + dsExpr dRHS `thenDs` (\ dRHS' -> + returnDs (CoDrawnGen binders binder dRHS', + combineHoles hf hf') )))))))) + + +dsParQuals (IndexGen exprs pat iRHS) + = listDs (map dsExpr exprs) `thenDs` (\ exprs' -> + prettyNewLocalDs pat `thenDs` (\ binder -> + duplicateLocalDs binder `thenDs` (\ iden -> + dsPid pat binder (CoLam [iden] (CoVar iden)) + `thenDs` (\ hf -> + dsExpr iRHS `thenDs` (\ iRHS' -> + returnDs (CoIndexGen exprs' binder iRHS' ,hf) ))))) + +\end{code} + +\begin{code} +dsPid:: TypecheckedPat -- Pattern to be desugared + -> Id -- Patterns desugared binder + -> PlainCoreExpr -- Conversion function + -> DsM HoleFunction + +dsPid pat binder conv + = duplicateLocalDs binder `thenDs` (\ lambdaBind -> + getSrcLocDs `thenDs` (\ (sfile,sline) -> + let_1_0 ("\""++sfile++"\", line "++sline++" : "++ + "Processor not defined\n") ( \ errorStr -> + getUniqueSupplyDs `thenDs` (\ us -> + let_1_0 (collectTypedPatBinders pat) (\ patBinders -> + case (null patBinders) of + True -> returnDs (mkHole lambdaBind errorStr us,[]) + False -> + returnDs (\t e -> e, [(mkPredicate patBinders, + mkHole lambdaBind errorStr us)]) ))))) + + where + mkPredicate b e + = let_1_0 (freeStuff b e) (\ ((fvSet,_),_) -> + let_1_0 (mkSet b) (\ bSet -> + not (isEmptySet (intersect fvSet bSet)) )) + + mkHole lambdaBind errorStr us + = \ ty expr -> + (CoApp + (CoLam + [lambdaBind] + (snd (initDs + us + nullIdEnv + (\ _ -> False) -- Hack alert!!! + (panic "mkHole: module name") + (match [lambdaBind] [([pat], \x -> expr)] + (CoApp + (mkCoTyApp (CoVar eRROR_ID) ty) + (CoLit (NoRepStr (_PK_ errorStr)))))))) + (CoApp conv (CoVar binder))) +\end{code} + +In the mkHole function we need to conjure up some state so we can +use the match function... +%************************************************************************ +%* * +\subsection[prettyLocals]{Make a new binder; try and keep names nice :-)} +%* * +%************************************************************************ + +\begin{code} +prettyNewLocalDs::TypecheckedPat -> DsM Id +prettyNewLocalDs (VarPat id) = duplicateLocalDs id +prettyNewLocalDs (AsPat id _) = duplicateLocalDs id +preetyNewLocalDs pat = let_1_0 (typeOfPat pat) (\ pat_ty-> + newSysLocalDs pat_ty + ) +\end{code} diff --git a/ghc/compiler/deSugar/DsUtils.hi b/ghc/compiler/deSugar/DsUtils.hi new file mode 100644 index 0000000..ff077e2 --- /dev/null +++ b/ghc/compiler/deSugar/DsUtils.hi @@ -0,0 +1,50 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DsUtils where +import Bag(Bag) +import BasicLit(BasicLit) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreAtom, CoreBinding, CoreExpr) +import DsMonad(DsMatchContext) +import HsPat(TypecheckedPat) +import Id(Id) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM) +data CanItFail = CanFail | CantFail +data EquationInfo = EqnInfo [TypecheckedPat] MatchResult +data MatchResult = MatchResult CanItFail UniType (CoreExpr Id Id -> CoreExpr Id Id) DsMatchContext +combineGRHSMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 11222222 _N_ _S_ "U(ELLL)L" {_A_ 5 _U_ 22221222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +combineMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 11222222 _N_ _S_ "U(ELLL)L" {_A_ 5 _U_ 22221222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +dsExprToAtom :: CoreExpr Id Id -> (CoreAtom Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "SS" _N_ _N_ #-} +mkCoAlgCaseMatchResult :: Id -> [(Id, [Id], MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "U(LSLL)L" {_A_ 5 _U_ 22222222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkCoAppDs :: CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-} +mkCoConDs :: Id -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 221222222 _N_ _S_ "LLS" _N_ _N_ #-} +mkCoLetsMatchResult :: [CoreBinding Id Id] -> MatchResult -> MatchResult + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkCoPrimCaseMatchResult :: Id -> [(BasicLit, MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 8 _U_ 22120002 _N_ _S_ "LLU(ALA)LLLLL" _N_ _N_ #-} +mkCoPrimDs :: PrimOp -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 221222222 _N_ _S_ "LLS" _N_ _N_ #-} +mkFailurePair :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((CoreExpr Id Id -> CoreBinding Id Id, CoreExpr Id Id), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-} +mkGuardedMatchResult :: CoreExpr Id Id -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 8 _U_ 21000002 _N_ _S_ "LU(ALLL)AAAAAL" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkSelectorBinds :: [TyVar] -> TypecheckedPat -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 4 _U_ 2222122222 _N_ _S_ "LSSL" _N_ _N_ #-} +mkTupleBind :: [TyVar] -> [Id] -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 4 _U_ 2222222222 _N_ _S_ "LLSL" _N_ _N_ #-} +mkTupleExpr :: [Id] -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +selectMatchVars :: [TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs new file mode 100644 index 0000000..5e0031d --- /dev/null +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -0,0 +1,556 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DsUtils]{Utilities for desugaring} + +This module exports some utility functions of no great interest. + +\begin{code} +#include "HsVersions.h" + +module DsUtils ( + CanItFail(..), EquationInfo(..), MatchResult(..), + + combineGRHSMatchResults, + combineMatchResults, + dsExprToAtom, + mkCoAlgCaseMatchResult, + mkCoAppDs, + mkCoConDs, + mkCoLetsMatchResult, + mkCoPrimCaseMatchResult, + mkCoPrimDs, + mkFailurePair, + mkGuardedMatchResult, + mkSelectorBinds, + mkTupleBind, + mkTupleExpr, + selectMatchVars + ) where + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsPrel ( mkFunTy, stringTy + IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) + ) +import AbsUniType ( mkTyVarTy, quantifyTy, mkTupleTyCon, + mkRhoTy, splitDictType, applyTyCon, + getUniDataTyCon, isUnboxedDataType, + TyVar, TyVarTemplate, TyCon, Arity(..), Class, + UniType, RhoType(..), SigmaType(..) + ) +import Id ( getIdUniType, getInstantiatedDataConSig, + mkTupleCon, DataCon(..), Id + ) +import Maybes ( Maybe(..) ) +import Match ( match, matchSimply ) +import Pretty +import Unique ( initUs, UniqueSupply, UniqSM(..) ) +import UniqSet +import Util +\end{code} + +%************************************************************************ +%* * +%* type synonym EquationInfo and access functions for its pieces * +%* * +%************************************************************************ +\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} + +The ``equation info'' used by @match@ is relatively complicated and +worthy of a type synonym and a few handy functions. + +\begin{code} +data EquationInfo + = EqnInfo + [TypecheckedPat] -- the patterns for an eqn + MatchResult -- Encapsulates the guards and bindings +\end{code} + +\begin{code} +data MatchResult + = MatchResult + CanItFail + UniType -- Type of argument expression + + (PlainCoreExpr -> PlainCoreExpr) + -- Takes a expression to plug in at the + -- failure point(s). The expression should + -- be duplicatable! + + DsMatchContext -- The context info is used when producing warnings + -- about shadowed patterns. It's the context + -- of the *first* thing matched in this group. + -- Should perhaps be a list of them all! + +data CanItFail = CanFail | CantFail + +orFail CantFail CantFail = CantFail +orFail _ _ = CanFail + + +mkCoLetsMatchResult :: [PlainCoreBinding] -> MatchResult -> MatchResult +mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt) + = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt + +mkGuardedMatchResult :: PlainCoreExpr -> MatchResult -> DsM MatchResult +mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt) + = returnDs (MatchResult CanFail + ty + (\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail) + cxt + ) + +mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> [(BasicLit, MatchResult)] -- Alternatives + -> DsM MatchResult +mkCoPrimCaseMatchResult var alts + = newSysLocalDs (getIdUniType var) `thenDs` \ wild -> + returnDs (MatchResult CanFail + ty1 + (mk_case alts wild) + cxt1) + where + ((_,MatchResult _ ty1 _ cxt1) : _) = alts + + mk_case alts wild fail_expr + = CoCase (CoVar var) (CoPrimAlts final_alts (CoBindDefault wild fail_expr)) + where + final_alts = [ (lit, body_fn fail_expr) + | (lit, MatchResult _ _ body_fn _) <- alts + ] + + +mkCoAlgCaseMatchResult :: Id -- Scrutinee + -> [(DataCon, [Id], MatchResult)] -- Alternatives + -> DsM MatchResult +mkCoAlgCaseMatchResult var alts + = -- Find all the constructors in the type which aren't + -- explicitly mentioned in the alternatives: + case un_mentioned_constructors of + [] -> -- All constructors mentioned, so no default needed + returnDs (MatchResult can_any_alt_fail + ty1 + (mk_case alts (\ignore -> CoNoDefault)) + cxt1) + + [con] -> -- Just one constructor missing, so add a case for it + -- We need to build new locals for the args of the constructor, + -- and figuring out their types is somewhat tiresome. + let + (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys + in + newSysLocalsDs arg_tys `thenDs` \ arg_ids -> + + -- Now we are ready to construct the new alternative + let + new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext) + in + returnDs (MatchResult CanFail + ty1 + (mk_case (new_alt:alts) (\ignore -> CoNoDefault)) + cxt1) + + other -> -- Many constructors missing, so use a default case + newSysLocalDs scrut_ty `thenDs` \ wild -> + returnDs (MatchResult CanFail + ty1 + (mk_case alts (\fail_expr -> CoBindDefault wild fail_expr)) + cxt1) + where + scrut_ty = getIdUniType var + (tycon, tycon_arg_tys, data_cons) = getUniDataTyCon scrut_ty + + un_mentioned_constructors + = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] ) + + match_results = [match_result | (_,_,match_result) <- alts] + (MatchResult _ ty1 _ cxt1 : _) = match_results + can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results] + + mk_case alts deflt_fn fail_expr + = CoCase (CoVar var) (CoAlgAlts final_alts (deflt_fn fail_expr)) + where + final_alts = [ (con, args, body_fn fail_expr) + | (con, args, MatchResult _ _ body_fn _) <- alts + ] + + +combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult +combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1) + (MatchResult can_it_fail2 ty2 body_fn2 cxt2) + = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) -> + let + new_body_fn1 = \body1 -> CoLet (bind_fn body1) (body_fn1 duplicatable_expr) + new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2) + in + returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1) + +combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) + match_result2 + = returnDs match_result1 + + +-- The difference in combineGRHSMatchResults is that there is no +-- need to let-bind to avoid code duplication +combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult +combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1) + (MatchResult can_it_fail ty2 body_fn2 cxt2) + = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1) + +combineGRHSMatchResults match_result1 match_result2 + = -- Delegate to avoid duplication of code + combineMatchResults match_result1 match_result2 +\end{code} + +%************************************************************************ +%* * +\subsection[dsExprToAtom]{Take an expression and produce an atom} +%* * +%************************************************************************ + +\begin{code} +dsExprToAtom :: PlainCoreExpr -- The argument expression + -> (PlainCoreAtom -> DsM PlainCoreExpr) -- Something taking the argument *atom*, + -- and delivering an expression E + -> DsM PlainCoreExpr -- Either E or let x=arg-expr in E + +dsExprToAtom (CoVar v) continue_with = continue_with (CoVarAtom v) +dsExprToAtom (CoLit v) continue_with = continue_with (CoLitAtom v) + +dsExprToAtom arg_expr continue_with + = newSysLocalDs ty `thenDs` \ arg_id -> + continue_with (CoVarAtom arg_id) `thenDs` \ body -> + if isUnboxedDataType ty + then returnDs (CoCase arg_expr (CoPrimAlts [] (CoBindDefault arg_id body))) + else returnDs (CoLet (CoNonRec arg_id arg_expr) body) + where + ty = typeOfCoreExpr arg_expr + +dsExprsToAtoms :: [PlainCoreExpr] + -> ([PlainCoreAtom] -> DsM PlainCoreExpr) + -> DsM PlainCoreExpr + +dsExprsToAtoms [] continue_with + = continue_with [] + +dsExprsToAtoms (arg:args) continue_with + = dsExprToAtom arg (\ arg_atom -> + dsExprsToAtoms args (\ arg_atoms -> + continue_with (arg_atom:arg_atoms) + )) +\end{code} + +%************************************************************************ +%* * +\subsection[mkCoAppDs]{Desugarer's versions of some Core functions} +%* * +%************************************************************************ + +Plumb the desugarer's @UniqueSupply@ in/out of the @UniqueSupplyMonad@ +world. +\begin{code} +mkCoAppDs :: PlainCoreExpr -> PlainCoreExpr -> DsM PlainCoreExpr +mkCoConDs :: Id -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr +mkCoPrimDs :: PrimOp -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr + +mkCoAppDs fun arg_expr + = dsExprToAtom arg_expr (\ arg_atom -> returnDs (CoApp fun arg_atom)) + +mkCoConDs con tys arg_exprs + = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoCon con tys arg_atoms)) + +mkCoPrimDs op tys arg_exprs + = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoPrim op tys arg_atoms)) +\end{code} + +%************************************************************************ +%* * +\subsection[mkSelectorBind]{Make a selector bind} +%* * +%************************************************************************ + +This is used in various places to do with lazy patterns. +For each binder $b$ in the pattern, we create a binding: + + b = case v of pat' -> b' + +where pat' is pat with each binder b cloned into b'. + +ToDo: making these bindings should really depend on whether there's +much work to be done per binding. If the pattern is complex, it +should be de-mangled once, into a tuple (and then selected from). +Otherwise the demangling can be in-line in the bindings (as here). + +Boring! Boring! One error message per binder. The above ToDo is +even more helpful. Something very similar happens for pattern-bound +expressions. + +\begin{code} +mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic + -> TypecheckedPat -- The pattern + -> [(Id,Id)] -- Monomorphic and polymorphic binders for + -- the pattern + -> PlainCoreExpr -- Expression to which the pattern is bound + -> DsM [(Id,PlainCoreExpr)] + +mkSelectorBinds tyvars pat locals_and_globals val_expr + = getSrcLocDs `thenDs` \ (src_file, src_line) -> + + if is_simple_tuple_pat pat then + mkTupleBind tyvars [] locals_and_globals val_expr + else + newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the string + let + src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line + error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern" + error_msg = mkErrorCoApp res_ty str_var error_string + in + matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> + mkTupleBind tyvars [] locals_and_globals tuple_expr + where + locals = [local | (local, _) <- locals_and_globals] + local_tuple = mkTupleExpr locals + res_ty = typeOfCoreExpr local_tuple + + is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps + is_simple_tuple_pat other = False + + is_var_pat (VarPat v) = True + is_var_pat other = False -- Even wild-card patterns aren't acceptable +\end{code} + +We're about to match against some patterns. We want to make some +@Ids@ to use as match variables. If a pattern has an @Id@ readily at +hand, which should indeed be bound to the pattern as a whole, then use it; +otherwise, make one up. +\begin{code} +selectMatchVars :: [TypecheckedPat] -> DsM [Id] +selectMatchVars pats + = mapDs var_from_pat_maybe pats + where + var_from_pat_maybe (VarPat var) = returnDs var + var_from_pat_maybe (AsPat var pat) = returnDs var + var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat + +-- var_from_pat_maybe (NPlusKPat n _ _ _ _ _) = returnDs n +-- WRONG! We don't want to bind n to the pattern as a whole! + + var_from_pat_maybe other_pat + = newSysLocalDs (typeOfPat other_pat) -- OK, better make up one... +\end{code} + +\begin{code} +mkTupleBind :: [TyVar] -- Abstract wrt these... + -> [DictVar] -- ... and these + + -> [(Id, Id)] -- Local, global pairs, equal in number + -- to the size of the tuple. The types + -- of the globals is the generalisation of + -- the corresp local, wrt the tyvars and dicts + + -> PlainCoreExpr -- Expr whose value is a tuple; the expression + -- may mention the tyvars and dicts + + -> DsM [(Id, PlainCoreExpr)] -- Bindings for the globals +\end{code} + +The general call is +\begin{verbatim} + mkTupleBind tyvars dicts [(l1,g1), ..., (ln,gn)] tup_expr +\end{verbatim} +If $n=1$, the result is: +\begin{verbatim} + g1 = /\ tyvars -> \ dicts -> rhs +\end{verbatim} +Otherwise, the result is: +\begin{verbatim} + tup = /\ tyvars -> \ dicts -> tup_expr + g1 = /\ tyvars -> \ dicts -> case (tup tyvars dicts) of + (l1, ..., ln) -> l1 + ...etc... +\end{verbatim} + +\begin{code} +mkTupleBind tyvars dicts [(local,global)] tuple_expr + = returnDs [(global, mkCoTyLam tyvars (mkCoLam dicts tuple_expr))] +\end{code} + +The general case: + +\begin{code} +mkTupleBind tyvars dicts local_global_prs tuple_expr + = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> + + zipWithDs (mk_selector (CoVar tuple_var)) + local_global_prs + [(0::Int) .. (length local_global_prs - 1)] + `thenDs` \ tup_selectors -> + returnDs ( + (tuple_var, mkCoTyLam tyvars (mkCoLam dicts tuple_expr)) : + tup_selectors + ) + where + locals, globals :: [Id] + locals = [local | (local,global) <- local_global_prs] + globals = [global | (local,global) <- local_global_prs] + + no_of_binders = length local_global_prs + tyvar_tys = map mkTyVarTy tyvars + + tuple_var_ty :: UniType + tuple_var_ty + = case (quantifyTy tyvars (mkRhoTy theta + (applyTyCon (mkTupleTyCon no_of_binders) + (map getIdUniType locals)))) of + (_{-tossed templates-}, ty) -> ty + where + theta = map (splitDictType . getIdUniType) dicts + + mk_selector :: PlainCoreExpr -> (Id, Id) -> Int -> DsM (Id, PlainCoreExpr) + + mk_selector tuple_var_expr (local, global) which_local + = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders -> + let + selected = binders !! which_local + in + returnDs ( + (global, mkCoTyLam tyvars ( + mkCoLam dicts ( + mkTupleSelector (mkCoApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts) + binders selected))) + ) + +mkCoApp_XX :: PlainCoreExpr -> [Id] -> PlainCoreExpr +mkCoApp_XX expr [] = expr +mkCoApp_XX expr (id:ids) = mkCoApp_XX (CoApp expr (CoVarAtom id)) ids +\end{code} + + + +@mkTupleExpr@ builds a tuple; the inverse to mkTupleSelector. +If it has only one element, it is +the identity function. + +\begin{code} +mkTupleExpr :: [Id] -> PlainCoreExpr + +mkTupleExpr [] = CoCon (mkTupleCon 0) [] [] +mkTupleExpr [id] = CoVar id +mkTupleExpr ids = CoCon (mkTupleCon (length ids)) + (map getIdUniType ids) + [ CoVarAtom i | i <- ids ] +\end{code} + + +@mkTupleSelector@ builds a selector which scrutises the given +expression and extracts the one name from the list given. +If you want the no-shadowing rule to apply, the caller +is responsible for making sure that none of these names +are in scope. + +If there is just one id in the ``tuple'', then the selector is +just the identity. + +\begin{code} +mkTupleSelector :: PlainCoreExpr -- Scrutinee + -> [Id] -- The tuple args + -> Id -- The selected one + -> PlainCoreExpr + +mkTupleSelector expr [] the_var = panic "mkTupleSelector" + +mkTupleSelector expr [var] should_be_the_same_var + = ASSERT(var == should_be_the_same_var) + expr + +mkTupleSelector expr vars the_var + = CoCase expr (CoAlgAlts [(mkTupleCon arity, vars, CoVar the_var)] + CoNoDefault) + where + arity = length vars +\end{code} + + +%************************************************************************ +%* * +\subsection[mkFailurePair]{Code for pattern-matching and other failures} +%* * +%************************************************************************ + +Generally, we handle pattern matching failure like this: let-bind a +fail-variable, and use that variable if the thing fails: +\begin{verbatim} + let fail.33 = error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 + p3 -> fail.33 + p4 -> ... +\end{verbatim} +Then +\begin{itemize} +\item +If the case can't fail, then there'll be no mention of fail.33, and the +simplifier will later discard it. + +\item +If it can fail in only one way, then the simplifier will inline it. + +\item +Only if it is used more than once will the let-binding remain. +\end{itemize} + +There's a problem when the result of the case expression is of +unboxed type. Then the type of fail.33 is unboxed too, and +there is every chance that someone will change the let into a case: +\begin{verbatim} + case error "Help" of + fail.33 -> case .... +\end{verbatim} + +which is of course utterly wrong. Rather than drop the condition that +only boxed types can be let-bound, we just turn the fail into a function +for the primitive case: +\begin{verbatim} + let fail.33 :: () -> Int# + fail.33 = \_ -> error "Help" + in + case x of + p1 -> ... + p2 -> fail.33 () + p3 -> fail.33 () + p4 -> ... +\end{verbatim} + +Now fail.33 is a function, so it can be let-bound. + +\begin{code} +mkFailurePair :: UniType -- Result type of the whole case expression + -> DsM (PlainCoreExpr -> PlainCoreBinding, + -- Binds the newly-created fail variable + -- to either the expression or \_ -> expression + PlainCoreExpr) -- Either the fail variable, or fail variable + -- applied to unit tuple +mkFailurePair ty + | isUnboxedDataType ty + = newFailLocalDs (mkFunTy unit_ty ty) `thenDs` \ fail_fun_var -> + newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> + returnDs (\ body -> CoNonRec fail_fun_var (CoLam [fail_fun_arg] body), + CoApp (CoVar fail_fun_var) (CoVarAtom unit_id)) + + | otherwise + = newFailLocalDs ty `thenDs` \ fail_var -> + returnDs (\ body -> CoNonRec fail_var body, CoVar fail_var) + +unit_id :: Id -- out here to avoid CAF (sigh) +unit_id = mkTupleCon 0 + +unit_ty :: UniType +unit_ty = getIdUniType unit_id +\end{code} diff --git a/ghc/compiler/deSugar/Jmakefile b/ghc/compiler/deSugar/Jmakefile new file mode 100644 index 0000000..3e0bd41 --- /dev/null +++ b/ghc/compiler/deSugar/Jmakefile @@ -0,0 +1,11 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) +HaskellSuffixRules() + +/* LIT2LATEX_OPTS=-tbird */ + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTargetWithNamedOutput(root,lit,root-standalone) diff --git a/ghc/compiler/deSugar/Match.hi b/ghc/compiler/deSugar/Match.hi new file mode 100644 index 0000000..0a1697c --- /dev/null +++ b/ghc/compiler/deSugar/Match.hi @@ -0,0 +1,22 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Match where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext, DsMatchKind) +import DsUtils(EquationInfo, MatchResult) +import HsMatches(Match) +import HsPat(TypecheckedPat) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniType(UniType) +import UniqFM(UniqFM) +match :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "SSS" _N_ _N_ #-} +matchSimply :: CoreExpr Id Id -> TypecheckedPat -> UniType -> CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 5 _U_ 22222222222 _N_ _S_ "SLLLL" _N_ _N_ #-} +matchWrapper :: DsMatchKind -> [Match Id TypecheckedPat] -> [Char] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Id], CoreExpr Id Id), Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "LSL" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs new file mode 100644 index 0000000..5f1eaea --- /dev/null +++ b/ghc/compiler/deSugar/Match.lhs @@ -0,0 +1,712 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[Main_match]{The @match@ function} + +\begin{code} +module Match ( + match, matchWrapper, matchSimply + ) where + +#include "HsVersions.h" + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsPrel ( nilDataCon, consDataCon, mkTupleTy, mkListTy, + charTy, charDataCon, intTy, intDataCon, floatTy, + floatDataCon, doubleTy, doubleDataCon, + integerTy, intPrimTy, charPrimTy, + floatPrimTy, doublePrimTy, mkFunTy, stringTy, + addrTy, addrPrimTy, addrDataCon, + wordTy, wordPrimTy, wordDataCon +#ifdef DPH + ,mkProcessorTy +#endif {- Data Parallel Haskell -} + ) +import PrimKind ( PrimKind(..) ) -- Rather ugly import; ToDo??? + +import AbsUniType ( isPrimType ) +import DsBinds ( dsBinds ) +import DsExpr ( dsExpr ) +import DsGRHSs ( dsGRHSs ) +import DsUtils +#ifdef DPH +import Id ( eqId, getIdUniType, mkTupleCon, mkProcessorCon ) +import MatchProc ( matchProcessor) +#else +import Id ( eqId, getIdUniType, mkTupleCon, DataCon(..), Id ) +#endif {- Data Parallel Haskell -} +import Maybes ( Maybe(..) ) +import MatchCon ( matchConFamily ) +import MatchLit ( matchLiterals ) +import Outputable -- all for one "panic"... +import Pretty +import Util +\end{code} + +The function @match@ is basically the same as in the Wadler chapter, +except it is monadised, to carry around the name supply, info about +annotations, etc. + +Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns: +\begin{enumerate} +\item +A list of $n$ variable names, those variables presumably bound to the +$n$ expressions being matched against the $n$ patterns. Using the +list of $n$ expressions as the first argument showed no benefit and +some inelegance. + +\item +The second argument, a list giving the ``equation info'' for each of +the $m$ equations: +\begin{itemize} +\item +the $n$ patterns for that equation, and +\item +a list of Core bindings [@(Id, PlainCoreExpr)@ pairs] to be ``stuck on +the front'' of the matching code, as in: +\begin{verbatim} +let +in +\end{verbatim} +\item +and finally: (ToDo: fill in) + +The right way to think about the ``after-match function'' is that it +is an embryonic @CoreExpr@ with a ``hole'' at the end for the +final ``else expression''. +\end{itemize} + +There is a type synonym, @EquationInfo@, defined in module @DsUtils@. + +An experiment with re-ordering this information about equations (in +particular, having the patterns available in column-major order) +showed no benefit. + +\item +A default expression---what to evaluate if the overall pattern-match +fails. This expression will (almost?) always be +a measly expression @CoVar@, unless we know it will only be used once +(as we do in @glue_success_exprs@). + +Leaving out this third argument to @match@ (and slamming in lots of +@CoVar "fail"@s) is a positively {\em bad} idea, because it makes it +impossible to share the default expressions. (Also, it stands no +chance of working in our post-upheaval world of @Locals@.) +\end{enumerate} +So, the full type signature: +\begin{code} +match :: [Id] -- Variables rep'ing the exprs we're matching with + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> [EquationInfo] -- Potentially shadowing equations above this one + -> DsM MatchResult -- Desugared result! +\end{code} + +Note: @match@ is often called via @matchWrapper@ (end of this module), +a function that does much of the house-keeping that goes with a call +to @match@. + +It is also worth mentioning the {\em typical} way a block of equations +is desugared with @match@. At each stage, it is the first column of +patterns that is examined. The steps carried out are roughly: +\begin{enumerate} +\item +Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add +bindings to the second component of the equation-info): +\begin{itemize} +\item +Remove the `as' patterns from column~1. +\item +Make all constructor patterns in column~1 into @ConPats@, notably +@ListPats@ and @TuplePats@. +\item +Handle any irrefutable (or ``twiddle'') @LazyPats@. +\end{itemize} +\item +Now {\em unmix} the equations into {\em blocks} [w/ local function +@unmix_eqns@], in which the equations in a block all have variable +patterns in column~1, or they all have constructor patterns in ... +(see ``the mixture rule'' in SLPJ). +\item +Call @matchUnmixedEqns@ on each block of equations; it will do the +appropriate thing for each kind of column-1 pattern, usually ending up +in a recursive call to @match@. +\end{enumerate} + +%************************************************************************ +%* * +%* match: empty rule * +%* * +%************************************************************************ +\subsection[Match-empty-rule]{The ``empty rule''} + +We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87) +than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). +And gluing the ``success expressions'' together isn't quite so pretty. + +\begin{code} +match [] eqns_info shadows + = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) -> + + -- If at this stage we find that at least one of the shadowing + -- equations is guaranteed not to fail, then warn of an overlapping pattern + if not (all shadow_can_fail shadows) then + dsShadowError cxt `thenDs` \ _ -> + returnDs match_result + else + returnDs match_result + + where + pin_eqns [EqnInfo [] match_result] = returnDs match_result + -- Last eqn... can't have pats ... + + pin_eqns (EqnInfo [] match_result1 : more_eqns) + = pin_eqns more_eqns `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 + + pin_eqns other_pat = panic "match: pin_eqns" + + shadow_can_fail :: EquationInfo -> Bool + + shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True + shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False + shadow_can_fail other = panic "match:shadow_can_fail" +\end{code} + +%************************************************************************ +%* * +%* match: non-empty rule * +%* * +%************************************************************************ +\subsection[Match-nonempty]{@match@ when non-empty: unmixing} + +This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@ +(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and +(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em +un}mixes the equations], producing a list of equation-info +blocks, each block having as its first column of patterns either all +constructors, or all variables (or similar beasts), etc. + +@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the +Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ +corresponds roughly to @matchVarCon@. + +\begin{code} +match vars@(v:vs) eqns_info shadows + = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> + mapDs (tidyEqnInfo v) shadows `thenDs` \ tidy_shadows -> + let + tidy_eqns_blks = unmix_eqns tidy_eqns_info + in + match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows + where + unmix_eqns [] = [] + unmix_eqns [eqn] = [ [eqn] ] + unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs) + = if ( (unfailablePat p1 && unfailablePat p2) + || (isConPat p1 && isConPat p2) + || (isLitPat p1 && isLitPat p2) ) then + eq1 `tack_onto` unmixed_rest + else + [ eq1 ] : unmixed_rest + where + unmixed_rest = unmix_eqns (eq2:eqs) + + x `tack_onto` xss = ( x : head xss) : tail xss + + ----------------------------------------------------------------------- + -- loop through the blocks: + -- subsequent blocks create a "fail expr" for the first one... + match_unmixed_eqn_blks :: [Id] + -> [ [EquationInfo] ] -- List of eqn BLOCKS + -> [EquationInfo] -- Shadows + -> DsM MatchResult + + match_unmixed_eqn_blks vars [] shadows = panic "match_unmixed_eqn_blks" + + match_unmixed_eqn_blks vars [eqn_blk] shadows = matchUnmixedEqns vars eqn_blk shadows + + match_unmixed_eqn_blks vars (eqn_blk:eqn_blks) shadows + = matchUnmixedEqns vars eqn_blk shadows `thenDs` \ match_result1 -> -- try to match with first blk + match_unmixed_eqn_blks vars eqn_blks shadows' `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 + where + shadows' = eqn_blk ++ shadows +\end{code} + +Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ +which will be scrutinised. This means: +\begin{itemize} +\item +Replace variable patterns @x@ (@x /= v@) with the pattern @_@, +together with the binding @x = v@. +\item +Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. +\item +Removing lazy (irrefutable) patterns (you don't want to know...). +\item +Converting explicit tuple- and list-pats into ordinary @ConPats@. +\end{itemize} + +The result of this tidying is that the column of patterns will include +{\em only}: +\begin{description} +\item[@WildPats@:] +The @VarPat@ information isn't needed any more after this. + +\item[@ConPats@:] +@ListPats@, @TuplePats@, etc., are all converted into @ConPats@. + +\item[@LitPats@ and @NPats@ (and @NPlusKPats@):] +@LitPats@/@NPats@/@NPlusKPats@ of ``known friendly types'' (Int, Char, +Float, Double, at least) are converted to unboxed form; e.g., +\tr{(NPat (IntLit i) _ _)} is converted to: +\begin{verbatim} +(ConPat I# _ _ [LitPat (IntPrimLit i) _]) +\end{verbatim} +\end{description} + +\begin{code} +tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo + -- DsM'd because of internal call to "match". + -- "tidy1" does the interesting stuff, looking at + -- one pattern and fiddling the list of bindings. +tidyEqnInfo v (EqnInfo (pat : pats) match_result) + = tidy1 v pat match_result `thenDs` \ (pat', match_result') -> + returnDs (EqnInfo (pat' : pats) match_result') + +tidy1 :: Id -- The Id being scrutinised + -> TypecheckedPat -- The pattern against which it is to be matched + -> MatchResult -- Current thing do do after matching + -> DsM (TypecheckedPat, -- Equivalent pattern + MatchResult) -- Augmented thing to do afterwards + -- The augmentation usually takes the form + -- of new bindings to be added to the front + +tidy1 v (VarPat var) match_result + = returnDs (WildPat (getIdUniType var), + mkCoLetsMatchResult extra_binds match_result) + where + extra_binds | v `eqId` var = [] + | otherwise = [CoNonRec var (CoVar v)] + +tidy1 v (AsPat var pat) match_result + = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result) + where + extra_binds | v `eqId` var = [] + | otherwise = [CoNonRec var (CoVar v)] + +tidy1 v (WildPat ty) match_result + = returnDs (WildPat ty, match_result) + +{- now, here we handle lazy patterns: + tidy1 v ~p bs = (v, v1 = case v of p -> v1 : + v2 = case v of p -> v2 : ... : bs ) + + where the v_i's are the binders in the pattern. + + ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? + + The case expr for v_i is just: match [v] [(p, [], \ x -> CoVar v_i)] any_expr +-} + +tidy1 v (LazyPat pat) match_result + = mkSelectorBinds [] pat l_to_l (CoVar v) `thenDs` \ sel_binds -> + returnDs (WildPat (getIdUniType v), + mkCoLetsMatchResult [CoNonRec b rhs | (b,rhs) <- sel_binds] match_result) + where + l_to_l = binders `zip` binders -- Boring + binders = collectTypedPatBinders pat + +-- re-express as (ConPat ...) [directly] + +tidy1 v (ConOpPat pat1 id pat2 ty) match_result + = returnDs (ConPat id ty [pat1, pat2], match_result) + +tidy1 v (ListPat ty pats) match_result + = returnDs (list_ConPat, match_result) + where + list_ty = mkListTy ty + list_ConPat + = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y]) + (ConPat nilDataCon list_ty []) + pats + +tidy1 v (TuplePat pats) match_result + = returnDs (tuple_ConPat, match_result) + where + arity = length pats + tuple_ConPat + = ConPat (mkTupleCon arity) + (mkTupleTy arity (map typeOfPat pats)) + pats + +#ifdef DPH +tidy1 v (ProcessorPat pats convs pat) match_result + = returnDs ((ProcessorPat pats convs pat), match_result) +{- +tidy1 v (ProcessorPat pats _ _ pat) match_result + = returnDs (processor_ConPat, match_result) + where + processor_ConPat + = ConPat (mkProcessorCon (length pats)) + (mkProcessorTy (map typeOfPat pats) (typeOfPat pat)) + (pats++[pat]) +-} +#endif {- Data Parallel Haskell -} + +-- deeply ugly mangling for some (common) NPats/LitPats + +-- LitPats: the desugarer only sees these at well-known types + +tidy1 v pat@(LitPat lit lit_ty) match_result + | isPrimType lit_ty + = returnDs (pat, match_result) + + | lit_ty == charTy + = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy], + match_result) + + | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat) + where + mk_char (CharLit c) = CharPrimLit c + +-- NPats: we *might* be able to replace these w/ a simpler form + +tidy1 v pat@(NPat lit lit_ty _) match_result + = returnDs (better_pat, match_result) + where + better_pat + | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] + | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] + | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] + | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] + | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] + | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + | otherwise = pat + + mk_int (IntLit i) = IntPrimLit i + mk_int l@(LitLitLit s _) = l + + mk_char (CharLit c)= CharPrimLit c + mk_char l@(LitLitLit s _) = l + + mk_word l@(LitLitLit s _) = l + + mk_addr l@(LitLitLit s _) = l + + mk_float (IntLit i) = FloatPrimLit (fromInteger i) +#if __GLASGOW_HASKELL__ <= 22 + mk_float (FracLit f)= FloatPrimLit (fromRational f) -- ToDo??? +#else + mk_float (FracLit f)= FloatPrimLit f +#endif + mk_float l@(LitLitLit s _) = l + + mk_double (IntLit i) = DoublePrimLit (fromInteger i) +#if __GLASGOW_HASKELL__ <= 22 + mk_double (FracLit f)= DoublePrimLit (fromRational f) -- ToDo??? +#else + mk_double (FracLit f)= DoublePrimLit f +#endif + mk_double l@(LitLitLit s _) = l + +{- OLD: and wrong! I don't think we can do anything + useful with n+k patterns, so drop through to default case + +tidy1 v pat@(NPlusKPat n k lit_ty and so on) match_result + = returnDs (NPlusKPat v k lit_ty and so on, + (if v `eqId` n then id else (mkCoLet (CoNonRec n (CoVar v)))) . match_result) +-} + +-- and everything else goes through unchanged... + +tidy1 v non_interesting_pat match_result + = returnDs (non_interesting_pat, match_result) +\end{code} + +PREVIOUS matchTwiddled STUFF: + +Now we get to the only interesting part; note: there are choices for +translation [from Simon's notes]; translation~1: +\begin{verbatim} +deTwiddle [s,t] e +\end{verbatim} +returns +\begin{verbatim} +[ w = e, + s = case w of [s,t] -> s + t = case w of [s,t] -> t +] +\end{verbatim} + +Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple +evaluation of \tr{e}. An alternative translation (No.~2): +\begin{verbatim} +[ w = case e of [s,t] -> (s,t) + s = case w of (s,t) -> s + t = case w of (s,t) -> t +] +\end{verbatim} + +%************************************************************************ +%* * +\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} +%* * +%************************************************************************ + +We might be able to optimise unmixing when confronted by +only-one-constructor-possible, of which tuples are the most notable +examples. Consider: +\begin{verbatim} +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +f j ... = ... +\end{verbatim} +This definition would normally be unmixed into four equation blocks, +one per equation. But it could be unmixed into just one equation +block, because if the one equation matches (on the first column), +the others certainly will. + +You have to be careful, though; the example +\begin{verbatim} +f j ... = ... +------------------- +f (a,b,c) ... = ... +f d ... (e:f) = ... +f (g,h,i) ... = ... +\end{verbatim} +{\em must} be broken into two blocks at the line shown; otherwise, you +are forcing unnecessary evaluation. In any case, the top-left pattern +always gives the cue. You could then unmix blocks into groups of... +\begin{description} +\item[all variables:] +As it is now. +\item[constructors or variables (mixed):] +Need to make sure the right names get bound for the variable patterns. +\item[literals or variables (mixed):] +Presumably just a variant on the constructor case (as it is now). +\end{description} + +%************************************************************************ +%* * +%* match on an unmixed block: the real business * +%* * +%************************************************************************ +\subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business} + +The function @matchUnmixedEqns@ is where the matching stuff sets to +work a block of equations, to which the mixture rule has been applied. +Its arguments and results are the same as for the ``top-level'' @match@. + +\begin{code} +matchUnmixedEqns :: [Id] + -> [EquationInfo] + -> [EquationInfo] -- Shadows + -> DsM MatchResult + +matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names" + +matchUnmixedEqns all_vars@(var:vars) eqns_info shadows + | unfailablePats column_1_pats -- Could check just one; we know they've been tidied, unmixed; + -- this way is (arguably) a sanity-check + = -- Real true variables, just like in matchVar, SLPJ p 94 + match vars remaining_eqns_info remaining_shadows + +#ifdef DPH + | patsAreAllProcessor column_1_pats + = -- ToDo: maybe check just one... + matchProcessor all_vars eqns_info +#endif {- Data Parallel Haskell -} + + | patsAreAllCons column_1_pats -- ToDo: maybe check just one... + = matchConFamily all_vars eqns_info shadows + + | patsAreAllLits column_1_pats -- ToDo: maybe check just one... + = -- see notes in MatchLiteral + -- not worried about the same literal more than once in a column + -- (ToDo: sort this out later) + matchLiterals all_vars eqns_info shadows + + where + column_1_pats = [pat | EqnInfo (pat:_) _ <- eqns_info] + remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info] + remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows, + irrefutablePat pat ] + -- Discard shadows which can be refuted, since they don't shadow + -- a variable +\end{code} + +%************************************************************************ +%* * +%* matchWrapper: a convenient way to call @match@ * +%* * +%************************************************************************ +\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} + +Calls to @match@ often involve similar (non-trivial) work; that work +is collected here, in @matchWrapper@. This function takes as +arguments: +\begin{itemize} +\item +Typchecked @Matches@ (of a function definition, or a case or lambda +expression)---the main input; +\item +An error message to be inserted into any (runtime) pattern-matching +failure messages. +\end{itemize} + +As results, @matchWrapper@ produces: +\begin{itemize} +\item +A list of variables (@Locals@) that the caller must ``promise'' to +bind to appropriate values; and +\item +a @PlainCoreExpr@, the desugared output (main result). +\end{itemize} + +The main actions of @matchWrapper@ include: +\begin{enumerate} +\item +Flatten the @[TypecheckedMatch]@ into a suitable list of +@EquationInfo@s. +\item +Create as many new variables as there are patterns in a pattern-list +(in any one of the @EquationInfo@s). +\item +Create a suitable ``if it fails'' expression---a call to @error@ using +the error-string input; the {\em type} of this fail value can be found +by examining one of the RHS expressions in one of the @EquationInfo@s. +\item +Call @match@ with all of this information! +\end{enumerate} + +\begin{code} +matchWrapper :: DsMatchKind -- For shadowing warning messages + -> [TypecheckedMatch] -- Matches being desugared + -> String -- Error message if the match fails + -> DsM ([Id], PlainCoreExpr) -- Results + +-- a special case for the common ...: +-- just one Match +-- lots of (all?) unfailable pats +-- e.g., +-- f x y z = .... + +matchWrapper kind [(PatMatch (VarPat var) match)] error_string + = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> + returnDs (var:vars, core_expr) + +matchWrapper kind [(PatMatch (WildPat ty) match)] error_string + = newSysLocalDs ty `thenDs` \ var -> + matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> + returnDs (var:vars, core_expr) + +matchWrapper kind [(GRHSMatch + (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string + = dsBinds binds `thenDs` \ core_binds -> + dsExpr expr `thenDs` \ core_expr -> + returnDs ([], mkCoLetsAny core_binds core_expr) + +---------------------------------------------------------------------------- +-- and all the rest... (general case) + +matchWrapper kind matches error_string + = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) -> + + selectMatchVars arg_pats `thenDs` \ new_vars -> + match new_vars eqns_info [] `thenDs` \ match_result -> + + getSrcLocDs `thenDs` \ (src_file, src_line) -> + newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String + let + src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line + fail_expr = mkErrorCoApp result_ty str_var (src_loc_str++": "++error_string) + in + extractMatchResult match_result fail_expr `thenDs` \ result_expr -> + returnDs (new_vars, result_expr) +\end{code} + +%************************************************************************ +%* * +\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} +%* * +%************************************************************************ + +@mkSimpleMatch@ is a wrapper for @match@ which deals with the +situation where we want to match a single expression against a single +pattern. It returns an expression. + +\begin{code} +matchSimply :: PlainCoreExpr -- Scrutinee + -> TypecheckedPat -- Pattern it should match + -> UniType -- Type of result + -> PlainCoreExpr -- Return this if it matches + -> PlainCoreExpr -- Return this if it does + -> DsM PlainCoreExpr + +matchSimply (CoVar var) pat result_ty result_expr fail_expr + = match [var] [eqn_info] [] `thenDs` \ match_result -> + extractMatchResult match_result fail_expr + where + eqn_info = EqnInfo [pat] initial_match_result + initial_match_result = MatchResult CantFail + result_ty + (\ ignore -> result_expr) + NoMatchContext + +matchSimply scrut_expr pat result_ty result_expr msg + = newSysLocalDs (typeOfPat pat) `thenDs` \ scrut_var -> + matchSimply (CoVar scrut_var) pat result_ty result_expr msg `thenDs` \ expr -> + returnDs (CoLet (CoNonRec scrut_var scrut_expr) expr) + + +extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr + = returnDs (match_fn (error "It can't fail!")) + +extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr + = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> + returnDs (CoLet (fail_bind_fn fail_expr) (match_fn if_it_fails)) +\end{code} + +%************************************************************************ +%* * +%* flattenMatches : create a list of EquationInfo * +%* * +%************************************************************************ +\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@} + +This is actually local to @matchWrapper@. + +\begin{code} +flattenMatches + :: DsMatchKind + -> [TypecheckedMatch] + -> DsM [EquationInfo] + +flattenMatches kind [] = returnDs [] + +flattenMatches kind (match : matches) + = flatten_match [] match `thenDs` \ eqn_info -> + flattenMatches kind matches `thenDs` \ eqn_infos -> + returnDs (eqn_info : eqn_infos) + where + flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far + -> TypecheckedMatch + -> DsM EquationInfo + + flatten_match pats_so_far (PatMatch pat match) + = flatten_match (pat:pats_so_far) match + + flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) + = dsBinds binds `thenDs` \ core_binds -> + dsGRHSs ty kind pats grhss `thenDs` \ match_result -> + returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) + where + pats = reverse pats_so_far -- They've accumulated in reverse order +\end{code} diff --git a/ghc/compiler/deSugar/MatchCon.hi b/ghc/compiler/deSugar/MatchCon.hi new file mode 100644 index 0000000..bb10bf1 --- /dev/null +++ b/ghc/compiler/deSugar/MatchCon.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface MatchCon where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext) +import DsUtils(EquationInfo, MatchResult) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniqFM(UniqFM) +matchConFamily :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 122222222 _N_ _S_ "SSL" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs new file mode 100644 index 0000000..80b16ea --- /dev/null +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -0,0 +1,150 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[MatchCon]{Pattern-matching constructors} + +\begin{code} +#include "HsVersions.h" + +module MatchCon ( + matchConFamily +) where + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsUniType ( mkTyVarTy, splitType, TyVar, TyVarTemplate, + getTyConDataCons, + instantiateTauTy, TyCon, Class, UniType, + TauType(..), InstTyEnv(..) + IF_ATTACK_PRAGMAS(COMMA instantiateTy) + ) +import DsUtils +import Id ( eqId, getInstantiatedDataConSig, + getIdUniType, isDataCon, DataCon(..) + ) +import Maybes ( Maybe(..) ) +import Match ( match ) +import Util +\end{code} + +\subsection[matchConFamily]{Making alternatives for a constructor family} + +We are confronted with the first column of patterns in a set of +equations, all beginning with constructors from one ``family'' (e.g., +@[]@ and @:@ make up the @List@ ``family''). We want to generate the +alternatives for a @CoCase@ expression. There are several choices: +\begin{enumerate} +\item +Generate an alternative for every constructor in the family, whether +they are used in this set of equations or not; this is what the Wadler +chapter does. +\begin{description} +\item[Advantages:] +(a)~Simple. (b)~It may also be that large sparsely-used constructor families are mainly +handled by the code for literals. +\item[Disadvantages:] +(a)~Not practical for large sparsely-used constructor families, e.g., the +ASCII character set. (b)~Have to look up (in the TDE environment) a +list of what constructors make up the whole family. So far, this is +the only part of desugaring that needs information from the environments. +\end{description} + +\item +Generate an alternative for each constructor used, then add a default +alternative in case some constructors in the family weren't used. +\begin{description} +\item[Advantages:] +(a)~Alternatives aren't generated for unused constructors. (b)~The +STG is quite happy with defaults. (c)~No lookup in an environment needed. +\item[Disadvantages:] +(a)~A spurious default alternative may be generated. +\end{description} + +\item +``Do it right:'' generate an alternative for each constructor used, +and add a default alternative if all constructors in the family +weren't used. +\begin{description} +\item[Advantages:] +(a)~You will get cases with only one alternative (and no default), +which should be amenable to optimisation. Tuples are a common example. +\item[Disadvantages:] +(b)~Have to look up constructor families in TDE (as above). +\end{description} +\end{enumerate} + +We are implementing the ``do-it-right'' option for now. +The arguments to @matchConFamily@ are the same as to @match@; the extra +@Int@ returned is the number of constructors in the family. + +The function @matchConFamily@ is concerned with this +have-we-used-all-the-constructors question; the local function +@match_cons_used@ does all the real work. +\begin{code} +matchConFamily :: [Id] + -> [EquationInfo] + -> [EquationInfo] -- Shadows + -> DsM MatchResult + +matchConFamily (var:vars) eqns_info shadows + = match_cons_used vars eqns_info shadows `thenDs` \ alts -> + mkCoAlgCaseMatchResult var alts +\end{code} + +And here is the local function that does all the work. It is more-or-less the +@matchCon@/@matchClause@ functions on page~94 in Wadler's chapter in SLPJ. +\begin{code} +match_cons_used _ [{- no more eqns -}] _ = returnDs [] + +match_cons_used vars eqns_info@(EqnInfo (ConPat data_con _ arg_pats : ps1) _ : eqns) shadows + = ASSERT(isDataCon data_con) + let + (eqns_for_this_con, eqns_not_for_this_con) = splitByCon eqns_info + (shadows_for_this_con, shadows_not_for_this_con) = splitByCon shadows + in + -- Go ahead and do the recursive call to make the alts + -- for the other ConPats in this con family... + match_cons_used vars eqns_not_for_this_con shadows_not_for_this_con `thenDs` \ rest_of_alts -> + + -- Make new vars for the con arguments; avoid new locals where possible + selectMatchVars arg_pats `thenDs` \ new_vars -> + + -- Now do the business to make the alt for _this_ ConPat ... + match (new_vars++vars) + (map shift_con_pat eqns_for_this_con) + (map shift_con_pat shadows_for_this_con) `thenDs` \ match_result -> + + returnDs ( + (data_con, new_vars, match_result) + : rest_of_alts + ) + where + splitByCon :: [EquationInfo] -> ([EquationInfo], [EquationInfo]) + splitByCon [] = ([],[]) + splitByCon (info@(EqnInfo (pat : _) _) : rest) + = case pat of + ConPat n _ _ | n `eqId` data_con -> (info:rest_yes, rest_no) + WildPat _ -> (info:rest_yes, info:rest_no) + -- WildPats will be in the shadows only, + -- and they go into both groups + other_pat -> (rest_yes, info:rest_no) + where + (rest_yes, rest_no) = splitByCon rest + + shift_con_pat :: EquationInfo -> EquationInfo + shift_con_pat (EqnInfo (ConPat _ _ pats': pats) match_result) + = EqnInfo (pats' ++ pats) match_result + shift_con_pat (EqnInfo (WildPat _: pats) match_result) -- Will only happen in shadow + = EqnInfo ([WildPat (typeOfPat arg_pat) | arg_pat <- arg_pats] ++ pats) match_result + shift_con_pat other = panic "matchConFamily:match_cons_used:shift_con_pat" +\end{code} + +Note on @shift_con_pats@ just above: does what the list comprehension in +@matchClause@ (SLPJ, p.~94) does, except things are trickier in real +life. Works for @ConPats@, and we want it to fail catastrophically +for anything else (which a list comprehension wouldn't). +Cf.~@shift_lit_pats@ in @MatchLits@. diff --git a/ghc/compiler/deSugar/MatchLit.hi b/ghc/compiler/deSugar/MatchLit.hi new file mode 100644 index 0000000..9f211d9 --- /dev/null +++ b/ghc/compiler/deSugar/MatchLit.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface MatchLit where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreExpr) +import DsMonad(DsMatchContext) +import DsUtils(EquationInfo, MatchResult) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import UniqFM(UniqFM) +matchLiterals :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext) + {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "SSL" _N_ _N_ #-} + diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs new file mode 100644 index 0000000..31d8be7 --- /dev/null +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -0,0 +1,205 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[MatchLit]{Pattern-matching literal and n+k patterns} + +\begin{code} +#include "HsVersions.h" + +module MatchLit ( + matchLiterals + ) where + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsUniType ( isPrimType, getUniDataTyCon, kindFromType ) +import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) +import DsExpr ( dsExpr ) +import DsUtils +import Maybes ( Maybe(..), catMaybes ) +import Match ( match ) +import Id ( getIdUniType, eqId ) +import Util +\end{code} + +\begin{code} +matchLiterals :: [Id] + -> [EquationInfo] + -> [EquationInfo] -- Shadows + -> DsM MatchResult +\end{code} + +This first one is a {\em special case} where the literal patterns are +unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@). We +want to avoid using the ``equality'' stuff provided by the +typechecker, and do a real ``case'' instead. In that sense, the code +is much like @matchConFamily@, which uses @match_cons_used@ to create +the alts---here we use @match_prims_used@. + +\begin{code} +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps1) _ : eqns) shadows + = -- GENERATE THE ALTS + match_prims_used vars eqns_info shadows `thenDs` \ prim_alts -> + + -- MAKE THE PRIMITIVE CASE + mkCoPrimCaseMatchResult var prim_alts + where + match_prims_used _ [{-no more eqns-}] _ = returnDs [] + + match_prims_used vars eqns_info@(EqnInfo ((LitPat literal _):ps1) _ : eqns) shadows + = let + (shifted_eqns_for_this_lit, eqns_not_for_this_lit) + = partitionEqnsByLit Nothing literal eqns_info + (shifted_shadows_for_this_lit, shadows_not_for_this_lit) + = partitionEqnsByLit Nothing literal shadows + in + -- recursive call to make other alts... + match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ rest_of_alts -> + + -- (prim pats have no args; no selectMatchVars as in match_cons_used) + -- now do the business to make the alt for _this_ LitPat ... + match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ match_result -> + returnDs ( + (mk_core_lit literal, match_result) + : rest_of_alts + ) + where + mk_core_lit :: Literal -> BasicLit + + mk_core_lit (IntPrimLit i) = mkMachInt i + mk_core_lit (CharPrimLit c) = MachChar c + mk_core_lit (StringPrimLit s) = MachStr s + mk_core_lit (FloatPrimLit f) = MachFloat f + mk_core_lit (DoublePrimLit d) = MachDouble d + mk_core_lit (LitLitLit s t) = ASSERT(isPrimType t) + MachLitLit s (kindFromType t) + mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled" +\end{code} + +\begin{code} +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows + = let + (shifted_eqns_for_this_lit, eqns_not_for_this_lit) + = partitionEqnsByLit Nothing literal eqns_info + (shifted_shadows_for_this_lit, shadows_not_for_this_lit) + = partitionEqnsByLit Nothing literal shadows + in + dsExpr (App eq_chk (Var var)) `thenDs` \ pred_expr -> + match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> + mkGuardedMatchResult pred_expr inner_match_result `thenDs` \ match_result1 -> + + if (null eqns_not_for_this_lit) + then + returnDs match_result1 + else + matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 +\end{code} + +For an n+k pattern, we use the various magic expressions we've been given. +We generate: +\begin{verbatim} + if ge var lit then + let n = sub var lit + in + else + +\end{verbatim} + +\begin{code} +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty from_lit ge sub):ps1) _ : eqns) shadows + = let + (shifted_eqns_for_this_lit, eqns_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k eqns_info + (shifted_shadows_for_this_lit, shadows_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k shadows + in + match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> + + dsExpr from_lit `thenDs` \ core_lit -> + dsExpr (App ge (Var var)) `thenDs` \ var_ge -> + dsExpr (App sub (Var var)) `thenDs` \ var_sub -> + mkCoAppDs var_ge core_lit `thenDs` \ var_ge_lit -> + mkCoAppDs var_sub core_lit `thenDs` \ var_sub_lit -> + + mkGuardedMatchResult + var_ge_lit + (mkCoLetsMatchResult [CoNonRec master_n var_sub_lit] inner_match_result) + `thenDs` \ match_result1 -> + + if (null eqns_not_for_this_lit) + then + returnDs match_result1 + else + matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 +\end{code} + +Given a blob of LitPats/NPats/NPlusKPats, we want to split them into those +that are ``same''/different as one we are looking at. We need to know +whether we're looking at a LitPat/NPat or NPlusKPat (initial Bool arg is +@True@ for the latter), and what literal we're after. + +\begin{code} +partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v + -- is the "master" variable; + -- Nothing for NPats and LitPats + -> Literal + -> [EquationInfo] + -> ([EquationInfo], -- These ones are for this lit, AND + -- they've been "shifted" by stripping + -- off the first pattern + [EquationInfo] -- These are not for this lit; they + -- are exactly as fed in. + ) + +partitionEqnsByLit want_NPlusK lit eqns + = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) + (unzip (map (partition_eqn want_NPlusK lit) eqns)) + where + partition_eqn :: Maybe Id -> Literal -> EquationInfo -> + (Maybe EquationInfo, Maybe EquationInfo) + + partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result) + | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) + -- NB the pattern is stripped off thhe EquationInfo + + partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) + | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) + -- NB the pattern is stripped off thhe EquationInfo + + partition_eqn (Just master_n) lit (EqnInfo (NPlusKPat n k _ _ _ _ : remaining_pats) match_result) + | lit `eq_lit` k = (Just (EqnInfo remaining_pats new_match_result), Nothing) + -- NB the pattern is stripped off thhe EquationInfo + where + new_match_result = if master_n `eqId` n then + match_result + else + mkCoLetsMatchResult [CoNonRec n (CoVar master_n)] match_result + + -- Wild-card patterns, which will only show up in the shadows, go into both groups + partition_eqn wantNPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) + = (Just (EqnInfo remaining_pats match_result), Just eqn) + + -- Default case; not for this pattern + partition_eqn wantNPlusK lit eqn = (Nothing, Just eqn) + +-- ToDo: meditate about this equality business... + +eq_lit (IntLit i1) (IntLit i2) = i1 == i2 +eq_lit (FracLit f1) (FracLit f2) = f1 == f2 + +eq_lit (IntPrimLit i1) (IntPrimLit i2) = i1 == i2 +eq_lit (FloatPrimLit f1) (FloatPrimLit f2) = f1 == f2 +eq_lit (DoublePrimLit d1) (DoublePrimLit d2) = d1 == d2 +eq_lit (CharLit c1) (CharLit c2) = c1 == c2 +eq_lit (CharPrimLit c1) (CharPrimLit c2) = c1 == c2 +eq_lit (StringLit s1) (StringLit s2) = s1 == s2 +eq_lit (StringPrimLit s1) (StringPrimLit s2) = s1 == s2 +eq_lit (LitLitLit s1 _) (LitLitLit s2 _) = s1 == s2 -- ToDo: ??? (dubious) +eq_lit other1 other2 = panic "matchLiterals:eq_lit" +\end{code} diff --git a/ghc/compiler/deSugar/MatchProc.lhs b/ghc/compiler/deSugar/MatchProc.lhs new file mode 100644 index 0000000..fb8a5cb --- /dev/null +++ b/ghc/compiler/deSugar/MatchProc.lhs @@ -0,0 +1,98 @@ +% Filename: %M% +% Version : %I% +% Date : %G% +% +\section[MatchProcessors]{Pattern-matching processors} +\begin{code} +module MatchProc ( + matchProcessor +) where + +#include "HsVersions.h" + +import AbsSyn -- the stuff being desugared +import PlainCore -- the output of desugaring; + -- importing this module also gets all the + -- CoreSyn utility functions +import DsMonad -- the monadery used in the desugarer + +import AbsUniType ( mkTyVarTy, splitType, mkProcessorTyCon, + TyVar, TyCon, Class, UniType, + TauType(..) + ) +import DsUtils ( EquationInfo(..), selectMatchVars ) +import Id ( getDataConFamily, getDataConTyCon, + getIdUniType, mkProcessorCon + ) +import ListSetOps ( minusList ) +import Maybes ( Maybe(..) ) +import Match ( match ) +import Util +import DsExpr ( dsExpr) +\end{code} + +The matching of processors is based upon that of constructors. Given the +pattern : +\begin{verbatim} + (|x1,..xn;y|) +\end{verbatim} + +The pattern matching compiler converts the above into : +\begin{verbatim} + case x of + (|u1,..un;uy|) -> let x1 = fromDomain u_1 of + .... + let xn = fromDomain u_n of + let y = fromDomain uy of + PATTERN MATCH REST +\end{verbatim} + +\begin{code} +matchProcessor :: [Id] + -> [EquationInfo] + -> PlainCoreExpr + -> DsM PlainCoreExpr + +matchProcessor (v:vs) eqnInfo ifFail + = selectMatchVars [pat] `thenDs` (\ [var] -> + selectMatchVars pats `thenDs` (\ vars -> + match (var:vs) + [(pat:ps,after_fun)] + ifFail `thenDs` (\ body -> + create_lets vars pats convs body ifFail `thenDs` (\ rhs -> + returnDs ( + CoCase + (CoVar v) + (CoAlgAlts + [((mkProcessorCon podSize),vars++[var], rhs)] + CoNoDefault)) + )))) + where + podSize = (length pats) + -- Sanity checking pattern match. Product type of processors ensures + -- there can be only one result if the equations are properly unmixed. + ((ProcessorPat pats convs pat):ps,after_fun) + | length eqnInfo == 1 = head eqnInfo + | otherwise = panic "matchProcessor more than one" + +\end{code} + +\begin{code} +create_lets::[Id] -> + [TypecheckedPat] -> + [TypecheckedExpr] -> + PlainCoreExpr -> + PlainCoreExpr -> + (DsM PlainCoreExpr) + +create_lets [] _ _ body _ = returnDs (body) +create_lets (v:vs) (p:ps) (c:cs) body ifFail + = selectMatchVars [p] `thenDs` (\ var -> + create_lets vs ps cs body ifFail `thenDs` (\ after -> + dsExpr c `thenDs` (\ c' -> + match var + [([p], \x -> after)] + ifFail `thenDs` (\ exp -> + returnDs ( CoApp (CoLam var exp) (CoApp c' (CoVar v))) )))) +\end{code} + diff --git a/ghc/compiler/deSugar/intro.lit b/ghc/compiler/deSugar/intro.lit new file mode 100644 index 0000000..6ae7747 --- /dev/null +++ b/ghc/compiler/deSugar/intro.lit @@ -0,0 +1,24 @@ +\section[Desugar_intro]{Introduction} + +This pass of the \Haskell{} compiler converts a typechecked program in +@AbsSyntax@ form into a list of @CoreBinding@s, a much simpler form +more suitable for subsequent passes. The basic tasks in this +``desugaring'' are: +\begin{enumerate} +\item +Compile pattern-matching into equivalent code, mainly case-expressions. + +\item +Convert list comprehensions into equivalent code. + +\item +Make explicit all of the implicit activity due to overloading, +dictionaries, etc., etc. +\end{enumerate} + +For the basic desugaring process, we assume familiarity with Phil +Wadler's chapter~5 in SLPJ. The code here will be recognizable by the +avid reader of that chapter. The main difference you will see is that +this code uses a simple monad to pass around the name supply; if +you've read much of this compiler's code, the idioms used will be +grievously familiar. diff --git a/ghc/compiler/deSugar/root.lit b/ghc/compiler/deSugar/root.lit new file mode 100644 index 0000000..51c35f5 --- /dev/null +++ b/ghc/compiler/deSugar/root.lit @@ -0,0 +1,53 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate,a4wide]{article} +\begin{document} +\title{Desugaring \Haskell{}} +\author{The AQUA team} +\date{February 1994} +\maketitle +\tableofcontents +\end{onlystandalone} + +\begin{onlypartofdoc} +\section[De_sugar_er]{Desugaring} +\downsection +\end{onlypartofdoc} + +\input{intro.lit} + +\input{Desugar.lhs} + +\section[Desugar_match]{@match@: compiling out pattern-matching} +\downsection +\input{Match.lhs} +\input{MatchCon.lhs} +\input{MatchLit.lhs} +\input{MatchProc.lhs} +\upsection + +\section[Desugar_absSyntax]{Mangling the abstract syntax} + +Roughly speaking, a function with a name of the form +\tr{ds} is the de-sugar-er for the nonterminal +\pl{} in module @AbsSyntaxTypes@. +\downsection +\input{DsBinds.lhs} +\input{DsExpr.lhs} +\input{DsGRHSs.lhs} +\input{DsListComp.lhs} +\input{DsParZF.lhs} +\upsection + +\section[Desugar_utilities]{Utilities and constants for desugaring} +\downsection +\input{DsMonad.lhs} +\input{DsUtils.lhs} +\upsection + +\begin{onlypartofdoc} +\upsection +\end{onlypartofdoc} +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/deforest/Core2Def.hi b/ghc/compiler/deforest/Core2Def.hi new file mode 100644 index 0000000..a523d9d --- /dev/null +++ b/ghc/compiler/deforest/Core2Def.hi @@ -0,0 +1,22 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Core2Def where +import BinderInfo(BinderInfo) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreBinding, CoreExpr) +import DefSyn(DefBindee, DefProgram(..)) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreProgram(..)) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data DefBindee {-# GHC_PRAGMA DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee) #-} +type DefProgram = [CoreBinding Id DefBindee] +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreProgram = [CoreBinding Id Id] +c2d :: UniqFM (CoreExpr Id DefBindee) -> CoreExpr (Id, BinderInfo) Id -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> [CoreBinding Id DefBindee] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ #-} + diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs new file mode 100644 index 0000000..1ca4e45 --- /dev/null +++ b/ghc/compiler/deforest/Core2Def.lhs @@ -0,0 +1,147 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Core2Def]{Translate the CoreProgram into a DefProgram} + +>#include "HsVersions.h" +> +> module Core2Def ( +> core2def, c2d, +> +> PlainCoreProgram(..), DefProgram(..), +> CoreBinding, Id, DefBindee ) where +> +> import DefSyn +>#ifdef __HBC__ +> import Trace +>#endif + +> import CoreSyn +> import IdEnv +> import PlainCore +> import TaggedCore +> import BinderInfo -- ( BinderInfo(..), isFun, isDupDanger ) +> import CmdLineOpts ( switchIsOn, SwitchResult, SimplifierSwitch ) +> import OccurAnal ( occurAnalyseBinds ) +> import SimplEnv ( SwitchChecker(..) ) +> import Util +> import Pretty +> import Outputable + +This module translates the PlainCoreProgram into a DefCoreProgram, +which includes non-atomic right-hand sides. The decisions about which +expressions to inline are left to the substitution analyser, which we +run beforehand. + +Current thinking: + +1. Inline all non-recursive non-top-level lets that occur only + once (including inside lambdas, hoping full laziness + will sort things out later). + +2. We don't inline top-level lets that occur only once, because these + might not be pulled out again by the let-floater, due to non- + garbage collection of CAFs. + +2.1. Also, what about these lit things that occur at the top level, + and are usually marked as macros? + +3. No recusrive functions are unfolded. + +ToDo: +4. Lambdas and case alternatives that bind a variable that occurs + multiple times are transformed: + \x -> ..x..x.. ===> \x -> let x' = x in ..x'..x'.. + + +> core2def :: (GlobalSwitch -> SwitchResult) -> PlainCoreProgram -> DefProgram +> core2def sw prog = +> map coreBinding2def tagged_program +> where +> tagged_program = occurAnalyseBinds prog switch_is_on (const False) +> switch_is_on = switchIsOn sw + + +> coreBinding2def :: SimplifiableCoreBinding -> DefBinding +> coreBinding2def (CoNonRec (v,_) e) = CoNonRec v (c2d nullIdEnv e) +> coreBinding2def (CoRec bs) = CoRec (map recBind2def bs) +> where recBind2def ((v,_),e) = (v, c2d nullIdEnv e) + + +> coreAtom2def :: IdEnv DefExpr -> PlainCoreAtom -> DefAtom +> coreAtom2def p (CoVarAtom v) = CoVarAtom (DefArgExpr (lookup p v)) +> coreAtom2def p (CoLitAtom l) = CoVarAtom (DefArgExpr (CoLit l)) + +> isTrivial (CoCon c [] []) = True +> isTrivial (CoVar v) = True +> isTrivial (CoLit l) = True +> isTrivial _ = False + +> c2d :: IdEnv DefExpr -> SimplifiableCoreExpr -> DefExpr +> c2d p e = case e of +> +> CoVar v -> lookup p v +> +> CoLit l -> CoLit l +> +> CoCon c ts es -> CoCon c ts (map (coreAtom2def p) es) +> +> CoPrim op ts es -> CoPrim op ts (map (coreAtom2def p) es) +> +> CoLam vs e -> CoLam (map fst vs) (c2d p e) +> +> CoTyLam alpha e -> CoTyLam alpha (c2d p e) +> +> CoApp e v -> CoApp (c2d p e) (coreAtom2def p v) +> +> CoTyApp e t -> CoTyApp (c2d p e) t +> +> CoCase e ps -> CoCase (c2d p e) (coreCaseAlts2def p ps) +> +> CoLet (CoNonRec (v,ManyOcc _) e) e' +> | isTrivial e -> c2d (addOneToIdEnv p v (c2d p e)) e' +> | otherwise -> +> trace ("Not inlining ManyOcc " ++ ppShow 80 (ppr PprDebug v)) ( +> CoLet (CoNonRec v (c2d p e)) (c2d p e')) +> +> CoLet (CoNonRec (v,DeadCode) e) e' -> +> panic "Core2Def(c2d): oops, unexpected DeadCode" +> +> CoLet (CoNonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e' +> | isTrivial e -> inline_it +> | isDupDanger dup_danger -> +> trace ("Not inlining DupDanger " ++ ppShow 80 (ppr PprDebug v))( +> CoLet (CoNonRec v (c2d p e)) (c2d p e')) +> | isFun fun_or_arg -> +> panic "Core2Def(c2d): oops, unexpected Macro" +> | otherwise -> inline_it +> where inline_it = c2d (addOneToIdEnv p v (c2d p e)) e' +> +> CoLet (CoRec bs) e -> CoLet (CoRec (map recBind2def bs)) (c2d p e) +> where recBind2def ((v,_),e) = (v, c2d p e) +> +> CoSCC l e -> CoSCC l (c2d p e) + + +> coreCaseAlts2def +> :: IdEnv DefExpr +> -> SimplifiableCoreCaseAlternatives +> -> DefCaseAlternatives +> +> coreCaseAlts2def p alts = case alts of +> CoAlgAlts as def -> CoAlgAlts (map algAlt2def as) (defAlt2def def) +> CoPrimAlts as def -> CoPrimAlts (map primAlt2def as) (defAlt2def def) +> +> where +> +> algAlt2def (c, vs, e) = (c, (map fst vs), c2d p e) +> primAlt2def (l, e) = (l, c2d p e) + +> defAlt2def CoNoDefault = CoNoDefault +> defAlt2def (CoBindDefault (v,_) e) = CoBindDefault v (c2d p e) + + +> lookup :: IdEnv DefExpr -> Id -> DefExpr +> lookup p v = case lookupIdEnv p v of +> Nothing -> CoVar (DefArgVar v) +> Just e -> e diff --git a/ghc/compiler/deforest/Cyclic.hi b/ghc/compiler/deforest/Cyclic.hi new file mode 100644 index 0000000..a0c39ff --- /dev/null +++ b/ghc/compiler/deforest/Cyclic.hi @@ -0,0 +1,11 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Cyclic where +import CoreSyn(CoreExpr) +import DefSyn(DefBindee) +import Id(Id) +import SplitUniq(SplitUniqSupply) +fixupFreeVars :: [Id] -> Id -> CoreExpr Id DefBindee -> ((Id, CoreExpr Id DefBindee), [(Id, CoreExpr Id DefBindee)]) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLS" _N_ _N_ #-} +mkLoops :: CoreExpr Id DefBindee -> SplitUniqSupply -> ([(Id, CoreExpr Id DefBindee)], CoreExpr Id DefBindee) + {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CoreExpr Id DefBindee) (u1 :: SplitUniqSupply) -> _APP_ _TYAPP_ error { (SplitUniqSupply -> ([(Id, CoreExpr Id DefBindee)], CoreExpr Id DefBindee)) } [ _NOREP_S_ "mkLoops", u1 ] _N_ #-} + diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs new file mode 100644 index 0000000..318921c --- /dev/null +++ b/ghc/compiler/deforest/Cyclic.lhs @@ -0,0 +1,411 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Cyclic]{Knot tying} + +>#include "HsVersions.h" +> +> module Cyclic ( +> mkLoops, fixupFreeVars +> ) where + +> import DefSyn +> import PlainCore +> import DefUtils +> import Def2Core ( d2c, defPanic ) +>#ifdef __HBC__ +> import Trace +>#endif + +> import AbsUniType ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy, +> TyVarTemplate +> ) +> import Digraph ( dfs ) +> import Id ( getIdUniType, toplevelishId, updateIdType, +> getIdInfo, replaceIdInfo, eqId, Id +> ) +> import IdInfo +> import Maybes ( Maybe(..) ) +> import Outputable +> import Pretty +> import SplitUniq +> import Util + +----------------------------------------------------------------------------- +A more efficient representation for lists that are extended multiple +times, but only examined once. + +> type FList a = [a] -> [a] +> append = (.) +> singleton x = (x:) +> cons x xs = \ys -> x:(xs ys) +> list x = (x++) +> emptylist = id + +----------------------------------------------------------------------------- +Monad for the knot-tier. + +> type Lbl a = SUniqSM ( +> [(Id)], -- loops used +> [(Id,DefExpr,[Id],DefExpr)], -- bindings floating upwards +> [(Id,DefExpr)], -- back loops +> a) -- computation result +> +> thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b +> thenLbl a k +> = a `thenSUs` \(ls, bs, bls, a) -> +> k a `thenSUs` \(ls',bs',bls', b) -> +> returnSUs (ls ++ ls', bs ++ bs', bls ++ bls', b) +> +> returnLbl :: a -> Lbl a +> returnLbl a = returnSUs ([],[],[],a) +> +> mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b] +> mapLbl f [] = returnLbl [] +> mapLbl f (x:xs) +> = f x `thenLbl` \x -> +> mapLbl f xs `thenLbl` \xs -> +> returnLbl (x:xs) + +----------------------------------------------------------------------------- + +This is terribly inefficient. + +> mkLoops :: DefExpr -> SUniqSM ([(Id,DefExpr)],DefExpr) +> mkLoops e = +> error "mkLoops" +>{- LATER: +> loop [] e `thenSUs` \(ls,bs,bls,e) -> + +Throw away all the extracted bindings that can't be reached. These +can occur as the result of some forward loops being short-circuited by +back-loops. We find out which bindings can be reached by a +depth-first search of the call graph starting with the free variables +of the expression being returned. + +> let +> loops_out = filter deforestable (freeVars e) +> (_,reachable) = dfs (==) r ([],[]) loops_out +> r f = lookup f bs +> +> lookup f [] = [] +> lookup f ((g,out,_):xs) | f == g = out +> | otherwise = lookup f xs +> +> isReachable (f,_,_) = f `elem` reachable +> in +> returnSUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e) +> where + +> loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr + +> loop ls (CoVar (Label e e1)) +> = +> d2c e `thenSUs` \core_e -> +>-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $ + +> mapSUs (\(f,e',val_args,ty_args) -> +> renameExprs e' e `thenSUs` \r -> +> returnSUs (f,val_args,ty_args,r)) ls `thenSUs` \results -> +> let +> loops = +> [ (f,val_args,ty_args,r) | +> (f,val_args,ty_args,IsRenaming r) <- results ] +> inconsistent_renamings = +> [ (f,r) | +> (f,val_args,ty_args,InconsistentRenaming r) +> <- results ] +> in +> +> (case loops of +> [] -> + +Ok, there are no loops (i.e. this expression hasn't occurred before). +Prepare for a possible re-occurrence of *this* expression, by making +up a new function name and type (laziness ensures that this isn't +actually done unless the function is required). + +The type of a new function, if one is generated at this point, is +constructed as follows: + + \/ a1 ... \/ an . b1 -> ... -> bn -> t + +where a1...an are the free type variables in the expression, b1...bn +are the types of the free variables in the expression, and t is the +type of the expression itself. + +> let +> +> -- Collect the value/type arguments for the function +> fvs = freeVars e +> val_args = filter isArgId fvs +> ty_args = freeTyVars e +> +> -- Now to make up the type... +> base_type = typeOfCoreExpr core_e +> fun_type = glueTyArgs (map getIdUniType val_args) base_type +> (_, type_of_f) = quantifyTy ty_args fun_type +> in +> +> newDefId type_of_f `thenSUs` \f' -> +> let +> f = replaceIdInfo f' +> (addInfo (getIdInfo f') DoDeforest) +> in +> loop ((f,e,val_args,ty_args):ls) e1 +> `thenSUs` \res@(ls',bs,bls,e') -> + +Key: ls = loops, bs = bindings, bls = back loops, e = expression. + +If we are in a back-loop (i.e. we found a label somewhere below which +this expression is a renaming of), then just insert the expression +here. + +Comment the next section out to disable back-loops. + +(NB. I've seen this panic too - investigate?) + +> let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in +> if not (null back_loops){- && not (f `elem` ls')-} then +> --if length back_loops > 1 then panic "barf!" else +> d2c (head back_loops) `thenSUs` \core_e -> +> trace ("Back Loop:\n" ++ +> ppShow 80 (ppr PprDebug core_e)) $ + +If we find a back-loop that also occurs where we would normally make a +new function... + +> if f `elem` ls' then +> d2c e' `thenSUs` \core_e' -> +> trace ("In Forward Loop " ++ +> ppShow 80 (ppr PprDebug f) ++ "\n" ++ +> ppShow 80 (ppr PprDebug core_e')) $ +> if f `notElem` (freeVars (head back_loops)) then +> returnSUs (ls', bs, bls, head back_loops) +> else +> panic "hello" +> else + +> returnSUs (ls', bs, bls, head back_loops) +> else + +If we are in a forward-loop (i.e. we found a label somewhere below +which is a renaming of this one), then make a new function definition. + +> if f `elem` ls' then +> +> rebindExpr (mkCoTyLam ty_args (mkCoLam val_args e')) +> `thenSUs` \rhs -> +> returnSUs +> (ls', +> (f,filter deforestable (freeVars e'),e,rhs) : bs, +> bls, +> mkLoopFunApp val_args ty_args f) + +otherwise, forget about it + +> else returnSUs res + +This is a loop, just make a call to the function which we +will create on the way back up the tree. + +(NB: it appears that sometimes we do get more than one loop matching, +investigate this?) + +> ((f,val_args,ty_args,r):_) -> +> +> returnSUs +> ([f], -- found a loop, propagate it back +> [], -- no bindings +> [], -- no back loops +> mkLoopFunApp (applyRenaming r val_args) ty_args f) +> +> ) `thenSUs` \res@(ls',bs,bls,e') -> + +If this expression reoccurs, record the binding and replace the cycle +with a call to the new function. We also rebind all the free +variables in the new function to avoid name clashes later. + +> let +> findBackLoops (g,r) bls +> | consistent r' = subst s e' `thenSUs` \e' -> +> returnSUs ((g,e') : bls) +> | otherwise = returnSUs bls +> where +> r' = map swap r +> s = map (\(x,y) -> (x, CoVar (DefArgVar y))) (nub r') +> in + +We just want the first one (ie. furthest up the tree), so reverse the +list of inconsistent renamings. + +> foldrSUs findBackLoops [] (reverse inconsistent_renamings) +> `thenSUs` \back_loops -> + +Comment out the next block to disable back-loops. ToDo: trace all of them. + +> if not (null back_loops) then +> d2c e' `thenSUs` \core_e -> +> trace ("Floating back loop:\n" +> ++ ppShow 80 (ppr PprDebug core_e)) +> returnSUs (ls', bs, back_loops ++ bls, e') +> else +> returnSUs res + +> loop ls e@(CoVar (DefArgVar v)) +> = returnLbl e +> loop ls e@(CoLit l) +> = returnLbl e +> loop ls (CoCon c ts es) +> = mapLbl (loopAtom ls) es `thenLbl` \es -> +> returnLbl (CoCon c ts es) +> loop ls (CoPrim op ts es) +> = mapLbl (loopAtom ls) es `thenLbl` \es -> +> returnLbl (CoPrim op ts es) +> loop ls (CoLam vs e) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoLam vs e) +> loop ls (CoTyLam alpha e) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoTyLam alpha e) +> loop ls (CoApp e v) +> = loop ls e `thenLbl` \e -> +> loopAtom ls v `thenLbl` \v -> +> returnLbl (CoApp e v) +> loop ls (CoTyApp e t) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoTyApp e t) +> loop ls (CoCase e ps) +> = loop ls e `thenLbl` \e -> +> loopCaseAlts ls ps `thenLbl` \ps -> +> returnLbl (CoCase e ps) +> loop ls (CoLet (CoNonRec v e) e') +> = loop ls e `thenLbl` \e -> +> loop ls e' `thenLbl` \e' -> +> returnLbl (CoLet (CoNonRec v e) e') +> loop ls (CoLet (CoRec bs) e) +> = mapLbl loopRecBind bs `thenLbl` \bs -> +> loop ls e `thenLbl` \e -> +> returnLbl (CoLet (CoRec bs) e) +> where +> vs = map fst bs +> loopRecBind (v, e) +> = loop ls e `thenLbl` \e -> +> returnLbl (v, e) +> loop ls e +> = defPanic "Cyclic" "loop" e + +> loopAtom ls (CoVarAtom (DefArgExpr e)) +> = loop ls e `thenLbl` \e -> +> returnLbl (CoVarAtom (DefArgExpr e)) +> loopAtom ls (CoVarAtom e@(DefArgVar v)) +> = defPanic "Cyclic" "loopAtom" (CoVar e) +> loopAtom ls (CoVarAtom e@(Label _ _)) +> = defPanic "Cyclic" "loopAtom" (CoVar e) +> loopAtom ls e@(CoLitAtom l) +> = returnLbl e +> +> loopCaseAlts ls (CoAlgAlts as def) = +> mapLbl loopAlgAlt as `thenLbl` \as -> +> loopDefault ls def `thenLbl` \def -> +> returnLbl (CoAlgAlts as def) +> where +> loopAlgAlt (c, vs, e) = +> loop ls e `thenLbl` \e -> +> returnLbl (c, vs, e) + +> loopCaseAlts ls (CoPrimAlts as def) = +> mapLbl loopPrimAlt as `thenLbl` \as -> +> loopDefault ls def `thenLbl` \def -> +> returnLbl (CoPrimAlts as def) +> where +> loopPrimAlt (l, e) = +> loop ls e `thenLbl` \e -> +> returnLbl (l, e) + +> loopDefault ls CoNoDefault = +> returnLbl CoNoDefault +> loopDefault ls (CoBindDefault v e) = +> loop ls e `thenLbl` \e -> +> returnLbl (CoBindDefault v e) +> -} + +> mkVar v = CoVarAtom (DefArgExpr (CoVar (DefArgVar v))) + +----------------------------------------------------------------------------- +The next function is applied to all deforestable functions which are +placed in the environment. Given a list of free variables in the +recursive set of which the function is a member, this funciton +abstracts those variables, generates a new Id with the new type, and +returns a substitution element which can be applied to all other +expressions and function right hand sides that call this function. + + (freeVars e) \subseteq (freeVars l) + +> fixupFreeVars :: [Id] -> Id -> DefExpr -> ((Id,DefExpr),[(Id,DefExpr)]) +> fixupFreeVars total_fvs id e = +> case fvs of +> [] -> ((id,e),[]) +> _ -> let new_type = +> glueTyArgs (map getIdUniType fvs) +> (getIdUniType id) +> new_id = +> updateIdType id new_type +> in +> let +> t = foldl CoApp (CoVar (DefArgVar new_id)) +> (map mkVar fvs) +> in +> trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $ +> ((new_id, mkCoLam fvs e), [(id,t)]) +> where +> fvs = case e of +> CoLam bvs e -> filter (`notElem` bvs) total_fvs +> _ -> total_fvs + +> swap (x,y) = (y,x) + +> applyRenaming :: [(Id,Id)] -> [Id] -> [Id] +> applyRenaming r ids = map rename ids +> where +> rename x = case [ y | (x',y) <- r, x' `eqId` x ] of +> [] -> panic "Cyclic(rename): no match in rename" +> (y:_) -> y + +> mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr +> mkLoopFunApp val_args ty_args f = +> foldl CoApp +> (foldl CoTyApp (CoVar (DefArgVar f)) +> (map mkTyVarTy ty_args)) +> (map mkVar val_args) + +----------------------------------------------------------------------------- +Removing duplicates from a list of definitions. + +> removeDuplicateDefinitions +> :: [(DefExpr,(Id,DefExpr))] -- (label,(id,rhs)) +> -> SUniqSM [(Id,DefExpr)] + +> removeDuplicateDefinitions defs = +> foldrSUs rem ([],[]) defs `thenSUs` \(newdefs,s) -> +> mapSUs (\(l,(f,e)) -> subst s e `thenSUs` \e -> +> returnSUs (f, e)) newdefs +> where + +> rem d@(l,(f,e)) (defs,s) = +> findDup l defs `thenSUs` \maybe -> +> case maybe of +> Nothing -> returnSUs (d:defs,s) +> Just g -> returnSUs (defs, (f,(CoVar.DefArgVar) g):s) + +We insist that labels rename in both directions, is this necessary? + +> findDup l [] = returnSUs Nothing +> findDup l ((l',(f,e)):defs) = +> renameExprs l l' `thenSUs` \r -> +> case r of +> IsRenaming _ -> renameExprs l' l `thenSUs` \r -> +> case r of +> IsRenaming r -> returnSUs (Just f) +> _ -> findDup l defs +> _ -> findDup l defs diff --git a/ghc/compiler/deforest/Def2Core.hi b/ghc/compiler/deforest/Def2Core.hi new file mode 100644 index 0000000..4e36e86 --- /dev/null +++ b/ghc/compiler/deforest/Def2Core.hi @@ -0,0 +1,23 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Def2Core where +import CoreSyn(CoreBinding, CoreExpr) +import DefSyn(DefBindee, DefBinding(..)) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreProgram(..)) +import SplitUniq(SUniqSM(..), SplitUniqSupply) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data DefBindee {-# GHC_PRAGMA DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee) #-} +type DefBinding = CoreBinding Id DefBindee +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreProgram = [CoreBinding Id Id] +type SUniqSM a = SplitUniqSupply -> a +d2c :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "S" _N_ _N_ #-} +def2core :: [CoreBinding Id DefBindee] -> SplitUniqSupply -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "S" _N_ _N_ #-} +defPanic :: [Char] -> [Char] -> CoreExpr Id DefBindee -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 3 _U_ 1111 _N_ _S_ _!_ _N_ _N_ #-} + diff --git a/ghc/compiler/deforest/Def2Core.lhs b/ghc/compiler/deforest/Def2Core.lhs new file mode 100644 index 0000000..7fe5b11 --- /dev/null +++ b/ghc/compiler/deforest/Def2Core.lhs @@ -0,0 +1,156 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Def2Core]{Translate a DefProgram back into a CoreProgram} + +>#include "HsVersions.h" +> +> module Def2Core ( +> def2core, d2c, +> +> -- and to make the interface self-sufficient, all this stuff: +> DefBinding(..), SUniqSM(..), PlainCoreProgram(..), +> CoreBinding, Id, DefBindee, +> defPanic +> ) where + +> import DefSyn +> import DefUtils +> +> import Maybes ( Maybe(..) ) +> import Outputable +> import PlainCore +> import Pretty +> import SplitUniq +> import Util + + +> def2core :: DefProgram -> SUniqSM PlainCoreProgram +> def2core prog = mapSUs defBinding2core prog + +> defBinding2core :: DefBinding -> SUniqSM PlainCoreBinding +> defBinding2core (CoNonRec v e) = +> d2c e `thenSUs` \e' -> +> returnSUs (CoNonRec v e') +> defBinding2core (CoRec bs) = +> mapSUs recBind2core bs `thenSUs` \bs' -> +> returnSUs (CoRec bs') +> where recBind2core (v,e) +> = d2c e `thenSUs` \e' -> +> returnSUs (v, e') + + +> defAtom2core :: DefAtom -> SUniqSM (PlainCoreAtom, Maybe PlainCoreExpr) +> defAtom2core atom = case atom of +> CoLitAtom l -> returnSUs (CoLitAtom l, Nothing) +> CoVarAtom (DefArgVar id) -> returnSUs (CoVarAtom id, Nothing) +> CoVarAtom (DefArgExpr (CoVar (DefArgVar id))) -> +> returnSUs (CoVarAtom id, Nothing) +> CoVarAtom (DefArgExpr (CoLit l)) -> +> returnSUs (CoLitAtom l, Nothing) +> CoVarAtom (DefArgExpr e) -> +> d2c e `thenSUs` \e' -> +> newTmpId (typeOfCoreExpr e') `thenSUs` \new_id -> +> returnSUs (CoVarAtom new_id, Just e') +> CoVarAtom (Label _ _) -> +> panic "Def2Core(defAtom2core): CoVarAtom (Label _ _)" + +> d2c :: DefExpr -> SUniqSM PlainCoreExpr +> d2c e = case e of +> +> CoVar (DefArgExpr e) -> +> panic "Def2Core(d2c): CoVar (DefArgExpr _)" +> +> CoVar (Label _ _) -> +> panic "Def2Core(d2c): CoVar (Label _ _)" +> +> CoVar (DefArgVar v) -> +> returnSUs (CoVar v) +> +> CoLit l -> +> returnSUs (CoLit l) +> +> CoCon c ts as -> +> mapSUs defAtom2core as `thenSUs` \atom_expr_pairs -> +> returnSUs ( +> foldr (\(a,b) -> mkLet a b) +> (CoCon c ts (map fst atom_expr_pairs)) +> atom_expr_pairs) +> +> CoPrim op ts as -> +> mapSUs defAtom2core as `thenSUs` \atom_expr_pairs -> +> returnSUs ( +> foldr (\(a,b) -> mkLet a b) +> (CoPrim op ts (map fst atom_expr_pairs)) +> atom_expr_pairs) +> +> CoLam vs e -> +> d2c e `thenSUs` \e' -> +> returnSUs (CoLam vs e') +> +> CoTyLam alpha e -> +> d2c e `thenSUs` \e' -> +> returnSUs (CoTyLam alpha e') +> +> CoApp e v -> +> d2c e `thenSUs` \e' -> +> defAtom2core v `thenSUs` \(v',e'') -> +> returnSUs (mkLet v' e'' (CoApp e' v')) +> +> CoTyApp e t -> +> d2c e `thenSUs` \e' -> +> returnSUs (CoTyApp e' t) +> +> CoCase e ps -> +> d2c e `thenSUs` \e' -> +> defCaseAlts2Core ps `thenSUs` \ps' -> +> returnSUs (CoCase e' ps') +> +> CoLet b e -> +> d2c e `thenSUs` \e' -> +> defBinding2core b `thenSUs` \b' -> +> returnSUs (CoLet b' e') +> +> CoSCC l e -> +> d2c e `thenSUs` \e' -> +> returnSUs (CoSCC l e') + +> defCaseAlts2Core :: DefCaseAlternatives +> -> SUniqSM PlainCoreCaseAlternatives +> +> defCaseAlts2Core alts = case alts of +> CoAlgAlts alts dflt -> +> mapSUs algAlt2Core alts `thenSUs` \alts' -> +> defAlt2Core dflt `thenSUs` \dflt' -> +> returnSUs (CoAlgAlts alts' dflt') +> +> CoPrimAlts alts dflt -> +> mapSUs primAlt2Core alts `thenSUs` \alts' -> +> defAlt2Core dflt `thenSUs` \dflt' -> +> returnSUs (CoPrimAlts alts' dflt') +> +> where +> +> algAlt2Core (c, vs, e) = d2c e `thenSUs` \e' -> returnSUs (c, vs, e') +> primAlt2Core (l, e) = d2c e `thenSUs` \e' -> returnSUs (l, e') +> +> defAlt2Core CoNoDefault = returnSUs CoNoDefault +> defAlt2Core (CoBindDefault v e) = +> d2c e `thenSUs` \e' -> +> returnSUs (CoBindDefault v e') + +> mkLet :: PlainCoreAtom +> -> Maybe PlainCoreExpr +> -> PlainCoreExpr +> -> PlainCoreExpr +> +> mkLet (CoVarAtom v) (Just e) e' = CoLet (CoNonRec v e) e' +> mkLet v Nothing e' = e' + +----------------------------------------------------------------------------- +XXX - in here becuase if it goes in DefUtils we've got mutual recursion. + +> defPanic :: String -> String -> DefExpr -> SUniqSM a +> defPanic modl fun expr = +> d2c expr `thenSUs` \expr -> +> panic (modl ++ "(" ++ fun ++ "): " ++ ppShow 80 (ppr PprDebug expr)) diff --git a/ghc/compiler/deforest/DefExpr.hi b/ghc/compiler/deforest/DefExpr.hi new file mode 100644 index 0000000..f4164ed --- /dev/null +++ b/ghc/compiler/deforest/DefExpr.hi @@ -0,0 +1,12 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DefExpr where +import CmdLineOpts(SwitchResult) +import CoreSyn(CoreArg, CoreExpr) +import DefSyn(DefBindee) +import Id(Id) +import SplitUniq(SplitUniqSupply) +import UniType(UniType) +import UniqFM(UniqFM) +tran :: (a -> SwitchResult) -> UniqFM (CoreExpr Id DefBindee) -> UniqFM UniType -> CoreExpr Id DefBindee -> [CoreArg DefBindee] -> SplitUniqSupply -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 5 _U_ 222222 _N_ _S_ "LLLSL" _N_ _N_ #-} + diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs new file mode 100644 index 0000000..7a1eaaf --- /dev/null +++ b/ghc/compiler/deforest/DefExpr.lhs @@ -0,0 +1,657 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DefExpr]{Transformation Algorithm for Expressions} + +>#include "HsVersions.h" + +> module DefExpr ( +> tran +> ) where +> +> import DefSyn +> import CoreSyn +> import DefUtils +> import Core2Def ( c2d ) -- for unfoldings +> import TreelessForm +> import Cyclic + +> import AbsUniType ( applyTypeEnvToTy, isPrimType, +> SigmaType(..), UniType +> IF_ATTACK_PRAGMAS(COMMA cmpUniType) +> ) +> import CmdLineOpts ( SwitchResult, switchIsOn ) +> import CoreFuns ( mkCoLam, unTagBinders, typeOfCoreExpr ) +> import Id ( applyTypeEnvToId, getIdInfo, isTopLevId, Id, +> isInstId_maybe +> ) +> import Inst -- Inst(..) +> import IdEnv +> import IdInfo +> import Maybes ( Maybe(..) ) +> import Outputable +> import SimplEnv ( SwitchChecker(..), UnfoldingDetails(..) ) +> import SplitUniq +> import TyVarEnv +> import Util + +> -- tmp +> import Pretty +> import Def2Core + +----------------------------------------------------------------------------- +Top level transformation + +A type environment mapping type variables to types is carried around. +This is extended by one rule only: reduction of a type application. + +> tran +> :: SwitchChecker who_knows +> -> IdEnv DefExpr -- Environment +> -> TypeEnv -- Type environment +> -> DefExpr -- input expression +> -> [DefCoreArg] -- args +> -> SUniqSM DefExpr + +> tran sw p t e@(CoVar (DefArgVar id)) as = +> tranVar sw p id +> ( +> mapArgs (\e -> tran sw p t e []) as `thenSUs` \as -> +> returnSUs (applyToArgs (CoVar (DefArgVar new_id)) as) +> ) +> ( +> \e -> +> tran sw p t e as `thenSUs` \e -> +> returnSUs (mkLabel (applyToArgs (CoVar (DefArgVar new_id)) +> (map (substTyArg t) as)) +> e) +> ) +> where new_id = applyTypeEnvToId t id + +> tran sw p t e@(CoLit l) [] = +> returnSUs e +> +> tran sw p t (CoCon c ts es) [] = +> mapSUs (tranAtom sw p t) es `thenSUs` \es -> +> returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es) +> +> tran sw p t (CoPrim op ts es) [] = -- XXX constant folding? +> mapSUs (tranAtom sw p t) es `thenSUs` \es -> +> returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es) +> +> tran sw p t (CoLam vs e) [] = +> tran sw p t e [] `thenSUs` \e -> +> returnSUs (mkCoLam (map (applyTypeEnvToId t) vs) e) +> +> tran sw p t (CoLam vs e) as = +> subst s e `thenSUs` \e -> +> tran sw p t (mkCoLam rvs e) ras +> where +> (rvs,ras,s) = mkSubst vs as [] + +> tran sw p t (CoTyLam alpha e) [] = +> tran sw p t e [] `thenSUs` \e -> +> returnSUs (CoTyLam alpha e) +> + + ToDo: use the environment rather than doing explicit substitution + (didn't work last time I tried :) + +> tran sw p t (CoTyLam alpha e) (TypeArg ty : as) = +> tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as + +> tran sw p t (CoApp e v) as = +> maybeJumbleApp e v `thenSUs` \j -> +> case j of +> Nothing -> tran sw p t e (ValArg v : as) +> Just e' -> tran sw p t e' as +> +> tran sw p t (CoTyApp e ty) as = +> tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as) +> +> tran sw p t (CoLet (CoNonRec v e) e') as = +> tran sw p t e [] `thenSUs` \e -> +> if isConstant e then +> trace "yippee!!" $ +> subst [(v,removeLabels e)] e' `thenSUs` \e' -> +> tran sw p t e' as +> else +> tran sw p t e' as `thenSUs` \e' -> +> returnSUs (CoLet (CoNonRec (applyTypeEnvToId t v) e) e') +> +> tran sw p t (CoLet (CoRec bs) e) as = +> tranRecBinds sw p t bs e `thenSUs` \(p',resid,e) -> +> tran sw p' t e as `thenSUs` \e -> +> returnSUs (mkDefLetrec resid e) +> +> tran sw p t (CoSCC l e) as = +> tran sw p t e [] `thenSUs` \e -> +> mapArgs (\e -> tran sw p t e []) as `thenSUs` \as -> +> returnSUs (applyToArgs (CoSCC l e) as) +> +> tran sw p t (CoCase e ps) as = +> tranCase sw p t e [] ps as +> +> tran _ _ _ e as = +> defPanic "DefExpr" "tran" (applyToArgs e as) + +----------------------------------------------------------------------------- +Transformation for case expressions of the form (case e1..en of {..}) + +> tranCase +> :: SwitchChecker who_knows +> -> IdEnv DefExpr +> -> TypeEnv +> -> DefExpr +> -> [DefCoreArg] +> -> DefCaseAlternatives +> -> [DefCoreArg] +> -> SUniqSM DefExpr + +> tranCase sw p t e bs ps as = case e of +> +> CoVar (DefArgVar id) -> +> tranVar sw p id +> ( +> tranAlts sw p t ps as `thenSUs` \ps -> +> mapArgs (\e -> tran sw p t e []) bs `thenSUs` \bs -> +> returnSUs +> (CoCase +> (applyToArgs (CoVar (DefArgVar +> (applyTypeEnvToId t id))) +> bs) +> ps) +> ) +> ( +> \e -> +> tranCase sw p t e bs ps as `thenSUs` \e -> +> returnSUs +> (mkLabel +> (applyToArgs +> (CoCase (applyToArgs (CoVar (DefArgVar id)) +> (map (substTyArg t) bs)) +> ps) +> (map (substTyArg t) as)) +> e) +> ) +> +> CoLit l -> +> case bs of +> [] -> tranAlts sw p t ps as `thenSUs` \ps -> +> returnSUs (CoCase e ps) +> _ -> die_horribly +> +> CoPrim op ts es -> +> case bs of +> [] -> tranAlts sw p t ps as `thenSUs` \ps -> +> mapSUs (tranAtom sw p t) es `thenSUs` \es -> +> returnSUs (CoCase (CoPrim op +> (map (applyTypeEnvToTy t) ts) es) ps) +> _ -> die_horribly +> +> CoCon c ts es -> +> case bs of +> [] -> case ps of +> CoAlgAlts alts def -> +> reduceCase sw p c ts es alts def as +> CoPrimAlts alts def -> die_horribly +> _ -> die_horribly +> +> CoLam vs e -> +> case bs of +> [] -> die_horribly +> (TypeArg _ : _) -> die_horribly +> _ -> subst s e `thenSUs` \e -> +> tranCase sw p t e rbs ps as +> where +> (rvs,rbs,s) = mkSubst vs bs [] +> +> CoTyLam alpha e -> +> case bs of +> TypeArg ty : bs' -> tranCase sw p t e' bs' ps as +> where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e +> _ -> die_horribly +> +> CoApp e v -> +> maybeJumbleApp e v `thenSUs` \j -> +> case j of +> Nothing -> tranCase sw p t e (ValArg v : bs) ps as +> Just e' -> tranCase sw p t e' bs ps as +> +> CoTyApp e ty -> +> tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs) +> ps as +> +> CoLet (CoNonRec v e) e' -> +> tran sw p t e [] `thenSUs` \e -> +> if isConstant e then +> trace "yippee2!!" $ +> subst [(v,removeLabels e)] e' `thenSUs` \e' -> +> tranCase sw p t e' bs ps as +> else +> tranCase sw p t e' bs ps as `thenSUs` \e' -> +> returnSUs (CoLet (CoNonRec +> (applyTypeEnvToId t v) e) e') +> +> CoLet (CoRec binds) e -> +> tranRecBinds sw p t binds e `thenSUs` \(p',resid,e) -> +> tranCase sw p' t e bs ps as `thenSUs` \e -> +> returnSUs (mkDefLetrec resid e) +> +> -- ToDo: sort out cost centres. Currently they act as a barrier +> -- to optimisation. +> CoSCC l e -> +> tran sw p t e [] `thenSUs` \e -> +> mapArgs (\e -> tran sw p t e []) bs +> `thenSUs` \bs -> +> tranAlts sw p t ps as `thenSUs` \ps -> +> returnSUs (CoCase (applyToArgs (CoSCC l e) bs) +> ps) +> +> CoCase e ps' -> +> tranCase sw p t e [] +> (mapAlts (\e -> applyToArgs (CoCase e ps) bs) ps') as +> +> _ -> die_horribly +> +> where die_horribly = defPanic "DefExpr" "tranCase" +> (applyToArgs (CoCase (applyToArgs e bs) ps) as) + +----------------------------------------------------------------------------- +Deciding whether or not to replace a function variable with it's +definition. The tranVar function is passed four arguments: the +environment, the Id itself, the expression to return if no +unfolding takes place, and a function to apply to the unfolded expression +should an unfolding be required. + +> tranVar +> :: SwitchChecker who_knows +> -> IdEnv DefExpr +> -> Id +> -> SUniqSM DefExpr +> -> (DefExpr -> SUniqSM DefExpr) +> -> SUniqSM DefExpr +> +> tranVar sw p id no_unfold unfold_with = +> +> case lookupIdEnv p id of +> Just e' -> +> rebindExpr e' `thenSUs` \e' -> +> if deforestable id +> then unfold_with e' +> else panic "DefExpr(tran): not deforestable id in env" + + No mapping in the environment, but it could be an + imported function that was annotated with DEFOREST, + in which case it will have an unfolding inside the Id + itself. + +> Nothing -> +> if (not . deforestable) id +> then no_unfold +> +> else case (getInfo_UF (getIdInfo id)) of +> GeneralForm _ _ expr guidance -> +> panic "DefExpr:GeneralForm has changed a little; needs mod here" +> -- SLPJ March 95 +> +>--??? -- ToDo: too much overhead here. +>--??? let e' = c2d nullIdEnv expr in +>--??? convertToTreelessForm sw e' `thenSUs` \e'' -> +>--??? unfold_with e'' +> _ -> no_unfold + + If the unfolding isn't present, this is + a sign that the function is from this module and + is not in the environemnt yet (maybe because + we are transforming the body of the definition + itself). + +> {- panic +> ("DefExpr(tran): Deforestable id `" +> ++ ppShow 80 (ppr PprDebug id) +> ++ "' doesn't have an unfolding.") -} + +----------------------------------------------------------------------------- +Transform a set of case alternatives. + +> tranAlts +> :: SwitchChecker who_knows +> -> IdEnv DefExpr +> -> TypeEnv +> -> DefCaseAlternatives +> -> [DefCoreArg] +> -> SUniqSM DefCaseAlternatives + +> tranAlts sw p t (CoAlgAlts alts def) as = +> mapSUs (tranAlgAlt sw p t as) alts `thenSUs` \alts -> +> tranDefault sw p t def as `thenSUs` \def -> +> returnSUs (CoAlgAlts alts def) +> tranAlts sw p t (CoPrimAlts alts def) as = +> mapSUs (tranPrimAlt sw p t as) alts `thenSUs` \alts -> +> tranDefault sw p t def as `thenSUs` \def -> +> returnSUs (CoPrimAlts alts def) + +> tranAlgAlt sw p t as (c, vs, e) = +> tran sw p t e as `thenSUs` \e -> +> returnSUs (c, map (applyTypeEnvToId t) vs, e) +> tranPrimAlt sw p t as (l, e) = +> tran sw p t e as `thenSUs` \e -> +> returnSUs (l, e) +> +> tranDefault sw p t CoNoDefault as = returnSUs CoNoDefault +> tranDefault sw p t (CoBindDefault v e) as = +> tran sw p t e as `thenSUs` \e -> +> returnSUs (CoBindDefault (applyTypeEnvToId t v) e) + +----------------------------------------------------------------------------- +Transform an atom. + +> tranAtom +> :: SwitchChecker who_knows +> -> IdEnv DefExpr +> -> TypeEnv +> -> DefAtom +> -> SUniqSM DefAtom + +> tranAtom sw p t (CoVarAtom v) = +> tranArg sw p t v `thenSUs` \v -> +> returnSUs (CoVarAtom v) +> tranAtom sw p t e@(CoLitAtom l) = -- XXX +> returnSUs e + +> tranArg sw p t (DefArgExpr e) = +> tran sw p t e [] `thenSUs` \e -> +> returnSUs (DefArgExpr e) +> tranArg sw p t e@(Label _ _) = +> defPanic "DefExpr" "tranArg" (CoVar e) +> tranArg sw p t (DefArgVar v) = +> tran sw p t (CoVar (DefArgVar v)) [] `thenSUs` \e -> +> returnSUs (DefArgExpr e) -- XXX remove this case + +----------------------------------------------------------------------------- +Translating recursive definition groups. + +We first transform each binding, and then seperate the results into +deforestable and non-deforestable sets of bindings. The deforestable +bindings are processed by the knot-tyer, and added to the current +environment. The rest of the bindings are returned as residual. + +ToDo: conversion to treeless form should be unnecessary here, becuase +the transformer/knot-tyer should leave things in treeless form. + +> tranRecBinds sw p t bs e = + +Transform all the deforestable definitions, yielding + (extracted,rhss) +list of extracted functions = concat extracted ok, so let's get the +total set of free variables of the whole function set, call this set +fvs. Expand the argument list of each function by + (fvs - freeVars rhs) +and substitute the new function calls throughout the function set. + + +> let +> (unfold,resid) = partition (deforestable . fst) bs +> in + +> mapSUs (tranRecBind sw p t) unfold `thenSUs` \unfold -> +> mapSUs (tranRecBind sw p t) resid `thenSUs` \resid -> + + Tie knots in the deforestable right-hand sides, and convert the + results to treeless form. Then extract any nested deforestable + recursive functions, and place everything we've got in the new + environment. + +> let (vs,es) = unzip unfold in +> mapSUs mkLoops es `thenSUs` \res -> +> let +> (extracted,new_rhss) = unzip res +> new_binds = zip vs new_rhss ++ concat extracted +> in + + Convert everything to treeless form (these functions aren't + necessarily already in treeless form because the functions + bound in this letrec are about to change status from not + unfolded to unfolded). + +> mapSUs (\(v,e) -> +> convertToTreelessForm sw e `thenSUs` \e -> +> returnSUs (v,e)) new_binds `thenSUs` \fs -> + + Now find the total set of free variables of this function set. + +> let +> fvs = filter (\id -> isArgId id{- && (not . isLitId) id-}) +> (foldr union [] (map freeVars (map snd fs))) +> in + + Now expand the argument lists to include the total set of free vars. + +> let +> stuff = [ fixupFreeVars fvs id e | (id,e) <- fs ] +> fs' = map fst stuff +> s = concat (map snd stuff) +> subIt (id,e) = subst s e `thenSUs` \e -> returnSUs (id,e) +> in +> subst s e `thenSUs` \e -> +> mapSUs subIt resid `thenSUs` \resid -> +> mapSUs subIt fs' `thenSUs` \fs -> + +> let res = returnSUs (growIdEnvList p fs, resid, e) in +> case unzip fs of +> (evs,ees) -> mapSUs d2c ees `thenSUs` \ees -> +> let (vs',es') = unzip bs in +> mapSUs d2c es' `thenSUs` \es' -> +> trace ("extraction " +> ++ showIds (map fst bs) +> ++ showIds evs +> ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n" +> ++ "{ result:\n" ++ (concat (map showBind (zip evs ees))) ++ "}\n") res +> where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n" + +> tranRecBind sw p t (id,e) = +> tran sw p t e [] `thenSUs` \e -> +> returnSUs (applyTypeEnvToId t id,e) + +> showIds :: [Id] -> String +> showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids) +> ++ " )" + +----------------------------------------------------------------------------- + +> reduceCase sw p c ts es alts def as = +> case [ a | a@(c',vs,e) <- alts, c' == c ] of +> [(c,vs,e)] -> +> subst (zip vs (map atom2expr es)) e `thenSUs` \e -> +> tran sw p nullTyVarEnv e as +> [] -> case def of +> CoNoDefault -> +> panic "DefExpr(reduceCase): no match" +> CoBindDefault v e -> +> subst [(v,CoCon c ts es)] e `thenSUs` \e -> +> tran sw p nullTyVarEnv e as +> _ -> panic "DefExpr(reduceCase): multiple matches" + +----------------------------------------------------------------------------- +Type Substitutions. + +> applyTypeEnvToExpr +> :: TypeEnv +> -> DefExpr +> -> DefExpr + +> applyTypeEnvToExpr p e = substTy e +> where +> substTy e' = case e' of +> CoVar (DefArgExpr e) -> panic "DefExpr(substTy): CoVar (DefArgExpr _)" +> CoVar (Label l e) -> panic "DefExpr(substTy): CoVar (Label _ _)" +> CoVar (DefArgVar id) -> CoVar (DefArgVar (applyTypeEnvToId p id)) +> CoLit l -> e' +> CoCon c ts es -> +> CoCon c (map (applyTypeEnvToTy p) ts) (map substTyAtom es) +> CoPrim op ts es -> +> CoPrim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es) +> CoLam vs e -> CoLam (map (applyTypeEnvToId p) vs) (substTy e) +> CoTyLam alpha e -> CoTyLam alpha (substTy e) +> CoApp e v -> CoApp (substTy e) (substTyAtom v) +> CoTyApp e t -> mkCoTyApp (substTy e) (applyTypeEnvToTy p t) +> CoCase e ps -> CoCase (substTy e) (substTyCaseAlts ps) +> CoLet (CoNonRec id e) e' -> +> CoLet (CoNonRec (applyTypeEnvToId p id) (substTy e)) +> (substTy e') +> CoLet (CoRec bs) e -> +> CoLet (CoRec (map substTyRecBind bs)) (substTy e) +> where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e) +> CoSCC l e -> CoSCC l (substTy e) + +> substTyAtom :: DefAtom -> DefAtom +> substTyAtom (CoVarAtom v) = CoVarAtom (substTyArg v) +> substTyAtom (CoLitAtom l) = CoLitAtom l -- XXX + +> substTyArg :: DefBindee -> DefBindee +> substTyArg (DefArgExpr e) = DefArgExpr (substTy e) +> substTyArg e@(Label _ _) = panic "DefExpr(substArg): Label _ _" +> substTyArg e@(DefArgVar id) = -- XXX +> DefArgVar (applyTypeEnvToId p id) + +> substTyCaseAlts (CoAlgAlts as def) +> = CoAlgAlts (map substTyAlgAlt as) (substTyDefault def) +> substTyCaseAlts (CoPrimAlts as def) +> = CoPrimAlts (map substTyPrimAlt as) (substTyDefault def) + +> substTyAlgAlt (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e) +> substTyPrimAlt (l, e) = (l, substTy e) + +> substTyDefault CoNoDefault = CoNoDefault +> substTyDefault (CoBindDefault id e) = +> CoBindDefault (applyTypeEnvToId p id) (substTy e) + +> substTyArg t (ValArg e) = +> ValArg (CoVarAtom (DefArgExpr (applyTypeEnvToExpr t (atom2expr e)))) +> substTyArg t (TypeArg ty) = TypeArg ty + +----------------------------------------------------------------------------- + +> mapAlts f ps = case ps of +> CoAlgAlts alts def -> +> CoAlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def) +> CoPrimAlts alts def -> +> CoPrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def) +> +> mapDef f CoNoDefault = CoNoDefault +> mapDef f (CoBindDefault v e) = CoBindDefault v (f e) + +----------------------------------------------------------------------------- +Apply a function to all the ValArgs in an Args list. + +> mapArgs +> :: (DefExpr -> SUniqSM DefExpr) +> -> [DefCoreArg] +> -> SUniqSM [DefCoreArg] +> +> mapArgs f [] = +> returnSUs [] +> mapArgs f (a@(TypeArg ty) : as) = +> mapArgs f as `thenSUs` \as -> +> returnSUs (a:as) +> mapArgs f (ValArg v : as) = +> f (atom2expr v) `thenSUs` \e -> +> mapArgs f as `thenSUs` \as -> +> returnSUs (ValArg (CoVarAtom (DefArgExpr e)) : as) +> + +> mkSubst [] as s = ([],as,s) +> mkSubst vs [] s = (vs,[],s) +> mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s) + +----------------------------------------------------------------------------- + +The next function does a bit of extraction for applicative terms +before they are transformed. We look for boring expressions - those +that won't be any use in removing intermediate data structures. These +include applicative terms where we cannot unfold the head, +non-reducible case expressions, primitive applications and some let +bindings. + +Extracting these expressions helps the knot-tyer to find loops +earlier, and avoids the need to do matching instead of renaming. + +We also pull out lets from function arguments, and primitive case +expressions (which can't fail anyway). + +Think: + + (t (case u of x -> v)) + ====> + let x = u in t v + +Maybe shouldn't do this if -fpedantic-bottoms? Also can't do it if u +has an unboxed type. + +ToDo: sort this mess out - could be more efficient. + +> maybeJumbleApp :: DefExpr -> DefAtom -> SUniqSM (Maybe DefExpr) +> maybeJumbleApp e (CoLitAtom _) = returnSUs Nothing -- ToDo remove +> maybeJumbleApp e (CoVarAtom (DefArgExpr (CoVar (DefArgVar _)))) +> = returnSUs Nothing +> maybeJumbleApp e (CoVarAtom (DefArgExpr t)) +> = let t' = pull_out t [] in +> case t' of +> CoLet _ _ -> returnSUs (Just t') +> CoCase (CoPrim _ _ _) (CoPrimAlts [] _) -> returnSUs (Just t') +> _ -> if isBoringExpr t then +> rebind_with_let t +> else +> returnSUs Nothing + +> where isBoringExpr (CoVar (DefArgVar z)) = (not . deforestable) z +> isBoringExpr (CoPrim op ts es) = True +> isBoringExpr (CoCase e ps) = isBoringExpr e +> && boringCaseAlternatives ps +> isBoringExpr (CoApp l r) = isBoringExpr l +> isBoringExpr (CoTyApp l t) = isBoringExpr l +> isBoringExpr _ = False +> +> boringCaseAlternatives (CoAlgAlts as d) = +> all boringAlgAlt as && boringDefault d +> boringCaseAlternatives (CoPrimAlts as d) = +> all boringPrimAlt as && boringDefault d +> +> boringAlgAlt (c,xs,e) = isBoringExpr e +> boringPrimAlt (l,e) = isBoringExpr e +> +> boringDefault CoNoDefault = True +> boringDefault (CoBindDefault x e) = isBoringExpr e + +> pull_out (CoLet b t) as = CoLet b (pull_out t as) +> pull_out (CoApp l r) as = pull_out l (r:as) +> pull_out (CoCase prim@(CoPrim _ _ _) +> (CoPrimAlts [] (CoBindDefault x u))) as +> = CoCase prim (CoPrimAlts [] (CoBindDefault x +> (pull_out u as))) +> pull_out t as +> = CoApp e (CoVarAtom (DefArgExpr (foldl CoApp t as))) +> +> rebind_with_let t = +> d2c t `thenSUs` \core_t -> +> newDefId (typeOfCoreExpr core_t) `thenSUs` \x -> +> trace "boring epxr found!" $ +> returnSUs (Just (CoLet (CoNonRec x t) +> (CoApp e (CoVarAtom ( +> DefArgExpr (CoVar ( +> DefArgVar x))))))) + +----------------------------------------------------------------------------- + +> isLitId id = case isInstId_maybe id of +> Just (LitInst _ _ _ _) -> True +> _ -> False + +> isConstant (CoCon c [] []) = True +> isConstant (CoLit l) = True +> isConstant (CoVar (Label l e)) = isConstant e +> isConstant _ = False + +> removeLabels (CoVar (Label l e)) = removeLabels e +> removeLabels e = e diff --git a/ghc/compiler/deforest/DefSyn.hi b/ghc/compiler/deforest/DefSyn.hi new file mode 100644 index 0000000..fde9292 --- /dev/null +++ b/ghc/compiler/deforest/DefSyn.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DefSyn where +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr) +import Id(Id) +type DefAtom = CoreAtom DefBindee +data DefBindee = DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee) +type DefBinding = CoreBinding Id DefBindee +type DefCaseAlternatives = CoreCaseAlternatives Id DefBindee +type DefCaseDefault = CoreCaseDefault Id DefBindee +type DefCoreArg = CoreArg DefBindee +type DefExpr = CoreExpr Id DefBindee +type DefProgram = [CoreBinding Id DefBindee] +mkLabel :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/deforest/DefSyn.lhs b/ghc/compiler/deforest/DefSyn.lhs new file mode 100644 index 0000000..afb72d5 --- /dev/null +++ b/ghc/compiler/deforest/DefSyn.lhs @@ -0,0 +1,59 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[DefSyn]{A temporary datatype for the deforestation pass} + +> module DefSyn where + +> import CoreSyn +> import Outputable +> import Util + +This is exactly the same as core, except that the argument to +application can be an arbitrary expression. + +> type DefProgram = [CoreBinding Id DefBindee] +> type DefBinding = CoreBinding Id DefBindee +> type DefExpr = CoreExpr Id DefBindee +> type DefAtom = CoreAtom DefBindee +> type DefCaseAlternatives = CoreCaseAlternatives Id DefBindee +> type DefCaseDefault = CoreCaseDefault Id DefBindee + +> type DefCoreArg = CoreArg DefBindee + +> data DefBindee +> = DefArgExpr DefExpr -- arbitrary expressions as argumemts +> | DefArgVar Id -- or just ids +> | Label DefExpr DefExpr -- labels for detecting cycles + + +Ok, I've cheated horribly here. Instead of defining a new data type +including the new Label construct, I've just defined a new +parameterisation of Core in which a variable can be one of {variable, +expression, label}. This gives us both arbitrary expressions on the +right hand side of application, in addition to the new Label +construct. + +The penalty for this is that expressions will have extra indirections +as compared with a new datatype. The saving is basically not having +to define a new datatype almost identical to Core. + +Because our parameterised datatype is a little too general (i.e. it +distinguishes expressions that we wish to equate), there are some +invariants that will be adhered to during the transformation. The +following are alternative representations for certain expressions. +The forms on the left are disallowed: + +CoVar (DefArgExpr e) == e +CoVarAtom (Label l e) == CoVarAtom (DefArgExpr (CoVar (Label l e))) + +For completeness, we should also have: + +CoVarAtom (DefArgVar v) == CoVarAtom (DefArgExpr (CoVar (DefArgVar v))) +CoLitAtom l == CoVarAtom (DefArgExpr (CoLit l)) + +In other words, atoms must all be of the form (CoVarAtom (DefArgExpr +_)) and the argument to a CoVar can only be Label or DefArgVar. + +> mkLabel :: DefExpr -> DefExpr -> DefExpr +> mkLabel l e = CoVar (Label l e) diff --git a/ghc/compiler/deforest/DefUtils.hi b/ghc/compiler/deforest/DefUtils.hi new file mode 100644 index 0000000..0baaa9c --- /dev/null +++ b/ghc/compiler/deforest/DefUtils.hi @@ -0,0 +1,44 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface DefUtils where +import CoreSyn(CoreAtom, CoreCaseAlternatives, CoreExpr) +import DefSyn(DefBindee) +import Id(Id) +import SplitUniq(SplitUniqSupply) +import TyVar(TyVar) +import UniType(UniType) +data RenameResult = NotRenaming | IsRenaming [(Id, Id)] | InconsistentRenaming [(Id, Id)] +atom2expr :: CoreAtom DefBindee -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +consistent :: [(Id, Id)] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +deforestable :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAEAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: DeforestInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo DoDeforest -> _!_ True [] []; _ORIG_ IdInfo Don'tDeforest -> _!_ False [] []; _NO_DEFLT_ } _N_} _F_ _ALWAYS_ \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> case ub of { _ALG_ _ORIG_ IdInfo DoDeforest -> _!_ True [] []; _ORIG_ IdInfo Don'tDeforest -> _!_ False [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +foldrSUs :: (a -> b -> SplitUniqSupply -> b) -> b -> [a] -> SplitUniqSupply -> b + {-# GHC_PRAGMA _A_ 3 _U_ 2212 _N_ _S_ "LLS" _N_ _N_ #-} +freeTyVars :: CoreExpr Id DefBindee -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +freeVars :: CoreExpr Id DefBindee -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isArgId :: Id -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAEAAA)L)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkDefLetrec :: [(a, CoreExpr a b)] -> CoreExpr a b -> CoreExpr a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +newDefId :: UniType -> SplitUniqSupply -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(ALA)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newTmpId :: UniType -> SplitUniqSupply -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(ALA)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rebindExpr :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "S" _N_ _N_ #-} +renameExprs :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> SplitUniqSupply -> RenameResult + {-# GHC_PRAGMA _A_ 2 _U_ 222 _N_ _S_ "SS" _N_ _N_ #-} +strip :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +stripAtom :: CoreAtom DefBindee -> CoreAtom DefBindee + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +stripCaseAlts :: CoreCaseAlternatives Id DefBindee -> CoreCaseAlternatives Id DefBindee + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +subst :: [(Id, CoreExpr Id DefBindee)] -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-} +union :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-} + diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs new file mode 100644 index 0000000..81752f9 --- /dev/null +++ b/ghc/compiler/deforest/DefUtils.lhs @@ -0,0 +1,622 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[DefUtils]{Miscellaneous Utility functions} + +>#include "HsVersions.h" + +> module DefUtils ( +> strip, stripAtom, stripCaseAlts, freeVars, renameExprs, rebindExpr, +> atom2expr, newDefId, newTmpId, deforestable, foldrSUs, +> mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..), +> isArgId +> ) +> where + +> import DefSyn +> import Def2Core -- tmp, for traces + +>#ifdef __HBC__ +> import Trace +>#endif + +> import AbsUniType ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy, +> extractTyVarsFromTy, TyVar, SigmaType(..) +> IF_ATTACK_PRAGMAS(COMMA cmpTyVar) +> ) +> import BasicLit ( BasicLit ) -- for Eq BasicLit +> import CoreSyn +> import Id ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId, +> getIdInfo, toplevelishId, getIdUniType, Id ) +> import IdEnv +> import IdInfo +> import Outputable +> import Pretty +> import PrimOps ( PrimOp ) -- for Eq PrimOp +> import SplitUniq +> import SrcLoc ( mkUnknownSrcLoc ) +> import TyVarEnv +> import Util + +----------------------------------------------------------------------------- +\susbsection{Strip} + +Implementation of the strip function. Strip is the identity on +expressions (recursing into subterms), but replaces each label with +its left hand side. The result is a term with no labels. + +> strip :: DefExpr -> DefExpr + +> strip e' = case e' of +> CoVar (DefArgExpr e) -> panic "DefUtils(strip): CoVar (DefExpr _)" +> CoVar (Label l e) -> l +> CoVar (DefArgVar v) -> e' +> CoLit l -> e' +> CoCon c ts es -> CoCon c ts (map stripAtom es) +> CoPrim op ts es -> CoPrim op ts (map stripAtom es) +> CoLam vs e -> CoLam vs (strip e) +> CoTyLam alpha e -> CoTyLam alpha (strip e) +> CoApp e v -> CoApp (strip e) (stripAtom v) +> CoTyApp e t -> CoTyApp (strip e) t +> CoCase e ps -> CoCase (strip e) (stripCaseAlts ps) +> CoLet (CoNonRec v e) e' -> CoLet (CoNonRec v (strip e)) (strip e') +> CoLet (CoRec bs) e -> +> CoLet (CoRec [ (v, strip e) | (v,e) <- bs ]) (strip e) +> CoSCC l e -> CoSCC l (strip e) + +> stripAtom :: DefAtom -> DefAtom +> stripAtom (CoVarAtom v) = CoVarAtom (stripArg v) +> stripAtom (CoLitAtom l) = CoLitAtom l -- XXX + +> stripArg :: DefBindee -> DefBindee +> stripArg (DefArgExpr e) = DefArgExpr (strip e) +> stripArg (Label l e) = panic "DefUtils(stripArg): Label _ _" +> stripArg (DefArgVar v) = panic "DefUtils(stripArg): DefArgVar _ _" + +> stripCaseAlts (CoAlgAlts as def) +> = CoAlgAlts (map stripAlgAlt as) (stripDefault def) +> stripCaseAlts (CoPrimAlts as def) +> = CoPrimAlts (map stripPrimAlt as) (stripDefault def) + +> stripAlgAlt (c, vs, e) = (c, vs, strip e) +> stripPrimAlt (l, e) = (l, strip e) + +> stripDefault CoNoDefault = CoNoDefault +> stripDefault (CoBindDefault v e) = CoBindDefault v (strip e) + +----------------------------------------------------------------------------- +\subsection{Free Variables} + +Find the free variables of an expression. With labels, we descend +into the left side since this is the only sensible thing to do. +Strictly speaking, for a term (Label l e), freeVars l == freeVars e, +but l is guranteed to be finite so we choose that one. + +> freeVars :: DefExpr -> [Id] +> freeVars e = free e [] +> where +> free e fvs = case e of +> CoVar (DefArgExpr e) -> +> panic "DefUtils(free): CoVar (DefExpr _)" +> CoVar (Label l e) -> free l fvs +> CoVar (DefArgVar v) +> | v `is_elem` fvs -> fvs +> | otherwise -> v : fvs +> where { is_elem = isIn "freeVars(deforest)" } +> CoLit l -> fvs +> CoCon c ts es -> foldr freeAtom fvs es +> CoPrim op ts es -> foldr freeAtom fvs es +> CoLam vs e -> free' vs (free e fvs) +> CoTyLam alpha e -> free e fvs +> CoApp e v -> free e (freeAtom v fvs) +> CoTyApp e t -> free e fvs +> CoCase e ps -> free e (freeCaseAlts ps fvs) +> CoLet (CoNonRec v e) e' -> free e (free' [v] (free e' fvs)) +> CoLet (CoRec bs) e -> free' vs (foldr free (free e fvs) es) +> where (vs,es) = unzip bs +> CoSCC l e -> free e fvs + +> free' :: [Id] -> [Id] -> [Id] +> free' vs fvs = filter (\x -> notElem x vs) fvs + +> freeAtom (CoVarAtom (DefArgExpr e)) fvs = free e fvs +> freeAtom (CoVarAtom (Label l e)) fvs +> = panic "DefUtils(free): CoVarAtom (Label _ _)" +> freeAtom (CoVarAtom (DefArgVar v)) fvs +> = panic "DefUtils(free): CoVarAtom (DefArgVar _ _)" +> freeAtom (CoLitAtom l) fvs = fvs + +> freeCaseAlts (CoAlgAlts as def) fvs +> = foldr freeAlgAlt (freeDefault def fvs) as +> freeCaseAlts (CoPrimAlts as def) fvs +> = foldr freePrimAlt (freeDefault def fvs) as +> +> freeAlgAlt (c, vs, e) fvs = free' vs (free e fvs) +> freePrimAlt (l, e) fvs = free e fvs + +> freeDefault CoNoDefault fvs = fvs +> freeDefault (CoBindDefault v e) fvs = free' [v] (free e fvs) + +----------------------------------------------------------------------------- +\subsection{Free Type Variables} + +> freeTyVars :: DefExpr -> [TyVar] +> freeTyVars e = free e [] +> where +> free e tvs = case e of +> CoVar (DefArgExpr e) -> +> panic "DefUtils(freeVars): CoVar (DefExpr _)" +> CoVar (Label l e) -> free l tvs +> CoVar (DefArgVar id) -> freeId id tvs +> CoLit l -> tvs +> CoCon c ts es -> foldr freeTy (foldr freeAtom tvs es) ts +> CoPrim op ts es -> foldr freeTy (foldr freeAtom tvs es) ts +> CoLam vs e -> foldr freeId (free e tvs) vs +> CoTyLam alpha e -> filter (/= alpha) (free e tvs) +> CoApp e v -> free e (freeAtom v tvs) +> CoTyApp e t -> free e (freeTy t tvs) +> CoCase e ps -> free e (freeCaseAlts ps tvs) +> CoLet (CoNonRec v e) e' -> free e (freeId v (free e' tvs)) +> CoLet (CoRec bs) e -> foldr freeBind (free e tvs) bs +> CoSCC l e -> free e tvs +> +> freeId id tvs = extractTyVarsFromTy (getIdUniType id) `union` tvs +> freeTy t tvs = extractTyVarsFromTy t `union` tvs +> freeBind (v,e) tvs = freeId v (free e tvs) + +> freeAtom (CoVarAtom (DefArgExpr e)) tvs = free e tvs +> freeAtom (CoVarAtom (Label l e)) tvs +> = panic "DefUtils(freeVars): CoVarAtom (Label _ _)" +> freeAtom (CoVarAtom (DefArgVar v)) tvs +> = panic "DefUtils(freeVars): CoVarAtom (DefArgVar _ _)" +> freeAtom (CoLitAtom l) tvs = tvs -- XXX + +> freeCaseAlts (CoAlgAlts as def) tvs +> = foldr freeAlgAlt (freeDefault def tvs) as +> freeCaseAlts (CoPrimAlts as def) tvs +> = foldr freePrimAlt (freeDefault def tvs) as + +> freeAlgAlt (c, vs, e) tvs = foldr freeId (free e tvs) vs +> freePrimAlt (l, e) tvs = free e tvs + +> freeDefault CoNoDefault tvs = tvs +> freeDefault (CoBindDefault v e) tvs = freeId v (free e tvs) + +----------------------------------------------------------------------------- +\subsection{Rebinding variables in an expression} + +Here is the code that renames all the bound variables in an expression +with new uniques. Free variables are left unchanged. + +> rebindExpr :: DefExpr -> SUniqSM DefExpr +> rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e + +> uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> SUniqSM DefExpr +> uniqueExpr p t e = +> case e of +> CoVar (DefArgVar v) -> +> returnSUs (CoVar (DefArgVar (lookup v p))) +> +> CoVar (Label l e) -> +> uniqueExpr p t l `thenSUs` \l -> +> uniqueExpr p t e `thenSUs` \e -> +> returnSUs (mkLabel l e) +> +> CoVar (DefArgExpr _) -> +> panic "DefUtils(uniqueExpr): CoVar(DefArgExpr _)" +> +> CoLit l -> +> returnSUs e +> +> CoCon c ts es -> +> mapSUs (uniqueAtom p t) es `thenSUs` \es -> +> returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es) +> +> CoPrim op ts es -> +> mapSUs (uniqueAtom p t) es `thenSUs` \es -> +> returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es) +> +> CoLam vs e -> +> mapSUs (newVar t) vs `thenSUs` \vs' -> +> uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenSUs` \e -> +> returnSUs (CoLam vs' e) +> +> CoTyLam v e -> +> getSUnique `thenSUs` \u -> +> let v' = cloneTyVar v u +> t' = addOneToTyVarEnv t v (mkTyVarTy v') in +> uniqueExpr p t' e `thenSUs` \e -> +> returnSUs (CoTyLam v' e) +> +> CoApp e v -> +> uniqueExpr p t e `thenSUs` \e -> +> uniqueAtom p t v `thenSUs` \v -> +> returnSUs (CoApp e v) +> +> CoTyApp e ty -> +> uniqueExpr p t e `thenSUs` \e -> +> returnSUs (mkCoTyApp e (applyTypeEnvToTy t ty)) +> +> CoCase e alts -> +> uniqueExpr p t e `thenSUs` \e -> +> uniqueAlts alts `thenSUs` \alts -> +> returnSUs (CoCase e alts) +> where +> uniqueAlts (CoAlgAlts as d) = +> mapSUs uniqueAlgAlt as `thenSUs` \as -> +> uniqueDefault d `thenSUs` \d -> +> returnSUs (CoAlgAlts as d) +> uniqueAlts (CoPrimAlts as d) = +> mapSUs uniquePrimAlt as `thenSUs` \as -> +> uniqueDefault d `thenSUs` \d -> +> returnSUs (CoPrimAlts as d) +> +> uniqueAlgAlt (c, vs, e) = +> mapSUs (newVar t) vs `thenSUs` \vs' -> +> uniqueExpr (growIdEnvList p (zip vs vs')) t e +> `thenSUs` \e -> +> returnSUs (c, vs', e) +> uniquePrimAlt (l, e) = +> uniqueExpr p t e `thenSUs` \e -> +> returnSUs (l, e) +> +> uniqueDefault CoNoDefault = returnSUs CoNoDefault +> uniqueDefault (CoBindDefault v e) = +> newVar t v `thenSUs` \v' -> +> uniqueExpr (addOneToIdEnv p v v') t e `thenSUs` \e -> +> returnSUs (CoBindDefault v' e) +> +> CoLet (CoNonRec v e) e' -> +> uniqueExpr p t e `thenSUs` \e -> +> newVar t v `thenSUs` \v' -> +> uniqueExpr (addOneToIdEnv p v v') t e' `thenSUs` \e' -> +> returnSUs (CoLet (CoNonRec v' e) e') +> +> CoLet (CoRec ds) e -> +> let (vs,es) = unzip ds in +> mapSUs (newVar t) vs `thenSUs` \vs' -> +> let p' = growIdEnvList p (zip vs vs') in +> mapSUs (uniqueExpr p' t) es `thenSUs` \es -> +> uniqueExpr p' t e `thenSUs` \e -> +> returnSUs (CoLet (CoRec (zip vs' es)) e) +> +> CoSCC l e -> +> uniqueExpr p t e `thenSUs` \e -> +> returnSUs (CoSCC l e) +> +> +> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> SUniqSM DefAtom +> uniqueAtom p t (CoLitAtom l) = returnSUs (CoLitAtom l) -- XXX +> uniqueAtom p t (CoVarAtom v) = +> uniqueArg p t v `thenSUs` \v -> +> returnSUs (CoVarAtom v) +> +> uniqueArg p t (DefArgVar v) = +> panic "DefUtils(uniqueArg): DefArgVar _ _" +> uniqueArg p t (DefArgExpr e) = +> uniqueExpr p t e `thenSUs` \e -> +> returnSUs (DefArgExpr e) +> uniqueArg p t (Label l e) = +> panic "DefUtils(uniqueArg): Label _ _" + +We shouldn't need to apply the type environment to free variables, +since their types can only contain type variables that are free in the +expression as a whole (?) + +> lookup :: Id -> IdEnv Id -> Id +> lookup id p = +> case lookupIdEnv p id of +> Nothing -> id +> Just new_id -> new_id + +> newVar :: TypeEnv -> Id -> SUniqSM Id +> newVar t id = +> getSUnique `thenSUs` \u -> +> returnSUs (mkIdWithNewUniq (applyTypeEnvToId t id) u) + +----------------------------------------------------------------------------- +\subsection{Detecting Renamings} + +The function `renameExprs' takes two expressions and returns True if +they are renamings of each other. The variables in the list `fs' are +excluded from the renaming process (i.e. if any of these variables +are present in one expression, they cannot be renamed in the other +expression). + +We only allow renaming of sysLocal ids - ie. not top-level, imported +or otherwise global ids. + +> data RenameResult +> = NotRenaming +> | IsRenaming [(Id,Id)] +> | InconsistentRenaming [(Id,Id)] + +> renameExprs :: DefExpr -> DefExpr -> SUniqSM RenameResult +> renameExprs u u' = +> case ren u u' of +> [] -> returnSUs NotRenaming +> [r] -> if not (consistent r) then +> d2c (strip u) `thenSUs` \u -> +> d2c (strip u') `thenSUs` \u' -> +> trace ("failed consistency check:\n" ++ +> ppShow 80 (ppr PprDebug u) ++ "\n" ++ +> ppShow 80 (ppr PprDebug u')) +> (returnSUs (InconsistentRenaming r)) +> else +> trace "Renaming!" (returnSUs (IsRenaming r)) +> _ -> panic "DefUtils(renameExprs)" + +Check that we have a consistent renaming. A renaming is consistent if +each time variable x in expression 1 is renamed, it is renamed to the +same variable. + +> consistent :: [(Id,Id)] -> Bool +> consistent rs = and [ y == y' | (x,y) <- rs, (x',y') <- rs, x == x' ] + +> checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]] +> checkConsistency bound free = [ r' | r <- free, r' <- check r ] +> where +> check r | they're_consistent = [frees] +> | otherwise = [] +> where +> (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r +> (lbound,rbound) = unzip bound +> they're_consistent = consistent (bound ++ bounds) + +Renaming composition operator. + +> (....) :: [[a]] -> [[a]] -> [[a]] +> r .... r' = [ xs ++ xs' | xs <- r, xs' <- r' ] + +The class of identifiers which can be renamed. It is sensible to +disallow renamings of deforestable ids, but the top-level ones are a +bit iffy. Ideally, we should allow renaming of top-level ids, but the +current scheme allows us to leave out the top-level ids from the +argument lists of new function definitions. (we still have the +shadowed ones to worry about..) + +Main renaming function. Returns a list of renamings made while +comparing the expressions. + +> ren :: DefExpr -> DefExpr -> [[(Id,Id)]] +> +> -- renaming or identical cases -- +> +> +> -- same variable, no renaming +> ren (CoVar (DefArgVar x)) t@(CoVar (DefArgVar y)) +> | x == y = [[(x,y)]] +> | isArgId x && isArgId y = [[(x,y)]] +> +> -- if we're doing matching, use the next rule, +> -- and delete the second clause in the above rule. +> {- +> ren (CoVar (DefArgVar x)) t +> | okToRename x && all (not. deforestable) (freeVars t) +> = [[(x,t)]] +> -} + +> ren (CoLit l) (CoLit l') | l == l' +> = [[]] +> ren (CoCon c ts es) (CoCon c' ts' es') | c == c' +> = foldr (....) [[]] (zipWith renAtom es es') +> ren (CoPrim op ts es) (CoPrim op' ts' es') | op == op' +> = foldr (....) [[]] (zipWith renAtom es es') +> ren (CoLam vs e) (CoLam vs' e') +> = checkConsistency (zip vs vs') (ren e e') +> ren (CoTyLam vs e) (CoTyLam vs' e') +> = ren e e' -- XXX! +> ren (CoApp e v) (CoApp e' v') +> = ren e e' .... renAtom v v' +> ren (CoTyApp e t) (CoTyApp e' t') +> = ren e e' -- XXX! +> ren (CoCase e alts) (CoCase e' alts') +> = ren e e' .... renAlts alts alts' +> ren (CoLet (CoNonRec v a) b) (CoLet (CoNonRec v' a') b') +> = ren a a' .... (checkConsistency [(v,v')] (ren b b')) +> ren (CoLet (CoRec ds) e) (CoLet (CoRec ds') e') +> = checkConsistency (zip vs vs') +> (ren e e' .... (foldr (....) [[]] (zipWith ren es es'))) +> where (vs ,es ) = unzip ds +> (vs',es') = unzip ds' +> +> -- label cases -- +> +> ren (CoVar (Label l e)) e' = ren l e' +> ren e (CoVar (Label l e')) = ren e l +> +> -- error cases -- +> +> ren (CoVar (DefArgExpr _)) _ +> = panic "DefUtils(ren): CoVar (DefArgExpr _)" +> ren _ (CoVar (DefArgExpr _)) +> = panic "DefUtils(ren): CoVar (DefArgExpr _)" +> +> -- default case -- +> +> ren _ _ = [] + +Rename atoms. + +> renAtom (CoVarAtom (DefArgExpr e)) (CoVarAtom (DefArgExpr e')) +> = ren e e' +> -- XXX shouldn't need the next two +> renAtom (CoLitAtom l) (CoLitAtom l') | l == l' = [[]] +> renAtom (CoVarAtom (DefArgVar v)) _ = +> panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)" +> renAtom _ (CoVarAtom (DefArgVar v)) = +> panic "DefUtils(renAtom): CoVarAtom (DefArgVar _ _)" +> renAtom (CoVarAtom (Label _ _)) _ = +> panic "DefUtils(renAtom): CoVarAtom (Label _ _)" +> renAtom e (CoVarAtom (Label l e')) = +> panic "DefUtils(renAtom): CoVarAtom (Label _ _)" +> +> renAtom _ _ = [] + +Renamings of case alternatives doesn't allow reordering, but that +should be Ok (we don't ever change the ordering anyway). + +> renAlts (CoAlgAlts as dflt) (CoAlgAlts as' dflt') +> = foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt' +> renAlts (CoPrimAlts as dflt) (CoPrimAlts as' dflt') +> = foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt' +> renAlts _ _ = [] +> +> renAlgAlt (c,vs,e) (c',vs',e') | c == c' +> = checkConsistency (zip vs vs') (ren e e') +> renAlgAlt _ _ = [] +> +> renPrimAlt (l,e) (l',e') | l == l' = ren e e' +> renPrimAlt _ _ = [] +> +> renDefault CoNoDefault CoNoDefault = [[]] +> renDefault (CoBindDefault v e) (CoBindDefault v' e') +> = checkConsistency [(v,v')] (ren e e') + +----------------------------------------------------------------------------- + +> atom2expr :: DefAtom -> DefExpr +> atom2expr (CoVarAtom (DefArgExpr e)) = e +> atom2expr (CoVarAtom (Label l e)) = mkLabel l e +> -- XXX next two should be illegal +> atom2expr (CoLitAtom l) = CoLit l +> atom2expr (CoVarAtom (DefArgVar v)) = +> panic "DefUtils(atom2expr): CoVarAtom (DefArgVar _)" + +> expr2atom = CoVarAtom . DefArgExpr + +----------------------------------------------------------------------------- +Grab a new Id and tag it as coming from the Deforester. + +> newDefId :: UniType -> SUniqSM Id +> newDefId t = +> getSUnique `thenSUs` \u -> +> returnSUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc) + +> newTmpId :: UniType -> SUniqSM Id +> newTmpId t = +> getSUnique `thenSUs` \u -> +> returnSUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc) + +----------------------------------------------------------------------------- +Check whether an Id was given a `DEFOREST' annotation by the programmer. + +> deforestable :: Id -> Bool +> deforestable id = +> case getInfo (getIdInfo id) of +> DoDeforest -> True +> Don'tDeforest -> False + +----------------------------------------------------------------------------- +Filter for free variables to abstract from new functions. + +> isArgId id +> = (not . deforestable) id +> && (not . toplevelishId) id + +----------------------------------------------------------------------------- + +> foldrSUs f c [] = returnSUs c +> foldrSUs f c (x:xs) +> = foldrSUs f c xs `thenSUs` \xs' -> +> f x xs' + +----------------------------------------------------------------------------- + +> mkDefLetrec [] e = e +> mkDefLetrec bs e = CoLet (CoRec bs) e + +----------------------------------------------------------------------------- +Substitutions. + +> subst :: [(Id,DefExpr)] +> -> DefExpr +> -> SUniqSM DefExpr + +> subst p e' = sub e' +> where +> p' = mkIdEnv p +> sub e' = case e' of +> CoVar (DefArgExpr e) -> panic "DefExpr(sub): CoVar (DefArgExpr _)" +> CoVar (Label l e) -> panic "DefExpr(sub): CoVar (Label _ _)" +> CoVar (DefArgVar v) -> +> case lookupIdEnv p' v of +> Just e -> rebindExpr e `thenSUs` \e -> returnSUs e +> Nothing -> returnSUs e' +> CoLit l -> returnSUs e' +> CoCon c ts es -> mapSUs substAtom es `thenSUs` \es -> +> returnSUs (CoCon c ts es) +> CoPrim op ts es -> mapSUs substAtom es `thenSUs` \es -> +> returnSUs (CoPrim op ts es) +> CoLam vs e -> sub e `thenSUs` \e -> +> returnSUs (CoLam vs e) +> CoTyLam alpha e -> sub e `thenSUs` \e -> +> returnSUs (CoTyLam alpha e) +> CoApp e v -> sub e `thenSUs` \e -> +> substAtom v `thenSUs` \v -> +> returnSUs (CoApp e v) +> CoTyApp e t -> sub e `thenSUs` \e -> +> returnSUs (CoTyApp e t) +> CoCase e ps -> sub e `thenSUs` \e -> +> substCaseAlts ps `thenSUs` \ps -> +> returnSUs (CoCase e ps) +> CoLet (CoNonRec v e) e' +> -> sub e `thenSUs` \e -> +> sub e' `thenSUs` \e' -> +> returnSUs (CoLet (CoNonRec v e) e') +> CoLet (CoRec bs) e -> sub e `thenSUs` \e -> +> mapSUs substBind bs `thenSUs` \bs -> +> returnSUs (CoLet (CoRec bs) e) +> where +> substBind (v,e) = +> sub e `thenSUs` \e -> +> returnSUs (v,e) +> CoSCC l e -> sub e `thenSUs` \e -> +> returnSUs (CoSCC l e) + +> substAtom (CoVarAtom v) = +> substArg v `thenSUs` \v -> +> returnSUs (CoVarAtom v) +> substAtom (CoLitAtom l) = +> returnSUs (CoLitAtom l) -- XXX + +> substArg (DefArgExpr e) = +> sub e `thenSUs` \e -> +> returnSUs (DefArgExpr e) +> substArg e@(Label _ _) = +> panic "DefExpr(substArg): Label _ _" +> substArg e@(DefArgVar v) = -- XXX +> case lookupIdEnv p' v of +> Just e -> rebindExpr e `thenSUs` \e -> +> returnSUs (DefArgExpr e) +> Nothing -> returnSUs e + +> substCaseAlts (CoAlgAlts as def) = +> mapSUs substAlgAlt as `thenSUs` \as -> +> substDefault def `thenSUs` \def -> +> returnSUs (CoAlgAlts as def) +> substCaseAlts (CoPrimAlts as def) = +> mapSUs substPrimAlt as `thenSUs` \as -> +> substDefault def `thenSUs` \def -> +> returnSUs (CoPrimAlts as def) + +> substAlgAlt (c, vs, e) = +> sub e `thenSUs` \e -> +> returnSUs (c, vs, e) +> substPrimAlt (l, e) = +> sub e `thenSUs` \e -> +> returnSUs (l, e) + +> substDefault CoNoDefault = +> returnSUs CoNoDefault +> substDefault (CoBindDefault v e) = +> sub e `thenSUs` \e -> +> returnSUs (CoBindDefault v e) + +----------------------------------------------------------------------------- + +> union [] ys = ys +> union (x:xs) ys +> | x `is_elem` ys = union xs ys +> | otherwise = x : union xs ys +> where { is_elem = isIn "union(deforest)" } diff --git a/ghc/compiler/deforest/Deforest.hi b/ghc/compiler/deforest/Deforest.hi new file mode 100644 index 0000000..a985820 --- /dev/null +++ b/ghc/compiler/deforest/Deforest.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Deforest where +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreBinding) +import Id(Id) +import SplitUniq(SplitUniqSupply) +deforestProgram :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLU(ALL)" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/deforest/Deforest.lhs b/ghc/compiler/deforest/Deforest.lhs new file mode 100644 index 0000000..623750a --- /dev/null +++ b/ghc/compiler/deforest/Deforest.lhs @@ -0,0 +1,140 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[Deforest]{Top level deforestation module} + +>#include "HsVersions.h" +> +> module Deforest ( +> deforestProgram +> ) where + +> import Core2Def +> import Def2Core +> import DefUtils +> import DefSyn +> import DefExpr +> import Cyclic +> import TreelessForm +>#ifdef __HBC__ +> import Trace +>#endif + +> import CmdLineOpts ( GlobalSwitch, SwitchResult ) +> import CoreSyn +> import Id ( getIdInfo, Id ) +> import IdEnv +> import IdInfo +> import Outputable +> import SimplEnv ( SwitchChecker(..) ) +> import SplitUniq +> import TyVarEnv +> import Util + +> -- tmp, for traces +> import Pretty + +> -- stub (ToDo) +> domIdEnv = panic "Deforest: domIdEnv" + +> deforestProgram +> :: SwitchChecker GlobalSwitch{-maybe-} +> -> PlainCoreProgram +> -> SplitUniqSupply +> -> PlainCoreProgram +> +> deforestProgram sw prog uq = +> let +> def_program = core2def sw prog +> out_program = ( +> defProg sw nullIdEnv def_program `thenSUs` \prog -> +> def2core prog) +> uq +> in +> out_program + +We have to collect all the unfoldings (functions that were annotated +with DEFOREST) and pass them in an environment to subsequent calls of +the transformer. + +Recursive functions are first transformed by the deforester. If the +function is annotated as deforestable, then it is converted to +treeless form for unfolding later on. + +Also converting non-recursive functions that are annotated with +{-# DEFOREST #-} now. Probably don't need to convert these to treeless +form: just the inner recursive bindings they contain. eg: + +repeat = \x -> letrec xs = x:xs in xs + +is non-recursive, but we want to unfold it and annotate the binding +for xs as unfoldable, too. + +> defProg +> :: SwitchChecker GlobalSwitch{-maybe-} +> -> IdEnv DefExpr +> -> [DefBinding] +> -> SUniqSM [DefBinding] +> +> defProg sw p [] = returnSUs [] +> +> defProg sw p (CoNonRec v e : bs) = +> trace ("Processing: `" ++ +> ppShow 80 (ppr PprDebug v) ++ "'\n") ( +> tran sw p nullTyVarEnv e [] `thenSUs` \e -> +> mkLoops e `thenSUs` \(extracted,e) -> +> let e' = mkDefLetrec extracted e in +> ( +> if deforestable v then +> let (vs,es) = unzip extracted in +> convertToTreelessForm sw e `thenSUs` \e -> +> mapSUs (convertToTreelessForm sw) es `thenSUs` \es -> +> defProg sw (growIdEnvList p ((v,e):zip vs es)) bs +> else +> defProg sw p bs +> ) `thenSUs` \bs -> +> returnSUs (CoNonRec v e' : bs) +> ) +> +> defProg sw p (CoRec bs : bs') = +> mapSUs (defRecBind sw p) bs `thenSUs` \res -> +> let +> (resid, unfold) = unzip res +> p' = growIdEnvList p (concat unfold) +> in +> defProg sw p' bs' `thenSUs` \bs' -> +> returnSUs (CoRec resid: bs') + + +> defRecBind +> :: SwitchChecker GlobalSwitch{-maybe-} +> -> IdEnv DefExpr +> -> (Id,DefExpr) +> -> SUniqSM ((Id,DefExpr),[(Id,DefExpr)]) +> +> defRecBind sw p (v,e) = +> trace ("Processing: `" ++ +> ppShow 80 (ppr PprDebug v) ++ "'\n") ( +> tran sw p nullTyVarEnv e [] `thenSUs` \e' -> +> mkLoops e' `thenSUs` \(bs,e') -> +> let e'' = mkDefLetrec bs e' in +> +> d2c e'' `thenSUs` \core_e -> +> let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ +> "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n" +> in +> trace ("Extracting from `" ++ +> ppShow 80 (ppr PprDebug v) ++ "'\n" +> ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $ +> +> if deforestable v +> then +> let (vs,es) = unzip bs in +> convertToTreelessForm sw e' `thenSUs` \e' -> +> mapSUs (convertToTreelessForm sw) es `thenSUs` \es -> +> returnSUs ((v,e''),(v,e'):zip vs es) +> else +> trace (show (length bs)) ( +> returnSUs ((v,e''),[]) +> ) +> ) diff --git a/ghc/compiler/deforest/TreelessForm.hi b/ghc/compiler/deforest/TreelessForm.hi new file mode 100644 index 0000000..f043c61 --- /dev/null +++ b/ghc/compiler/deforest/TreelessForm.hi @@ -0,0 +1,10 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TreelessForm where +import CmdLineOpts(SwitchResult) +import CoreSyn(CoreExpr) +import DefSyn(DefBindee) +import Id(Id) +import SplitUniq(SplitUniqSupply) +convertToTreelessForm :: (a -> SwitchResult) -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee + {-# GHC_PRAGMA _A_ 2 _U_ 012 _N_ _S_ "AS" {_A_ 1 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs new file mode 100644 index 0000000..88a6dee --- /dev/null +++ b/ghc/compiler/deforest/TreelessForm.lhs @@ -0,0 +1,189 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TreelessForm]{Convert Arbitrary expressions into treeless form} + +>#include "HsVersions.h" +> +> module TreelessForm ( +> convertToTreelessForm +> ) where +> +> import DefSyn +> import PlainCore +> import DefUtils + +> import CoreFuns ( typeOfCoreExpr ) +> import IdEnv +> import CmdLineOpts ( SwitchResult, switchIsOn ) +> import SplitUniq +> import SimplEnv ( SwitchChecker(..) ) +> import Maybes ( Maybe(..) ) +> import Id ( replaceIdInfo, getIdInfo ) +> import IdInfo +> import Util +> import Outputable + + +> -- tmp +> import Pretty +> import Def2Core + +Very simplistic approach to begin with: + +case e of {...} ====> let x = e in case x of {...} +x e1 ... en ====> let x1 = e1 in ... let xn = en in (x x1 ... xn) + +ToDo: make this better. + +> convertToTreelessForm +> :: SwitchChecker sw +> -> DefExpr +> -> SUniqSM DefExpr +> +> convertToTreelessForm sw e +> = convExpr e +> +> convExpr +> :: DefExpr +> -> SUniqSM DefExpr + +> convExpr e = case e of +> +> CoVar (DefArgExpr e) -> +> panic "TreelessForm(substTy): CoVar (DefArgExpr _)" +> +> CoVar (Label l e) -> +> panic "TreelessForm(substTy): CoVar (Label _ _)" +> +> CoVar (DefArgVar id) -> returnSUs e +> +> CoLit l -> returnSUs e +> +> CoCon c ts es -> +> mapSUs convAtom es `thenSUs` \es -> +> returnSUs (CoCon c ts es) +> +> CoPrim op ts es -> +> mapSUs convAtom es `thenSUs` \es -> +> returnSUs (CoPrim op ts es) +> +> CoLam vs e -> +> convExpr e `thenSUs` \e -> +> returnSUs (CoLam vs e) +> +> CoTyLam alpha e -> +> convExpr e `thenSUs` \e -> +> returnSUs (CoTyLam alpha e) +> +> CoApp e v -> +> convExpr e `thenSUs` \e -> +> case v of +> CoLitAtom l -> returnSUs (CoApp e v) +> CoVarAtom v' -> +> case v' of +> DefArgVar _ -> panic "TreelessForm(convExpr): DefArgVar" +> DefArgExpr (CoVar (DefArgVar id)) +> | (not.deforestable) id -> +> returnSUs (CoApp e v) +> DefArgExpr e' -> +> newLet e' (\id -> CoApp e (CoVarAtom +> (DefArgExpr id))) +> +> CoTyApp e ty -> +> convExpr e `thenSUs` \e -> +> returnSUs (CoTyApp e ty) +> +> CoCase e ps -> +> convCaseAlts ps `thenSUs` \ps -> +> case e of +> CoVar (DefArgVar id) | (not.deforestable) id -> +> returnSUs (CoCase e ps) +> CoPrim op ts es -> returnSUs (CoCase e ps) +> _ -> d2c e `thenSUs` \e' -> +> newLet e (\v -> CoCase v ps) +> +> CoLet (CoNonRec id e) e' -> +> convExpr e `thenSUs` \e -> +> convExpr e' `thenSUs` \e' -> +> returnSUs (CoLet (CoNonRec id e) e') +> +> CoLet (CoRec bs) e -> +>-- convRecBinds bs e `thenSUs` \(bs,e) -> +>-- returnSUs (CoLet (CoRec bs) e) +> convExpr e `thenSUs` \e -> +> mapSUs convRecBind bs `thenSUs` \bs -> +> returnSUs (CoLet (CoRec bs) e) +> where +> convRecBind (v,e) = +> convExpr e `thenSUs` \e -> +> returnSUs (v,e) +> +> CoSCC l e -> +> convExpr e `thenSUs` \e -> +> returnSUs (CoSCC l e) + +Mark all the recursive functions as deforestable. Might as well, +since they will be in treeless form anyway. This helps to cope with +overloaded functions, where the compiler earlier lifts out the +dictionary deconstruction. + +> convRecBinds bs e = +> convExpr e `thenSUs` \e' -> +> mapSUs convExpr es `thenSUs` \es' -> +> mapSUs (subst s) es' `thenSUs` \es'' -> +> subst s e' `thenSUs` \e'' -> +> returnSUs (zip vs' es', e') +> where +> (vs,es) = unzip bs +> vs' = map mkDeforestable vs +> s = zip vs (map (CoVar . DefArgVar) vs') +> mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest) + +> convAtom :: DefAtom -> SUniqSM DefAtom +> +> convAtom (CoVarAtom v) = +> convArg v `thenSUs` \v -> +> returnSUs (CoVarAtom v) +> convAtom (CoLitAtom l) = +> returnSUs (CoLitAtom l) -- XXX + +> convArg :: DefBindee -> SUniqSM DefBindee +> +> convArg (DefArgExpr e) = +> convExpr e `thenSUs` \e -> +> returnSUs (DefArgExpr e) +> convArg e@(Label _ _) = +> panic "TreelessForm(convArg): Label _ _" +> convArg e@(DefArgVar id) = +> panic "TreelessForm(convArg): DefArgVar _ _" + +> convCaseAlts :: DefCaseAlternatives -> SUniqSM DefCaseAlternatives +> +> convCaseAlts (CoAlgAlts as def) = +> mapSUs convAlgAlt as `thenSUs` \as -> +> convDefault def `thenSUs` \def -> +> returnSUs (CoAlgAlts as def) +> convCaseAlts (CoPrimAlts as def) = +> mapSUs convPrimAlt as `thenSUs` \as -> +> convDefault def `thenSUs` \def -> +> returnSUs (CoPrimAlts as def) + +> convAlgAlt (c, vs, e) = +> convExpr e `thenSUs` \e -> +> returnSUs (c, vs, e) +> convPrimAlt (l, e) = +> convExpr e `thenSUs` \e -> +> returnSUs (l, e) + +> convDefault CoNoDefault = +> returnSUs CoNoDefault +> convDefault (CoBindDefault id e) = +> convExpr e `thenSUs` \e -> +> returnSUs (CoBindDefault id e) + +> newLet :: DefExpr -> (DefExpr -> DefExpr) -> SUniqSM DefExpr +> newLet e body = +> d2c e `thenSUs` \core_expr -> +> newDefId (typeOfCoreExpr core_expr) `thenSUs` \new_id -> +> returnSUs (CoLet (CoNonRec new_id e) (body (CoVar (DefArgVar new_id)))) diff --git a/ghc/compiler/envs/CE.hi b/ghc/compiler/envs/CE.hi new file mode 100644 index 0000000..1a2001a --- /dev/null +++ b/ghc/compiler/envs/CE.hi @@ -0,0 +1,51 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CE where +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import Id(Id) +import InstEnv(InstTemplate) +import Maybes(MaybeErr) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM) +import Unique(Unique, u2i) +type CE = UniqFM Class +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +checkClassCycles :: UniqFM Class -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +lookupCE :: UniqFM Class -> Name -> Class + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +nullCE :: UniqFM Class + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [Class] [] _N_ #-} +plusCE :: UniqFM Class -> UniqFM Class -> UniqFM Class + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM plusUFM { Class } _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +rngCE :: UniqFM Class -> [Class] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM eltsUFM { Class } _N_ #-} +singletonDirectlyUFM :: Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +unitCE :: Unique -> Class -> UniqFM Class + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int#) (u1 :: Class) -> _!_ _ORIG_ UniqFM LeafUFM [Class] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: Unique) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [Class] [u2, u1]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/envs/CE.lhs b/ghc/compiler/envs/CE.lhs new file mode 100644 index 0000000..d1e4ea7 --- /dev/null +++ b/ghc/compiler/envs/CE.lhs @@ -0,0 +1,90 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[CE]{Class environment} + +\begin{code} +#include "HsVersions.h" + +module CE ( + CE(..), + nullCE, unitCE, rngCE, + plusCE, lookupCE, + checkClassCycles, + + -- imported things so we're self-contained... + Unique, UniqFM, + Class, MaybeErr, Name, Pretty(..), PprStyle, + PrettyRep, Error(..) + + IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM) + IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM) + IF_ATTACK_PRAGMAS(COMMA u2i) + ) where + +import AbsUniType ( getClassSig, Class, ClassOp, TyCon, FullName, Arity(..) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + ) +import Digraph ( topologicalSort ) +import Errors -- notably classCycleErr +import UniqFM -- basic environment handling +import Maybes ( Maybe(..), MaybeErr(..) ) +import Name -- Name(..), etc. +import Pretty +import Outputable -- def of ppr +import Unique -- for ClassKey uniques +import Util +\end{code} + +%************************************************************************ +%* * +%* The main representation * +%* * +%************************************************************************ + +\begin{code} +--data CE = MkCE (FiniteMap Unique Class) -- keyed off Class's Uniques +type CE = UniqFM Class +#define MkCE {--} +-- also killed instance CE, exported non-abstractly + +nullCE :: CE +nullCE = MkCE emptyUFM + +rngCE :: CE -> [Class] +rngCE (MkCE env) = eltsUFM env + +unitCE :: Unique{-ClassKey-} -> Class -> CE +unitCE u c = MkCE (singletonDirectlyUFM u c) + +plusCE :: CE -> CE -> CE +plusCE (MkCE ce1) (MkCE ce2) = MkCE (plusUFM ce1 ce2) + +lookupCE :: CE -> Name -> Class +lookupCE (MkCE ce) name + = case name of + PreludeClass key _ -> case (lookupDirectlyUFM ce key) of + Just clas -> clas + Nothing -> err_msg + OtherClass uniq _ _ -> case (lookupDirectlyUFM ce uniq) of + Just clas -> clas + Nothing -> panic "lookupCE! (non-prelude)" + where + err_msg = error ("ERROR: in looking up a Prelude class! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)\n") + +checkClassCycles :: CE -> MaybeErr () Error +checkClassCycles (MkCE stuff) + = case (topologicalSort (==) edges classes) of + Succeeded _ -> Succeeded () + Failed cycles + -> Failed (classCycleErr [ map fmt_tycon c | c <- cycles ]) + where + fmt_tycon c = (ppr PprForUser c, getSrcLoc c) + where + classes = eltsUFM stuff -- the "vertices" + edges = concat (map get_edges classes) + + get_edges clas + = let (_, super_classes, _) = getClassSig clas in + [ (clas, super_class) | super_class <- super_classes ] +\end{code} diff --git a/ghc/compiler/envs/E.hi b/ghc/compiler/envs/E.hi new file mode 100644 index 0000000..983265b --- /dev/null +++ b/ghc/compiler/envs/E.hi @@ -0,0 +1,65 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface E where +import CE(CE(..)) +import Class(Class) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import TCE(TCE(..)) +import TyCon(TyCon) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +type CE = UniqFM Class +data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-} +type GVE = [(Name, Id)] +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type LVE = [(Name, Id)] +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +type TCE = UniqFM TyCon +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +getE_CE :: E -> UniqFM Class + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM Class) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: E) -> case u0 of { _ALG_ _ORIG_ E MkE (u1 :: UniqFM TyCon) (u2 :: UniqFM Id) (u3 :: UniqFM Id) (u4 :: UniqFM Class) -> u4; _NO_DEFLT_ } _N_ #-} +getE_GlobalVals :: E -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASLA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getE_TCE :: E -> UniqFM TyCon + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM TyCon) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: E) -> case u0 of { _ALG_ _ORIG_ E MkE (u1 :: UniqFM TyCon) (u2 :: UniqFM Id) (u3 :: UniqFM Id) (u4 :: UniqFM Class) -> u1; _NO_DEFLT_ } _N_ #-} +growE_LVE :: E -> [(Name, Id)] -> E + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupE_Binder :: E -> Name -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AASA)S" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupE_ClassOpByKey :: E -> Unique -> _PackedString -> Id + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAS)LL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupE_Value :: E -> Name -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLA)S" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupE_ValueQuietly :: E -> Name -> Labda Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLA)S" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkE :: UniqFM TyCon -> UniqFM Class -> E + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +nullE :: E + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +nullGVE :: [(Name, Id)] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(Name, Id)] [] _N_ #-} +nullLVE :: [(Name, Id)] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(Name, Id)] [] _N_ #-} +plusE_CE :: E -> UniqFM Class -> E + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +plusE_GVE :: E -> [(Name, Id)] -> E + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +plusE_TCE :: E -> UniqFM TyCon -> E + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +plusGVE :: [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludeList (++) _N_ #-} +plusLVE :: [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludeList (++) _N_ #-} +tvOfE :: E -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AASA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +unitGVE :: Name -> Id -> [(Name, Id)] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/envs/E.lhs b/ghc/compiler/envs/E.lhs new file mode 100644 index 0000000..c0c8b0f --- /dev/null +++ b/ghc/compiler/envs/E.lhs @@ -0,0 +1,268 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[E]{Main typechecker environment} + +\begin{code} +#include "HsVersions.h" + +module E ( + E, + mkE, nullE, + getE_GlobalVals, getE_TCE, getE_CE, + plusE_TCE, plusE_CE, + + growE_LVE, plusE_GVE, tvOfE, + + lookupE_Value, lookupE_ValueQuietly, + lookupE_ClassOpByKey, lookupE_Binder, + + GVE(..), LVE(..), + plusLVE, nullLVE, + plusGVE, nullGVE, unitGVE, -- UNUSED: rngGVE, + + -- and to make the interface self-sufficient... + CE(..), Id, Name, TCE(..), TyVar, Maybe, UniqFM + ) where + +import CE +import TCE +import UniqFM -- basic env handling code + +import AbsPrel ( PrimOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( getClassOps, extractTyVarsFromTy, + getClassBigSig, getClassOpString, TyVar, + TyVarTemplate, ClassOp, Class, Arity(..), + TauType(..) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass) + ) +import Id ( getIdUniType, Id, IdInfo ) +import Maybes ( MaybeErr(..), Maybe(..) ) +import Name -- Name(..), etc. +import Outputable -- def of ppr, etc. +import Pretty -- to pretty-print error messages +import UniqSet -- this use of Sets is a HACK (WDP 94/05) +import Unique -- *Key stuff +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection{Type declarations} +%* * +%************************************************************************ + + +\begin{code} +data E + = MkE TCE -- type environment + GVB -- "global" value bindings; no free type vars + LVB -- "local" value bindings; may have free type vars + CE -- class environment + +mkE :: TCE -> CE -> E +mkE tce ce = MkE tce nullGVB nullLVB ce + +nullE :: E +nullE = MkE nullTCE nullGVB nullLVB nullCE +\end{code} + +The ``local'' and ``global'' bindings, @LVB@ and @GVB@, are +non-exported synonyms. The important thing is that @GVB@ doesn't +contain any free type variables. This is used (only) in @tvOfE@, +which extracts free type variables from the environment. It's quite a +help to have this separation because there may be quite a large bunch +of imported things in the @GVB@, all of which are guaranteed +polymorphic. + +\begin{code} +type LVB = UniqFM Id -- Locals just have a Unique +type GVB = UniqFM Id -- Globals might be a prelude thing; hence IdKey + +nullLVB = (emptyUFM :: LVB) +nullGVB = (emptyUFM :: GVB) +\end{code} + +The ``local'' and ``global'' value environments are not part of @E@ at +all, but is used to provide increments to the value bindings. GVE are +carries the implication that there are no free type variables. + +\begin{code} +type LVE = [(Name, Id)] -- Maps Names to Ids +type GVE = [(Name, Id)] -- Maps Names to Ids + +nullLVE = ([] :: LVE) +plusLVE a b = a ++ b +nullGVE = ([] :: GVE) +unitGVE n i = ( [(n, i)] :: GVE ) +-- UNUSED: rngGVE gve = map snd gve +plusGVE a b = a ++ b +\end{code} + +%************************************************************************ +%* * +\subsection{Value environment stuff} +%* * +%************************************************************************ + +Looking up things should mostly succeed, because the renamer should +have spotted all out-of-scope names. The exception is instances. + +The ``Quietly'' version is for pragmas, where lookups very well may +fail. @lookup_val@ is the internal function that does the work. + +\begin{code} +lookupE_Value :: E -> Name -> Id +lookupE_ValueQuietly :: E -> Name -> Maybe Id + +lookupE_Value e nm + = case lookup_val e nm of + Succeeded id -> id + Failed (should_panic, msg) + -> if should_panic then panic msg else error msg + +lookupE_ValueQuietly e nm + = case lookup_val e nm of + Succeeded id -> Just id + Failed _ -> Nothing +\end{code} + +\begin{code} +lookup_val (MkE _ gvb lvb ce) name + = case name of + + WiredInVal id -> Succeeded id + PreludeVal key _ -> case (lookupDirectlyUFM gvb key) of + Just id -> Succeeded id + Nothing -> Failed (False, prelude_err_msg) + + ClassOpName uniq clas_name _ tag -> id_from_env uniq + + -- You might think that top-level ids are guaranteed to have no + -- free tyvars, so look only in gvb; but you'd be wrong! When + -- type-checking the RHS of recursive top-level defns, the name + -- of the thing is bound to a *monomorphic* type, which is later + -- generalised. So we have to look in the LVE too. + + OtherTopId uniq _ -> id_from_env uniq + + -- Short names could be in either GVB or LVB + Short uniq _ -> id_from_env uniq + + funny_name -> pprPanic "lookup_val: funny Name" (ppr PprDebug funny_name) + where + prelude_err_msg = "ERROR: in looking up a built-in Prelude value!\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)" + + id_from_env uniq + = case (lookupDirectlyUFM lvb uniq) of + Just id -> Succeeded id + Nothing -> + case (lookupDirectlyUFM gvb uniq) of + Just id -> Succeeded id + Nothing -> Failed (True, -- should panic + ("lookupE_Value: unbound name: "++(ppShow 80 (ppr PprShowAll name)))) +\end{code} + +For Prelude things that we reach out and grab, we have only an @Unique@. +\begin{code} +lookupE_ClassOpByKey :: E -> Unique{-ClassKey-} -> FAST_STRING -> Id + +lookupE_ClassOpByKey (MkE _ gvb lvb ce) clas_key op_str + = let + clas = lookupCE ce (PreludeClass clas_key bottom) + bottom = pprPanic ("lookupE_ClassOpByKey: "++(_UNPK_ op_str)) + (ppAbove (pprUnique clas_key) (ppr PprShowAll (rngCE ce))) + + (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) + = getClassBigSig clas + in + case [ op_sel_id | (op, op_sel_id) <- ops `zip` op_sel_ids, + op_str == getClassOpString op ] of + [op] -> op + -- Seems a rather horrible way to do it (ToDo) +\end{code} + +@lookupE_Binder@ is like @lookupE_Value@, but it is used for {\em +binding} occurrences of a variable, rather than {\em uses}. The +difference is that there should always be an entry in the LVE for +binding occurrences. Just a sanity check now, really. + +\begin{code} +lookupE_Binder :: E -> Name -> Id +lookupE_Binder (MkE _ _ lvb _) name + = case (lookupDirectlyUFM lvb (name2uniq name)) of + Just id -> id + Nothing -> pprPanic "lookupE_Binder: unbound name: " (ppr PprShowAll name) +\end{code} + +\begin{code} +getE_GlobalVals :: E -> [Id] +getE_GlobalVals (MkE tce gvb lvb ce) + = let + result = eltsUFM gvb ++ eltsUFM lvb + in + -- pprTrace "Global Ids:" (ppr PprShowAll result) + result + +plusE_GVE :: E -> GVE -> E +plusE_GVE (MkE tce gvb lvb ce) gve + = let + new_stuff = listToUFM_Directly [(name2idkey n, i) | (n,i) <- gve ] + in + MkE tce (plusUFM gvb new_stuff) lvb ce + where + name2idkey (PreludeVal k _) = k + name2idkey (OtherTopId u _) = u + name2idkey (ClassOpName u _ _ _) = u + +growE_LVE :: E -> LVE -> E +growE_LVE (MkE tce gvb lvb ce) lve + = let + new_stuff = listToUFM_Directly [(name2uniq n, i) | (n,i) <- lve ] + in + MkE tce gvb (plusUFM lvb new_stuff) ce + +-- ToDo: move this elsewhere?? +name2uniq (Short u _) = u +name2uniq (OtherTopId u _) = u +name2uniq (ClassOpName u _ _ _) = panic "growE_LVE:name2uniq" +\end{code} + +Return the free type variables of an LVE; there are no duplicates in +the result---hence all the @Set@ bozo-ery. The free tyvars can only +occur in the LVB part. + +\begin{code} +tvOfE :: E -> [TyVar] +tvOfE (MkE tce gvb lvb ce) + = uniqSetToList (mkUniqSet ( + foldr ((++) . extractTyVarsFromTy . getIdUniType) [] (eltsUFM lvb) + )) +\end{code} + +%************************************************************************ +%* * +%* +\subsection{Type and class environments} +%* * +%************************************************************************ + +\begin{code} +getE_TCE :: E -> TCE +getE_TCE (MkE tce gvb lvb ce) = tce + +getE_CE :: E -> CE +getE_CE (MkE tce gvb lvb ce) = ce + +plusE_TCE :: E -> TCE -> E +plusE_TCE (MkE tce gvb lvb ce) tce' + = MkE (plusTCE tce' tce) gvb lvb ce + +plusE_CE :: E -> CE -> E +plusE_CE (MkE tce gvb lvb ce) ce' + = MkE tce gvb lvb (plusCE ce ce') +\end{code} diff --git a/ghc/compiler/envs/IdEnv.hi b/ghc/compiler/envs/IdEnv.hi new file mode 100644 index 0000000..4760b95 --- /dev/null +++ b/ghc/compiler/envs/IdEnv.hi @@ -0,0 +1,73 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface IdEnv where +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda(..)) +import Outputable(NamedThing) +import UniType(UniType) +import UniqFM(UniqFM, addToUFM, delFromUFM, delListFromUFM, eltsUFM, emptyUFM, filterUFM, listToUFM, lookupUFM, mapUFM, minusUFM, plusUFM, plusUFM_C, singletonUFM) +import Unique(Unique, u2i) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data Labda a = Hamna | Ni a +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +addOneToIdEnv :: UniqFM a -> Id -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +combineIdEnvs :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM_C _N_ #-} +delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-} +delManyFromIdEnv :: UniqFM a -> [Id] -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM delListFromUFM [ (Id), _N_ ] _N_ #-} +delOneFromIdEnv :: UniqFM a -> Id -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +growIdEnv :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM _N_ #-} +growIdEnvList :: UniqFM a -> [(Id, a)] -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +isNullIdEnv :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +listToUFM :: NamedThing a => [(a, b)] -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +lookupIdEnv :: UniqFM a -> Id -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupNoFailIdEnv :: UniqFM a -> Id -> a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +mapIdEnv :: (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM mapUFM _N_ #-} +mapUFM :: (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +minusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkIdEnv :: [(Id, a)] -> UniqFM a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM listToUFM [ (Id), _N_ ] _N_ #-} +modifyIdEnv :: UniqFM a -> (a -> a) -> Id -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLU(U(P)AAA)" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +nullIdEnv :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +rngIdEnv :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM eltsUFM _N_ #-} +singletonUFM :: NamedThing a => a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +unitIdEnv :: Id -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/envs/IdEnv.lhs b/ghc/compiler/envs/IdEnv.lhs new file mode 100644 index 0000000..a06ef63 --- /dev/null +++ b/ghc/compiler/envs/IdEnv.lhs @@ -0,0 +1,113 @@ +% +% (c) The AQUA Project, Glasgow University, 1995 +% +\section[IdEnv]{Lookup tables that have @Id@ keys} + +An interface to the @FiniteMap@ machinery, which exports +a ``personality'' the same as that of the old @IdEnv@ module. + +\begin{code} +#include "HsVersions.h" + +module IdEnv ( + IdEnv(..), -- abstract: NOT + + lookupIdEnv, lookupNoFailIdEnv, + nullIdEnv, unitIdEnv, mkIdEnv, growIdEnv, growIdEnvList, + isNullIdEnv, + addOneToIdEnv, + delOneFromIdEnv, delManyFromIdEnv, --UNUSED: minusIdEnv, + modifyIdEnv, combineIdEnvs, + rngIdEnv, + mapIdEnv, +-- UNUSED: filterIdEnv, + + -- and to make the interface self-sufficient... + UniqFM, + Id, Unique, Maybe(..) + + -- and for pragma-friendliness... +#ifdef USE_ATTACK_PRAGMAS + , addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM, + lookupUFM, mapUFM, filterUFM, minusUFM, listToUFM, emptyUFM, + eltsUFM, singletonUFM, + u2i +#endif + ) where + +import UniqFM +import Id +import IdInfo +import Maybes ( Maybe(..), MaybeErr(..) ) +import Outputable +import Unique ( Unique, u2i ) +import Util +\end{code} + +\begin{code} +type IdEnv elt = UniqFM elt +\end{code} + +Signatures: +\begin{code} +addOneToIdEnv :: IdEnv a -> Id -> a -> IdEnv a +combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a +delManyFromIdEnv :: IdEnv a -> [Id] -> IdEnv a +delOneFromIdEnv :: IdEnv a -> Id -> IdEnv a +growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a +growIdEnvList :: IdEnv a -> [(Id, a)] -> IdEnv a +isNullIdEnv :: IdEnv a -> Bool +lookupIdEnv :: IdEnv a -> Id -> Maybe a +lookupNoFailIdEnv :: IdEnv a -> Id -> a +mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b +--filterIdEnv :: (a -> Bool) -> IdEnv a -> IdEnv a +--minusIdEnv :: IdEnv a -> IdEnv a -> IdEnv a +mkIdEnv :: [(Id, a)] -> IdEnv a +modifyIdEnv :: IdEnv a -> (a -> a) -> Id -> IdEnv a +nullIdEnv :: IdEnv a +rngIdEnv :: IdEnv a -> [a] +unitIdEnv :: Id -> a -> IdEnv a +\end{code} + +\begin{code} +addOneToIdEnv env id elt = addToUFM env id elt + +combineIdEnvs combiner env1 env2 = plusUFM_C combiner env1 env2 + +delManyFromIdEnv env ids = delListFromUFM env ids + +delOneFromIdEnv env id = delFromUFM env id + +growIdEnv old_env new_stuff = plusUFM old_env new_stuff + +growIdEnvList old_env pairs = plusUFM old_env (listToUFM pairs) + +isNullIdEnv env = sizeUFM env == 0 + +lookupIdEnv env id = lookupUFM env id + +lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx } + +mapIdEnv f env = mapUFM f env + +{- UNUSED: +filterIdEnv p env = filterUFM p env +minusIdEnv env1 env2 = minusUFM env1 env2 +-} + +mkIdEnv stuff = listToUFM stuff + +-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the +-- modify function, and put it back. + +modifyIdEnv env mangle_fn key + = case (lookupIdEnv env key) of + Nothing -> env + Just xx -> addOneToIdEnv env key (mangle_fn xx) + +nullIdEnv = emptyUFM + +rngIdEnv env = eltsUFM env + +unitIdEnv id elt = singletonUFM id elt +\end{code} diff --git a/ghc/compiler/envs/InstEnv.hi b/ghc/compiler/envs/InstEnv.hi new file mode 100644 index 0000000..fae2749 --- /dev/null +++ b/ghc/compiler/envs/InstEnv.hi @@ -0,0 +1,59 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface InstEnv where +import BasicLit(BasicLit) +import Class(Class, ClassOp) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import HsBinds(Binds) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsLit(Literal) +import HsMatches(Match) +import HsPat(InPat, TypecheckedPat) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdInfo(IdInfo, SpecEnv, SpecInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import Maybes(Labda, MaybeErr) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +type ClassInstEnv = [(UniType, InstTemplate)] +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data InstTy {-# GHC_PRAGMA DictTy Class UniType | MethodTy Id [UniType] #-} +type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv) +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type MatchEnv a b = [(a, b)] +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +type MethodInstInfo = (Id, [UniType], InstTemplate) +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +addClassInst :: Class -> [(UniType, InstTemplate)] -> UniType -> Id -> [TyVarTemplate] -> [(Class, UniType)] -> SrcLoc -> MaybeErr [(UniType, InstTemplate)] (Class, (UniType, SrcLoc), (UniType, SrcLoc)) + {-# GHC_PRAGMA _A_ 7 _U_ 2222112 _N_ _S_ "LSLLLLL" _N_ _N_ #-} +lookupClassInstAtSimpleType :: Class -> UniType -> Labda Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAAAAAAASA)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupInst :: SplitUniqSupply -> Inst -> Labda (Expr Id TypecheckedPat, [Inst]) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +lookupNoBindInst :: SplitUniqSupply -> Inst -> Labda [Inst] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +nullMEnv :: [(a, b)] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _NIL_ [(u0, u1)] [] _N_ #-} + diff --git a/ghc/compiler/envs/InstEnv.lhs b/ghc/compiler/envs/InstEnv.lhs new file mode 100644 index 0000000..edc3e2f --- /dev/null +++ b/ghc/compiler/envs/InstEnv.lhs @@ -0,0 +1,549 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[InstEnv]{Instance environments} + +\begin{code} +#include "HsVersions.h" + +module InstEnv ( + -- these types could use some abstractification (??? ToDo) + ClassInstEnv(..), -- OLD: IdInstEnv(..), + InstTemplate, InstTy, + MethodInstInfo(..), -- needs to be exported? (ToDo) + InstanceMapper(..), -- widely-used synonym + +-- instMethod, instTemplate, -- no need to export + addClassInst, {- NOT USED addConstMethInst, -} + lookupInst, + lookupClassInstAtSimpleType, + lookupNoBindInst, + + MatchEnv(..), -- mk more abstract (??? ToDo) + nullMEnv, +-- mkMEnv, lookupMEnv, insertMEnv, -- no need to export + + -- and to make the interface self-sufficient... + Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id, + Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon, + UniType, SplitUniqSupply, SpecInfo + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import AbsPrel ( intTyCon, --wordTyCon, addrTyCon, + floatTyCon, doubleTyCon, charDataCon, intDataCon, + wordDataCon, addrDataCon, floatDataCon, + doubleDataCon, + intPrimTyCon, doublePrimTyCon + ) +import AbsSyn -- TypecheckedExpr, etc. +import AbsUniType +import Id +import IdInfo +import Inst +import Maybes -- most of it +import Outputable ( isExported ) +import PlainCore -- PlainCoreExpr, etc. +import Pretty +import PrimKind -- rather grubby import (ToDo?) +import SplitUniq +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[InstEnv-types]{Type declarations} +%* * +%************************************************************************ + +\begin{code} +type InstanceMapper + = Class -> (ClassInstEnv, ClassOp -> SpecEnv) + +type ClassInstEnv = MatchEnv UniType InstTemplate -- Instances of dicts +--OLD: type IdInstEnv = MatchEnv [UniType] InstTemplate -- Instances of ids + +data InstTemplate + = MkInstTemplate + Id -- A fully polymorphic Id; it is the function + -- which produces the Id instance or dict from + -- the pieces specified by the rest of the + -- template. Its SrcLoc tells where the + -- instance was defined. + [UniType] -- Apply it to these types, suitably instantiated + [InstTy] -- and instances of these things + +type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance +\end{code} + +There is an important consistency constraint between the @MatchEnv@s +in and the @InstTemplate@s inside them: the @UniType@(s) which is/are +the key for the @MatchEnv@ must contain only @TyVarTemplates@, and +these must be a superset of the @TyVarTemplates@ mentioned in the +corresponding @InstTemplate@. + +Reason: the lookup process matches the key against the desired value, +returning a substitution which is used to instantiate the template. + +\begin{code} +data InstTy + = DictTy Class UniType + | MethodTy Id [UniType] +\end{code} + + MkInstTemplate f tvs insts + +says that, given a particular mapping of type variables tvs to some +types tys, the value which is the required instance is + + f tys (insts [tys/tvs]) + + +@instMethod@ is used if there is no instance for a method; then it is +expressed in terms of the corresponding dictionary (or possibly, in a +wired-in case only, dictionaries). + +\begin{code} +instMethod :: SplitUniqSupply + -> InstOrigin + -> Id -> [UniType] + -> (TypecheckedExpr, [Inst]) + +instMethod uniqs orig id tys + = (mkDictApp (mkTyApp (Var id) tys) dicts, + insts) + where + (tyvars, theta, tau_ty) = splitType (getIdUniType id) + tenv = tyvars `zipEqual` tys + insts = mk_dict_insts uniqs theta + dicts = map mkInstId insts + + mk_dict_insts us [] = [] + mk_dict_insts us ((clas, ty) : rest) + = case splitUniqSupply us of { (s1, s2) -> + (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig) + : mk_dict_insts s2 rest + } +\end{code} + +@instTemplate@ is used if there is an instance for a method or dictionary. + +\begin{code} +instTemplate :: SplitUniqSupply + -> InstOrigin + -> [(TyVarTemplate, UniType)] + -> InstTemplate + -> (TypecheckedExpr, [Inst]) + +instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys) + = (mkDictApp (mkTyApp (Var id) ty_args) ids, -- ToDo: not strictly a dict app + -- for Method inst_tys + insts) + where + ty_args = map (instantiateTy tenv) ty_tmpls + insts = mk_insts uniqs inst_tys + ids = map mkInstId insts + + mk_insts us [] = [] + mk_insts us (inst_ty : rest) + = case splitUniqSupply us of { (s1, s2) -> + let + uniq = getSUnique s1 + in + (case inst_ty of + DictTy clas ty -> Dict uniq clas (instantiateTy tenv ty) orig + MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig + ) : mk_insts s2 rest + } +\end{code} + + +%************************************************************************ +%* * +\subsection[InstEnv-adding]{Adding new class instances} +%* * +%************************************************************************ + +@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ based on +information from a single instance declaration. It complains about +any overlap with an existing instance. + +Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from +scratch here, rather than passing them in. This means a small amount +of duplication (no big deal) and that we can't attach a single +canonical unfolding; but they don't have a slot for unfoldings +anyway... This could be improved. (We do, however, snaffle in the +pragma info from the interface...) + +{\em Random notes} + +\begin{verbatim} +class Foo a where + fop :: Ord b => a -> b -> b -> a + +instance Foo Int where + fop x y z = if y Foo [a] where + fop [] y z = [] + fop (x:xs) y z = [fop x y z] +\end{verbatim} + + +For the Int instance we add to the ??? envt +\begin{verbatim} + (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b] +\end{verbatim} + +If there are no type variables, @addClassInstance@ adds constant +instances for those class ops not mentioned in the class-op details +(possibly using the pragma info that was passed in). This MUST +be the same decision as that by @tcInstDecls2@ about whether to +generate constant methods. NB: A slightly more permissive version +would base the decision on the context being empty, but there is +slightly more admin associated and the benefits are very slight; the +context is seldom empty unless there are no tyvars involved. + +Note: the way of specifying class-op instance details is INADEQUATE +for polymorphic class ops. That just means you can't specify clever +instances for them via this function. + +\begin{code} +addClassInst + :: Class -- class in question (for err msg only) + -> ClassInstEnv -- Incoming envt + -> UniType -- The instance type + -> Id -- Dict fun id to apply + -> [TyVarTemplate] -- Types to which (after instantiation) to apply the dfun + -> ThetaType -- Dicts to which to apply the dfun + -> SrcLoc -- associated SrcLoc (for err msg only) + -> MaybeErr + ClassInstEnv -- Success + (Class, (UniType, SrcLoc), -- Failure: the overlapping pair + (UniType, SrcLoc)) + +addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn + = case (insertMEnv matchTy inst_env inst_ty dict_template) of + Succeeded inst_env' -> Succeeded inst_env' + Failed (ty', MkInstTemplate id' _ _) + -> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id')) + where + dict_template = MkInstTemplate dfun_id + (map mkTyVarTemplateTy inst_tyvars) + (unzipWith DictTy dfun_theta) +\end{code} + +============ NOT USED ============= +@addConstMethInst@ panics on overlap, because @addClassInst@ has already found +any overlap. + +\begin{pseudocode} +addConstMethInst :: IdInstEnv + -> UniType -- The instance type + -> Id -- The constant method + -> [TyVarTemplate] -- Apply method to these (as above) + -> IdInstEnv + +addConstMethInst inst_env inst_ty meth_id inst_tyvars + = case (insertMEnv matchTys inst_env [inst_ty] template) of + Succeeded inst_env' -> inst_env' + Failed (tys', MkInstTemplate id' _ _) -> + pprPanic "addConstMethInst:" + (ppSep [ppr PprDebug meth_id, + ppr PprDebug inst_ty, + ppr PprDebug id']) + where + template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) [] + -- Constant method just needs to be applied to tyvars + -- (which are usually empty) +\end{pseudocode} + +@mkIdInstEnv@ is useful in the simple case where we've a list of +@(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of +some other Id (in which the resulting IdInstEnv will doubtless be +embedded. There's no messing about with type variables or +dictionaries here. + +\begin{code} +{- OLD: +mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv + +mkIdInstEnv [] = nullMEnv +mkIdInstEnv ((tys,id) : rest) + = let + inst_env = mkIdInstEnv rest + in + case (insertMEnv matchTys inst_env tys template) of + Succeeded inst_env' -> inst_env' + Failed _ -> panic "Failed in mkIdInstEnv" + where + template = MkInstTemplate id [] [] +-} +\end{code} + +%************************************************************************ +%* * +\subsection[InstEnv-lookup]{Performing lookup} +%* * +%************************************************************************ + +\begin{code} +lookupInst :: SplitUniqSupply + -> Inst + -> Maybe (TypecheckedExpr, + [Inst]) + +lookupInst uniqs (Dict _ clas ty orig) + = if isTyVarTy ty then + Nothing -- No instances of a class at a type variable + else + case (lookupMEnv matchTy inst_env ty) of + Nothing -> Nothing + Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ) + where + inst_env + = case orig of + + -- During deriving and instance specialisation operations + -- we can't get the instances of the class from inside the + -- class, because the latter ain't ready yet. Instead we + -- find a mapping from classes to envts inside the dict origin. + -- (A Simon hack [WDP]) + + DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas) + + InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas) + + -- Usually we just get the instances of the class from + -- inside the class itself. + + other -> getClassInstEnv clas + +lookupInst uniqs (Method _ id tys orig) + = if (all isTyVarTy tys) then + general_case -- Instance types are all type variables, so there can't be + -- a special instance for this method + + else -- Get the inst env from the Id, and look up in it + case (lookupSpecEnv (getIdSpecialisation id) tys) of + Nothing -> general_case + Just (spec_id, types_left, num_dicts_to_toss) + -> Just (instMethod uniqs orig spec_id types_left) + where + general_case = Just (instMethod uniqs orig id tys) +\end{code} + +Now "overloaded" literals: the plain truth is that the compiler +is intimately familiar w/ the types Int, Integer, Float, and Double; +for everything else, we actually conjure up an appropriately-applied +fromInteger/fromRational, as the Haskell report suggests. + +\begin{code} +lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig) + = Just ( + case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms + Just (tycon, [], _) + | tycon == intPrimTyCon -> (intprim_lit, []) + | tycon == doublePrimTyCon -> (doubleprim_lit, []) + | tycon == intTyCon -> (int_lit, []) + | tycon == doubleTyCon -> (double_lit, []) + | tycon == floatTyCon -> (float_lit, []) +-- | tycon == wordTyCon -> (word_lit, []) +-- | tycon == addrTyCon -> (addr_lit, []) + + _{-otherwise-} -> + + if (i >= toInteger minInt && i <= toInteger maxInt) then + -- It's overloaded but small enough to fit into an Int + + let u2 = getSUnique uniqs + method = Method u2 from_int [ty] orig + in + (App (Var (mkInstId method)) int_lit, [method]) + + else + -- Alas, it is overloaded and a big literal! + + let u2 = getSUnique uniqs + method = Method u2 from_integer [ty] orig + in + (App (Var (mkInstId method)) (Lit (IntLit i)), [method]) + ) + where +#if __GLASGOW_HASKELL__ <= 22 + iD = ((fromInteger i) :: Double) +#else + iD = ((fromInteger i) :: Rational) +#endif + intprim_lit = Lit (IntPrimLit i) + doubleprim_lit = Lit (DoublePrimLit iD) + int_lit = App (Var intDataCon) intprim_lit + double_lit = App (Var doubleDataCon) doubleprim_lit + float_lit = App (Var floatDataCon) (Lit (FloatPrimLit iD)) +-- word_lit = App (Var wordDataCon) intprim_lit +-- addr_lit = App (Var addrDataCon) intprim_lit + +lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig) + = Just ( + case (getUniDataTyCon_maybe ty) of -- this way is *unflummoxed* by synonyms + Just (tycon, [], _) + | tycon == doublePrimTyCon -> (doubleprim_lit, []) + | tycon == doubleTyCon -> (double_lit, []) + | tycon == floatTyCon -> (float_lit, []) + + _ {-otherwise-} -> -- gotta fromRational it... + --pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) ( + let + u2 = getSUnique uniqs + method = Method u2 from_rational [ty] orig + in + (App (Var (mkInstId method)) (Lit (FracLit f)), [method]) + --) + ) + where +#if __GLASGOW_HASKELL__ <= 22 + fD = ((fromRational f) :: Double) +#else + fD = f +#endif + doubleprim_lit = Lit (DoublePrimLit fD) + double_lit = App (Var doubleDataCon) doubleprim_lit + float_lit = App (Var floatDataCon) (Lit (FloatPrimLit fD)) +\end{code} + +There is a second, simpler interface, when you want an instance +of a class at a given nullary type constructor. It just returns +the appropriate dictionary if it exists. It is used only when resolving +ambiguous dictionaries. + +\begin{code} +lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id + +lookupClassInstAtSimpleType clas ty + = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of + Nothing -> Nothing + Just (_,_,MkInstTemplate dict [] []) -> Just dict +\end{code} + +Notice in the above that the type constructors in the default list +should all have arity zero, so there should be no type variables +or thetas in the instance declaration. + +There's yet a third interface for Insts which need no binding. +They are used to record constraints on type variables, notably +for CCall arguments and results. + +\begin{code} +lookupNoBindInst :: SplitUniqSupply + -> Inst + -> Maybe [Inst] + +lookupNoBindInst uniqs (Dict _ clas ty orig) + = if isTyVarTy ty then + Nothing -- No instances of a class at a type variable + else + case (lookupMEnv matchTy inst_env ty) of + Nothing -> Nothing + Just (_,tenv,templ) -> + case (instTemplate uniqs orig tenv templ) of + (bottom_rhs, insts) + -> Just insts + -- The idea here is that the expression built by + -- instTemplate isn't relevant; indeed, it might well + -- be a place-holder bottom value. + where + inst_env = getClassInstEnv clas +\end{code} + +%************************************************************************ +%* * +\subsection[MatchEnv]{Matching environments} +%* * +%************************************************************************ + +``Matching'' environments allow you to bind a template to a value; +when you look up in it, you supply a value which is matched against +the template. + +\begin{code} +type MatchEnv key value = [(key, value)] +\end{code} + +For now we just use association lists. The list is maintained sorted +in order of {\em decreasing specificness} of @key@, so that the first +match will be the most specific. + +\begin{code} +nullMEnv :: MatchEnv a b +nullMEnv = [] + +mkMEnv :: [(key, value)] -> MatchEnv key value +mkMEnv stuff = stuff +\end{code} + +@lookupMEnv@ looks up in a @MatchEnv@. +It +simply takes the first match, should be the most specific. + +\begin{code} +lookupMEnv :: (key {- template -} -> -- Matching function + key {- instance -} -> + Maybe match_info) + -> MatchEnv key value -- The envt + -> key -- Key + -> Maybe (key, -- Template + match_info, -- Match info returned by matching fn + value) -- Value + +lookupMEnv key_match alist key + = find alist + where + find [] = Nothing + find ((tpl, val) : rest) + = case key_match tpl key of + Nothing -> find rest + Just match_info -> Just (tpl, match_info, val) +\end{code} + +@insertMEnv@ extends a match environment, checking for overlaps. + +\begin{code} +insertMEnv :: (key {- template -} -> -- Matching function + key {- instance -} -> + Maybe match_info) + -> MatchEnv key value -- Envt + -> key -> value -- New item + -> MaybeErr (MatchEnv key value) -- Success... + (key, value) -- Failure: Offending overlap + +insertMEnv match_fn alist key value + = insert alist + where + -- insert has to put the new item in BEFORE any keys which are + -- LESS SPECIFIC than the new key, and AFTER any keys which are + -- MORE SPECIFIC The list is maintained in specific-ness order, so + -- we just stick it in either last, or just before the first key + -- of which the new key is an instance. We check for overlap at + -- that point. + + insert [] = returnMaB [(key, value)] + insert ((t,v) : rest) + = case (match_fn t key) of + Nothing -> + -- New key is not an instance of this existing one, so + -- continue down the list. + insert rest `thenMaB` (\ rest' -> + returnMaB ((t,v):rest') ) + + Just match_info -> + -- New key *is* an instance of the old one, so check the + -- other way round in case of identity. + + case (match_fn key t) of + Just _ -> failMaB (t,v) + -- Oops; overlap + + Nothing -> returnMaB ((key,value):(t,v):rest) + -- All ok; insert here +\end{code} diff --git a/ghc/compiler/envs/LIE.hi b/ghc/compiler/envs/LIE.hi new file mode 100644 index 0000000..eb0f193 --- /dev/null +++ b/ghc/compiler/envs/LIE.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface LIE where +import Class(Class) +import Id(Id) +import Inst(Inst, InstOrigin, OverloadedLit) +import UniType(UniType) +import Unique(Unique) +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data LIE {-# GHC_PRAGMA MkLIE [Inst] #-} +mkLIE :: [Inst] -> LIE + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Inst]) -> _!_ _ORIG_ LIE MkLIE [] [u0] _N_ #-} +nullLIE :: LIE + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +plusLIE :: LIE -> LIE -> LIE + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(L)U(L)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +unMkLIE :: LIE -> [Inst] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [Inst]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: LIE) -> case u0 of { _ALG_ _ORIG_ LIE MkLIE (u1 :: [Inst]) -> u1; _NO_DEFLT_ } _N_ #-} +unitLIE :: Inst -> LIE + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/envs/LIE.lhs b/ghc/compiler/envs/LIE.lhs new file mode 100644 index 0000000..cd3e38c --- /dev/null +++ b/ghc/compiler/envs/LIE.lhs @@ -0,0 +1,44 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[LIE]{Id instance environment} + +This is not really an ``environment.'' + +\begin{code} +#include "HsVersions.h" + +module LIE ( + LIE, -- abstract type + mkLIE, nullLIE, unitLIE, unMkLIE, plusLIE, + + -- imported things so this module's interface is self-contained + Inst + ) where + +import Inst ( Inst ) +import Outputable +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[LIE-building]{Building LIEs} +%* * +%************************************************************************ + +\begin{code} +data LIE = MkLIE [Inst] + +mkLIE = MkLIE + +nullLIE = MkLIE [] +unitLIE x = MkLIE [x] + +unMkLIE :: LIE -> [Inst] +unMkLIE (MkLIE insts) = insts + +plusLIE :: LIE -> LIE -> LIE +plusLIE (MkLIE lie1) (MkLIE lie2) + = MkLIE (lie1 ++ lie2) +\end{code} diff --git a/ghc/compiler/envs/TCE.hi b/ghc/compiler/envs/TCE.hi new file mode 100644 index 0000000..7903554 --- /dev/null +++ b/ghc/compiler/envs/TCE.hi @@ -0,0 +1,50 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TCE where +import CharSeq(CSeq) +import Class(Class) +import ErrUtils(Error(..)) +import Id(Id) +import Maybes(Labda, MaybeErr) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM) +import Unique(Unique, u2i) +type Error = PprStyle -> Int -> Bool -> PrettyRep +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +type TCE = UniqFM TyCon +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +checkTypeCycles :: UniqFM TyCon -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +lookupTCE :: UniqFM TyCon -> Name -> TyCon + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +nullTCE :: UniqFM TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [TyCon] [] _N_ #-} +plusTCE :: UniqFM TyCon -> UniqFM TyCon -> UniqFM TyCon + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM plusUFM { TyCon } _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +rngTCE :: UniqFM TyCon -> [TyCon] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM eltsUFM { TyCon } _N_ #-} +singletonDirectlyUFM :: Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +unitTCE :: Unique -> TyCon -> UniqFM TyCon + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int#) (u1 :: TyCon) -> _!_ _ORIG_ UniqFM LeafUFM [TyCon] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: Unique) (u1 :: TyCon) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [TyCon] [u2, u1]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/envs/TCE.lhs b/ghc/compiler/envs/TCE.lhs new file mode 100644 index 0000000..aac6057 --- /dev/null +++ b/ghc/compiler/envs/TCE.lhs @@ -0,0 +1,110 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TCE]{Type constructor environment} + +\begin{code} +#include "HsVersions.h" + +module TCE ( + TCE(..), UniqFM, + nullTCE, unitTCE, + rngTCE, + lookupTCE, + plusTCE, checkTypeCycles, +-- NOT REALLY USED: printTypeInfoForPop, + + -- and to make the interface self-sufficient... + MaybeErr, Name, TyCon, + Error(..), SrcLoc, Pretty(..), PrettyRep + + IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM) + IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM) + IF_ATTACK_PRAGMAS(COMMA u2i) + ) where + +import AbsUniType ( getMentionedTyCons, isDataTyCon, getTyConDataCons, + TyCon, Arity(..), Class, UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Digraph ( topologicalSort ) +import Errors -- notably typeCycleErr +import Id ( getDataConArity, Id, DataCon(..) ) +import Maybes ( Maybe(..), MaybeErr(..) ) +import Name +import Outputable +import Pretty +import UniqFM -- basic environment handling +import Unique ( Unique ) +import Util +\end{code} + +\begin{code} +--data TCE = MkTCE (UniqFM TyCon) +type TCE = UniqFM TyCon +#define MkTCE {--} +-- also killed instance TCE, exported non-abstractly + +nullTCE :: TCE +nullTCE = MkTCE emptyUFM + +unitTCE :: Unique -> TyCon -> TCE +unitTCE uniq tycon = MkTCE (singletonDirectlyUFM uniq tycon) + +rngTCE :: TCE -> [TyCon] +rngTCE (MkTCE tce) = eltsUFM tce + +lookupTCE :: TCE -> Name -> TyCon +lookupTCE (MkTCE tce) name + = case name of + WiredInTyCon tycon -> tycon + PreludeTyCon key _ _ _ -> case (lookupDirectlyUFM tce key) of + Just tycon -> tycon + Nothing -> err_msg + OtherTyCon uniq _ _ _ _ -> case (lookupDirectlyUFM tce uniq) of + Just tycon -> tycon + Nothing -> err_msg + where + err_msg = error ("ERROR: in looking up a type constructor! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide or change the system's Prelude.hi in some way.\nA -fhaskell-1.3 flag, or lack thereof, can trigger this error.)\n") + +plusTCE :: TCE -> TCE -> TCE +plusTCE (MkTCE tce1) (MkTCE tce2) = MkTCE (plusUFM tce1 tce2) +\end{code} + +\begin{code} +checkTypeCycles :: TCE -> MaybeErr () Error +checkTypeCycles tce + = case (topologicalSort (==) edges vertices) of + Succeeded ordering -> Succeeded () + Failed cycles + -> Failed (typeCycleErr (map (\ c -> map fmt_tycon c) cycles)) + where + fmt_tycon c = (ppr PprForUser c, getSrcLoc c) + where + vertices = [ vertex1 | (vertex1, vertex2) <- edges] + edges = concat (map get_edges (rngTCE tce)) + where + get_edges tycon = [(tycon, dep) | dep <- getMentionedTyCons tycon] + -- Make an arc for every dependency +\end{code} + +\begin{code} +{- NOT REALLY USED: +printTypeInfoForPop :: TCE -> Pretty + +printTypeInfoForPop (MkTCE tce) + = ppAboves [ pp_type tc | tc <- eltsUFM tce, isDataTyCon tc ] + where + pp_type tycon + = ppBesides [ + ppStr "data ", + ppr PprForUser tycon, ppSP, + ppInterleave ppSP (map pp_data_con (getTyConDataCons tycon)), + ppSemi + ] + where + pp_data_con data_con + = ppCat [ppr PprForUser data_con, ppInt (getDataConArity data_con)] +-} +\end{code} diff --git a/ghc/compiler/envs/TVE.hi b/ghc/compiler/envs/TVE.hi new file mode 100644 index 0000000..f4bc96a --- /dev/null +++ b/ghc/compiler/envs/TVE.hi @@ -0,0 +1,42 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TVE where +import Class(Class) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM) +import Unique(Unique, u2i) +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +type TVE = UniqFM UniType +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +lookupTVE :: UniqFM UniType -> Name -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-} +lookupTVE_NoFail :: UniqFM a -> Name -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-} +mkTVE :: [Name] -> (UniqFM UniType, [TyVarTemplate], [UniType]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +nullTVE :: UniqFM UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [UniType] [] _N_ #-} +plusTVE :: UniqFM UniType -> UniqFM UniType -> UniqFM UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM plusUFM { UniType } _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +singletonDirectlyUFM :: Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +unitTVE :: Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/envs/TVE.lhs b/ghc/compiler/envs/TVE.lhs new file mode 100644 index 0000000..ab927df --- /dev/null +++ b/ghc/compiler/envs/TVE.lhs @@ -0,0 +1,74 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[TVE]{Type variable environment} + +This environment is not part of the big one that is carried around +monadically. + +\begin{code} +#include "HsVersions.h" + +module TVE ( + TVE(..), UniqFM, + + mkTVE, nullTVE, unitTVE, + lookupTVE, lookupTVE_NoFail, plusTVE, + + -- and to make the interface self-sufficient... + Maybe, Name, TyVarTemplate, UniType + + IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM) + IF_ATTACK_PRAGMAS(COMMA eltsUFM COMMA singletonDirectlyUFM) + IF_ATTACK_PRAGMAS(COMMA u2i) + ) where + +import AbsUniType ( mkUserTyVarTemplate, mkTyVarTemplateTy, + getTyVar, TyVarTemplate, TyVar, Class, + ClassOp, Arity(..), TyCon, + TauType(..), UniType + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Maybes ( Maybe(..), MaybeErr(..) ) +import Name +import Outputable -- def of ppr +import Pretty -- to pretty-print error messages +import UniqFM -- basic environment handling +import Unique ( Unique ) +import Util +\end{code} + +\begin{code} +type TVE = UniqFM UniType +#define MkTVE {--} +-- also: export non-abstractly + +mkTVE :: [Name] -> (TVE, [TyVarTemplate], [TauType]) +mkTVE names + = case (unzip3 (map mk_tve_one names)) of { (env, tyvars, tys) -> + (MkTVE (listToUFM_Directly env), tyvars, tys) } + where + mk_tve_one (Short uniq short_name) + = case (mkUserTyVarTemplate uniq short_name) of { tyvar -> + case (mkTyVarTemplateTy tyvar) of { ty -> + ((uniq, ty), tyvar, ty) }} + +nullTVE :: TVE +nullTVE = MkTVE emptyUFM + +unitTVE u ty = MkTVE (singletonDirectlyUFM u ty) + +lookupTVE :: TVE -> Name -> UniType +lookupTVE (MkTVE tve) (Short uniq short_name) + = case (lookupDirectlyUFM tve uniq) of + Just ty -> ty + Nothing -> panic "lookupTVE!" + +lookupTVE_NoFail (MkTVE tve) (Short uniq short_name) + = lookupDirectlyUFM tve uniq + +plusTVE :: TVE -> TVE -> TVE +plusTVE (MkTVE tve1) (MkTVE tve2) = MkTVE (plusUFM tve1 tve2) +\end{code} diff --git a/ghc/compiler/envs/TyVarEnv.hi b/ghc/compiler/envs/TyVarEnv.hi new file mode 100644 index 0000000..1330078 --- /dev/null +++ b/ghc/compiler/envs/TyVarEnv.hi @@ -0,0 +1,54 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TyVarEnv where +import Maybes(Labda(..)) +import NameTypes(ShortName) +import Outputable(NamedThing) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM, addToUFM, delFromUFM, delListFromUFM, eltsUFM, emptyUFM, listToUFM, lookupUFM, mapUFM, minusUFM, plusUFM, plusUFM_C, singletonUFM) +import Unique(Unique, u2i) +data Labda a = Hamna | Ni a +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +type TyVarEnv a = UniqFM a +type TypeEnv = UniqFM UniType +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +addOneToTyVarEnv :: UniqFM a -> TyVar -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM addToUFM [ (TyVar), _N_ ] _N_ #-} +addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +growTyVarEnvList :: UniqFM a -> [(TyVar, a)] -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +isNullTyVarEnv :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +listToUFM :: NamedThing a => [(a, b)] -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +lookupTyVarEnv :: UniqFM a -> TyVar -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM lookupUFM [ (TyVar), _N_ ] _N_ #-} +lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +mapUFM :: (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +minusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +mkTyVarEnv :: [(TyVar, a)] -> UniqFM a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM listToUFM [ (TyVar), _N_ ] _N_ #-} +nullTyVarEnv :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +singletonUFM :: NamedThing a => a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/envs/TyVarEnv.lhs b/ghc/compiler/envs/TyVarEnv.lhs new file mode 100644 index 0000000..421b4a2 --- /dev/null +++ b/ghc/compiler/envs/TyVarEnv.lhs @@ -0,0 +1,71 @@ +% +% (c) The AQUA Project, Glasgow University, 1994 +% +\section[TyVarEnv]{Lookup tables that have @TyVar@ keys} + +An interface to the @FiniteMap@ machinery, which exports +a ``personality'' the same as that of the old @TyVarEnv@ module. + +\begin{code} +#include "HsVersions.h" + +module TyVarEnv ( + TyVarEnv(..), -- abstract: NOT + + TypeEnv(..), -- most common/important kind of TyVarEnv + + mkTyVarEnv, + lookupTyVarEnv, + nullTyVarEnv, growTyVarEnvList, + isNullTyVarEnv, + addOneToTyVarEnv, + + -- and to make the interface self-sufficient... + UniqFM, + TyVar, Unique, Maybe(..) + +#ifdef USE_ATTACK_PRAGMAS + , addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM, + lookupUFM, mapUFM, minusUFM, listToUFM, emptyUFM, eltsUFM, + singletonUFM, + u2i +#endif + ) where + +import AbsUniType +import UniqFM +import Maybes ( Maybe(..) ) +import Outputable +import Unique ( Unique, u2i ) +import Util +\end{code} + +\begin{code} +type TyVarEnv elt = UniqFM elt + +type TypeEnv = TyVarEnv UniType -- most common flavo(u)r +\end{code} + +Signatures: +\begin{code} +mkTyVarEnv :: [(TyVar, a)] -> TyVarEnv a +addOneToTyVarEnv :: TyVarEnv a -> TyVar -> a -> TyVarEnv a +growTyVarEnvList :: TyVarEnv a -> [(TyVar, a)] -> TyVarEnv a +isNullTyVarEnv :: TyVarEnv a -> Bool +lookupTyVarEnv :: TyVarEnv a -> TyVar -> Maybe a +nullTyVarEnv :: TyVarEnv a +\end{code} + +\begin{code} +mkTyVarEnv stuff = listToUFM stuff + +addOneToTyVarEnv env id elt = addToUFM env id elt + +growTyVarEnvList env pairs = plusUFM env (listToUFM pairs) + +isNullTyVarEnv env = sizeUFM env == 0 + +lookupTyVarEnv env id = lookupUFM env id + +nullTyVarEnv = emptyUFM +\end{code} diff --git a/ghc/compiler/main/CmdLineOpts.hi b/ghc/compiler/main/CmdLineOpts.hi new file mode 100644 index 0000000..3b00fdc --- /dev/null +++ b/ghc/compiler/main/CmdLineOpts.hi @@ -0,0 +1,48 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CmdLineOpts where +import MainMonad(MainIO(..)) +import Maybes(Labda) +type CmdLineInfo = (GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo]) +data CoreToDo = CoreDoSimplify (SimplifierSwitch -> SwitchResult) | CoreDoArityAnalysis | CoreDoCalcInlinings1 | CoreDoCalcInlinings2 | CoreDoFloatInwards | CoreDoFullLaziness | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoStrictness | CoreDoSpecialising | CoreDoDeforest | CoreDoAutoCostCentres | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal +data GlobalSwitch + = ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats +type MainIO a = _State _RealWorld -> (a, _State _RealWorld) +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data SimplifierSwitch = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings +data StgToDo = StgDoStaticArgs | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling | D_stg_stats +data SwitchResult = SwBool Bool | SwString [Char] | SwInt Int +classifyOpts :: [[Char]] -> _State _RealWorld -> ((GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo]), _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +intSwitchSet :: (a -> SwitchResult) -> (Int -> a) -> Labda Int + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +stringSwitchSet :: (a -> SwitchResult) -> ([Char] -> a) -> Labda [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +switchIsOn :: (a -> SwitchResult) -> a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance Eq GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq SimplifierSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool)] [_CONSTM_ Eq (==) (SimplifierSwitch), _CONSTM_ Eq (/=) (SimplifierSwitch)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord SimplifierSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq SimplifierSwitch}}, (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> _CMP_TAG)] [_DFUN_ Eq (SimplifierSwitch), _CONSTM_ Ord (<) (SimplifierSwitch), _CONSTM_ Ord (<=) (SimplifierSwitch), _CONSTM_ Ord (>=) (SimplifierSwitch), _CONSTM_ Ord (>) (SimplifierSwitch), _CONSTM_ Ord max (SimplifierSwitch), _CONSTM_ Ord min (SimplifierSwitch), _CONSTM_ Ord _tagCmp (SimplifierSwitch)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs new file mode 100644 index 0000000..104a7e5 --- /dev/null +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -0,0 +1,969 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CmdLineOpts]{Things to do with command-line options} + +\begin{code} +#include "HsVersions.h" + +module CmdLineOpts ( + CmdLineInfo(..), SwitchResult(..), + GlobalSwitch(..), SimplifierSwitch(..), + CoreToDo(..), + StgToDo(..), +#ifdef DPH + PodizeToDo(..), +#endif {- Data Parallel Haskell -} + + classifyOpts, + switchIsOn, stringSwitchSet, intSwitchSet, + + -- to make the interface self-sufficient + Maybe, MainIO(..) + ) where + +import MainMonad +import Maybes ( maybeToBool, Maybe(..) ) +import Outputable +import Util +#ifdef __GLASGOW_HASKELL__ +import PreludeGlaST -- bad bad bad boy, Will +#endif +\end{code} + +A command-line {\em switch} is (generally) either on or off; e.g., the +``verbose'' (-v) switch is either on or off. (The \tr{-G} +switch is an exception; it's set to a string, or nothing.) + +A list of {\em ToDo}s is things to be done in a particular part of +processing. A (fictitious) example for the Core-to-Core simplifier +might be: run the simplifier, then run the strictness analyser, then +run the simplifier again (three ``todos''). + +There are three ``to-do processing centers'' at the moment. In the +main loop (\tr{main/Main.lhs}), in the Core-to-Core processing loop +(\tr{simplCore/SimplCore.lhs), and in the STG-to-STG processing loop +(\tr{simplStg/SimplStg.lhs}). + +We use function @classifyOpts@ to take raw command-line arguments from +@GetArgs@ and get back the @CmdLineInfo@, which is what we really +want. + +%************************************************************************ +%* * +\subsection[CmdLineOpts-datatype]{Datatypes associated with command-line options} +%* * +%************************************************************************ + +\begin{code} +type CmdLineInfo + = (GlobalSwitch -> SwitchResult, -- Switch lookup function + [CoreToDo], -- Core-to-core spec +#ifdef DPH + [PodizeToDo], -- Podizer spec + [CoreToDo], -- post podized Core-to-core spec +#endif + [StgToDo] -- Stg-to-stg spec + ) + +data SwitchResult + = SwBool Bool -- on/off + | SwString String -- nothing or a String + | SwInt Int -- nothing or an Int +\end{code} + +\begin{code} +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + (SimplifierSwitch -> SwitchResult) + -- Each run of the simplifier can take a different + -- set of simplifier-specific flags. + + | CoreDoArityAnalysis -- UNUSED right now + | CoreDoCalcInlinings1 + | CoreDoCalcInlinings2 + | CoreDoFloatInwards + | CoreDoFullLaziness + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoStrictness + | CoreDoSpecialising + | CoreDoDeforest + | CoreDoAutoCostCentres + | CoreDoFoldrBuildWorkerWrapper + | CoreDoFoldrBuildWWAnal +-- ANDY: +--| CoreDoHaskPrint +--| CoreDoHaskLetlessPrint +\end{code} + +\begin{code} +data StgToDo + = StgDoStaticArgs + | StgDoUpdateAnalysis + | StgDoLambdaLift + | StgDoMassageForProfiling -- should be (next to) last + -- There's also setStgVarInfo, but its absolute "lastness" + -- is so critical that it is hardwired in (no flag). + | D_stg_stats +\end{code} + +\begin{code} +#ifdef DPH +data PodizeToDo + = PodizeNeeded Int -- Which dimensioned PODs need vectorizing +#endif {- Data Parallel Haskell -} +\end{code} + +@GlobalSwitches@ may be visible everywhere in the compiler. +@SimplifierSwitches@ (which follow) are visible only in the main +Core-to-Core simplifier. + +\begin{code} +data GlobalSwitch + = ProduceC String -- generate C output into this file + | ProduceS String -- generate native-code assembler into this file + | ProduceHi String -- generate .hi interface into this file +--UNUSED: | ProduceHu String -- generate .hu usage-info into this file + + | AsmTarget String -- architecture we are generating code for + | ForConcurrent + + | Haskell_1_3 -- if set => Haskell 1.3; else 1.2 + | GlasgowExts -- Glasgow Haskell extensions allowed + | CompilingPrelude -- Compiling prelude source + + | HideBuiltinNames -- fiddle builtin namespace; used for compiling Prelude + | HideMostBuiltinNames + | EnsureSplittableC String -- (by globalising all top-level Ids w/ this String) + + | Verbose + | PprStyle_User -- printing "level" (mostly for debugging) + | PprStyle_Debug + | PprStyle_All + + | DoCoreLinting -- paranoia flags + | EmitArityChecks + + | OmitInterfacePragmas + | OmitDerivedRead + | OmitReexportedInstances + + | UnfoldingUseThreshold Int -- global one; see also SimplUnf... + | UnfoldingCreationThreshold Int -- ditto + | UnfoldingOverrideThreshold Int + + | ReportWhyUnfoldingsDisallowed + | UseGetMentionedVars + | ShowPragmaNameErrs + | NameShadowingNotOK + | SigsRequired + + | SccProfilingOn + | AutoSccsOnExportedToplevs + | AutoSccsOnAllToplevs + | AutoSccsOnIndividualCafs +--UNUSED: | AutoSccsOnIndividualDicts + | SccGroup String -- name of "group" for this cost centres in this module + + | DoTickyProfiling + + | DoSemiTagging + + -- ToDo: turn these into SimplifierSwitches? + | FoldrBuildOn -- If foldr/build-style transformations are on. + -- See also SimplDoFoldrBuild, which is used + -- inside the simplifier. + | FoldrBuildTrace -- show all foldr/build optimisations. + + | SpecialiseImports -- Treat non-essential spec requests as errors + | ShowImportSpecs -- Output spec requests for non-essential specs + | OmitUnspecialisedCode -- ToDo? (Patrick) + | SpecialiseOverloaded + | SpecialiseUnboxed + | SpecialiseAll + | SpecialiseTrace + + -- this batch of flags is for particular experiments; + -- v unlikely to be used in any other circumstance +--UNUSED: | OmitStkChecks + | OmitBlackHoling + | StgDoLetNoEscapes + | IgnoreStrictnessPragmas -- ToDo: still useful? + | IrrefutableTuples -- We inject extra "LazyPat"s in the typechecker + | IrrefutableEverything -- (TcPat); doing it any earlier would mean that + -- deriving-generated code wouldn't be irrefutablified. + | AllStrict + | AllDemanded + +-- NOT REALLY USED: | D_dump_type_info -- for Robin Popplestone stuff + + | D_dump_rif2hs -- debugging: print out various things + | D_dump_rn4 + | D_dump_tc + | D_dump_deriv + | D_dump_ds + | D_dump_occur_anal + | D_dump_simpl + | D_dump_spec + | D_dump_stranal + | D_dump_deforest + | D_dump_stg + | D_dump_absC + | D_dump_flatC + | D_dump_realC + | D_dump_asm + | D_dump_core_passes -- A Gill-ism + | D_dump_core_passes_info -- Yet another Gill-ism + + | D_verbose_core2core + | D_verbose_stg2stg + | D_simplifier_stats + +{- ???? + | Extra__Flag1 + | Extra__Flag2 + | Extra__Flag3 + | Extra__Flag4 + | Extra__Flag5 + | Extra__Flag6 + | Extra__Flag7 + | Extra__Flag8 + | Extra__Flag9 +-} + +#ifdef DPH + | PodizeIntelligent + | PodizeAggresive + | PodizeVeryAggresive + | PodizeExtremelyAggresive + | D_dump_pod + | D_dump_psimpl + | D_dump_nextC +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +data SimplifierSwitch + = SimplOkToDupCode + | SimplFloatLetsExposingWHNF + | SimplOkToFloatPrimOps + | SimplAlwaysFloatLetsFromLets + | SimplDoCaseElim + | SimplReuseCon + | SimplCaseOfCase + | SimplLetToCase +--UNUSED: | SimplOkToInlineInLambdas + | SimplMayDeleteConjurableIds + | SimplPedanticBottoms -- see Simplifier for an explanation + | SimplDoArityExpand -- expand arity of bindings + | SimplDoFoldrBuild -- This is the per-simplification flag; + -- see also FoldrBuildOn, used elsewhere + -- in the compiler. + | SimplDoNewOccurAnal -- use the *new*, all singing, Occurance analysis + | SimplDoInlineFoldrBuild + -- inline foldr/build (*after* f/b rule is used) + + | IgnoreINLINEPragma + | SimplDoLambdaEtaExpansion +--UNUSED: | SimplDoMonadEtaExpansion + + | SimplDoEtaReduction + + | EssentialUnfoldingsOnly -- never mind the thresholds, only + -- do unfoldings that *must* be done + -- (to saturate constructors and primitives) + + | ShowSimplifierProgress -- report counts on every interation + + | MaxSimplifierIterations Int + + | SimplUnfoldingUseThreshold Int -- per-simplification variants + | SimplUnfoldingCreationThreshold Int + + | KeepSpecPragmaIds -- We normally *toss* Ids we can do without + | KeepUnusedBindings + +{- + | Extra__SimplFlag1 + | Extra__SimplFlag2 + | Extra__SimplFlag3 + | Extra__SimplFlag4 + | Extra__SimplFlag5 + | Extra__SimplFlag6 + | Extra__SimplFlag7 + | Extra__SimplFlag8 +-} +\end{code} + +%************************************************************************ +%* * +\subsection[CmdLineOpts-classify]{Classifying command-line options} +%* * +%************************************************************************ + +\begin{code} +classifyOpts :: [String] -- cmd-line args, straight from GetArgs + -> MainIO CmdLineInfo +-- The MainIO bit is because we might find an unknown flag +-- in which case we print an error message + +#ifndef DPH +classifyOpts opts + = sep opts [] [] [] -- accumulators... + where + sep :: [String] -- cmd-line opts (input) + -> [GlobalSwitch] -- switch accumulator + -> [CoreToDo] -> [StgToDo] -- to_do accumulators + -> MainIO CmdLineInfo -- result + + sep [] glob_sw core_td stg_td + = returnMn ( + isAmong glob_sw, + reverse core_td, + reverse stg_td + ) + + sep (opt1:opts) glob_sw core_td stg_td + +#else {- Data Parallel Haskell -} +classifyOpts opts + = sep opts [] [] [] [] [] -- accumulators... + where + sep :: [String] -- cmd-line opts (input) + -> [GlobalSwitch] -- switch accumulator + -> [CoreToDo] -> [PodizeToDo] -- to_do accumulators + -> [CoreToDo] -> [StgToDo] + -> MainIO CmdLineInfo -- result + + -- see also the related "simpl_sep" function, used + -- to collect up the SimplifierSwitches for a "-fsimplify". + + sep [] glob_sw core_td pod_td pcore_td stg_td + = returnMn ( + isAmong glob_sw, + reverse core_td, + reverse pod_td, + reverse pcore_td, + reverse stg_td + ) + + sep (opt1:opts) glob_sw core_td pod_td pcore_td stg_td +#endif {- Data Parallel Haskell -} + +#ifndef DPH +#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td stg_td +#define CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td +#define POD_TD(to_do) sep opts glob_sw core_td stg_td +#define PAR_CORE_TD(to_do) sep opts glob_sw core_td stg_td +#define BOTH_CORE_TD(to_do) sep opts glob_sw (to_do:core_td) stg_td +#define STG_TD(to_do) sep opts glob_sw core_td (to_do:stg_td) +#define IGNORE_ARG() sep opts glob_sw core_td stg_td + +#else + +#define GLOBAL_SW(switch) sep opts (switch:glob_sw) core_td pod_td pcore_td stg_td +#define CORE_TD(to_do) sep opts glob_sw (to_do:core_td) pod_td pcore_td stg_td +#define POD_TD(to_do) sep opts glob_sw core_td (to_do:pod_td) pcore_td stg_td +#define PAR_CORE_TD(do) sep opts glob_sw core_td pod_td (do:pcore_td) stg_td +#define BOTH_CORE_TD(do) sep opts glob_sw (do:core_td) pod_td (do:pcore_td) stg_td +#define STG_TD(to_do) sep opts glob_sw core_td pod_td pcore_td (to_do:stg_td) +#define IGNORE_ARG() sep opts glob_sw core_td pod_td pcore_td stg_td + +#endif {- Data Parallel Haskell -} + +-- ToDo: DPH-ify +#define GLOBAL_SIMPL_SW(switch) simpl_sep opts (switch:simpl_sw) glob_sw core_td stg_td + + = let + maybe_fasm = starts_with "-fasm-" opt1 + maybe_G = starts_with "-G" opt1 + maybe_C = starts_with "-C" opt1 + maybe_S = starts_with "-S" opt1 + maybe_hi = starts_with "-hi" opt1 + maybe_hu = starts_with "-hu" opt1 + maybe_uut = starts_with "-funfolding-use-threshold" opt1 + maybe_uct = starts_with "-funfolding-creation-threshold" opt1 + maybe_uot = starts_with "-funfolding-override-threshold" opt1 + maybe_gtn = starts_with "-fglobalise-toplev-names" opt1 + starts_with_fasm = maybeToBool maybe_fasm + starts_with_G = maybeToBool maybe_G + starts_with_C = maybeToBool maybe_C + starts_with_S = maybeToBool maybe_S + starts_with_hi = maybeToBool maybe_hi + starts_with_hu = maybeToBool maybe_hu + starts_with_uut = maybeToBool maybe_uut + starts_with_uct = maybeToBool maybe_uct + starts_with_uot = maybeToBool maybe_uot + starts_with_gtn = maybeToBool maybe_gtn + (Just after_fasm) = maybe_fasm + (Just after_G) = maybe_G + (Just after_C) = maybe_C + (Just after_S) = maybe_S + (Just after_hi) = maybe_hi + (Just after_hu) = maybe_hu + (Just after_uut) = maybe_uut + (Just after_uct) = maybe_uct + (Just after_uot) = maybe_uot + (Just after_gtn) = maybe_gtn + in + case opt1 of -- the non-"just match a string" options are at the end... + ',' : _ -> IGNORE_ARG() -- it is for the parser + "-ddump-rif2hs" -> GLOBAL_SW(D_dump_rif2hs) + "-ddump-rn4" -> GLOBAL_SW(D_dump_rn4) + "-ddump-tc" -> GLOBAL_SW(D_dump_tc) + "-ddump-deriv" -> GLOBAL_SW(D_dump_deriv) + "-ddump-ds" -> GLOBAL_SW(D_dump_ds) + "-ddump-stranal" -> GLOBAL_SW(D_dump_stranal) + "-ddump-deforest"-> GLOBAL_SW(D_dump_deforest) + "-ddump-spec" -> GLOBAL_SW(D_dump_spec) + "-ddump-simpl" -> GLOBAL_SW(D_dump_simpl) + "-ddump-occur-anal" -> GLOBAL_SW(D_dump_occur_anal) +-- NOT REALLY USED: "-ddump-type-info" -> GLOBAL_SW(D_dump_type_info) +#ifdef DPH + "-ddump-pod" -> GLOBAL_SW(D_dump_pod) + "-ddump-psimpl"-> GLOBAL_SW(D_dump_psimpl) + "-ddump-nextC" -> GLOBAL_SW(D_dump_nextC) +#endif {- Data Parallel Haskell -} + + "-ddump-stg" -> GLOBAL_SW(D_dump_stg) + "-ddump-absC" -> GLOBAL_SW(D_dump_absC) + "-ddump-flatC"-> GLOBAL_SW(D_dump_flatC) + "-ddump-realC"-> GLOBAL_SW(D_dump_realC) + "-ddump-asm" -> GLOBAL_SW(D_dump_asm) + + "-ddump-core-passes" -> GLOBAL_SW(D_dump_core_passes) +-- ANDY: "-ddump-haskell" -> GLOBAL_SW(D_dump_core_passes_info) + "-dsimplifier-stats" -> GLOBAL_SW(D_simplifier_stats) + + "-dverbose-simpl" ->GLOBAL_SW(D_verbose_core2core) + "-dverbose-stg" -> GLOBAL_SW(D_verbose_stg2stg) + + "-fuse-get-mentioned-vars" -> GLOBAL_SW(UseGetMentionedVars) + + "-fhaskell-1.3" -> GLOBAL_SW(Haskell_1_3) + "-dcore-lint" -> GLOBAL_SW(DoCoreLinting) + "-fomit-interface-pragmas" -> GLOBAL_SW(OmitInterfacePragmas) + "-fignore-strictness-pragmas" -> GLOBAL_SW(IgnoreStrictnessPragmas) + "-firrefutable-tuples" -> GLOBAL_SW(IrrefutableTuples) + "-firrefutable-everything" -> GLOBAL_SW(IrrefutableEverything) + "-fall-strict" -> GLOBAL_SW(AllStrict) + "-fall-demanded" -> GLOBAL_SW(AllDemanded) + + "-fsemi-tagging" -> GLOBAL_SW(DoSemiTagging) + + "-fsimplify" -> -- gather up SimplifierSwitches specially... + simpl_sep opts [] glob_sw core_td stg_td + +--UNUSED: "-farity-analysis" -> CORE_TD(CoreDoArityAnalysis) + "-fcalc-inlinings1"-> CORE_TD(CoreDoCalcInlinings1) + "-fcalc-inlinings2"-> CORE_TD(CoreDoCalcInlinings2) + "-ffloat-inwards" -> CORE_TD(CoreDoFloatInwards) + "-ffull-laziness" -> CORE_TD(CoreDoFullLaziness) + "-fliberate-case" -> CORE_TD(CoreLiberateCase) + "-fprint-core" -> CORE_TD(CoreDoPrintCore) + "-fstatic-args" -> CORE_TD(CoreDoStaticArgs) + "-fstrictness" -> CORE_TD(CoreDoStrictness) + "-fspecialise" -> CORE_TD(CoreDoSpecialising) + "-fdeforest" -> CORE_TD(CoreDoDeforest) + "-fadd-auto-sccs" -> CORE_TD(CoreDoAutoCostCentres) + "-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper) + "-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal) +--ANDY: "-fprint-haskell-core" -> CORE_TD(CoreDoHaskPrint) +-- "-fprint-haskell-letless-core" -> CORE_TD(CoreDoHaskLetlessPrint) + + "-fspecialise-overloaded" -> GLOBAL_SW(SpecialiseOverloaded) + "-fspecialise-unboxed" -> GLOBAL_SW(SpecialiseUnboxed) + "-fspecialise-all" -> GLOBAL_SW(SpecialiseAll) + "-fspecialise-imports" -> GLOBAL_SW(SpecialiseImports) + "-fshow-import-specs" -> GLOBAL_SW(ShowImportSpecs) + "-ftrace-specialisation" -> GLOBAL_SW(SpecialiseTrace) + + "-freport-disallowed-unfoldings" + -> GLOBAL_SW(ReportWhyUnfoldingsDisallowed) + + "-fomit-derived-read" -> GLOBAL_SW(OmitDerivedRead) + + "-ffoldr-build-on" -> GLOBAL_SW(FoldrBuildOn) + "-ffoldr-build-trace" -> GLOBAL_SW(FoldrBuildTrace) + + "-fstg-static-args" -> STG_TD(StgDoStaticArgs) + "-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis) + "-dstg-stats" -> STG_TD(D_stg_stats) + "-flambda-lift" -> STG_TD(StgDoLambdaLift) + "-fmassage-stg-for-profiling" -> STG_TD(StgDoMassageForProfiling) + + "-flet-no-escape" -> GLOBAL_SW(StgDoLetNoEscapes) + +#ifdef DPH + "-fpodize-vector" -> POD_TD(PodizeNeeded 1) + "-fpodize-matrix" -> POD_TD(PodizeNeeded 2) + "-fpodize-cube" -> POD_TD(PodizeNeeded 3) + "-fpodize-intelligent" -> GLOBAL_SW(PodizeIntelligent) + "-fpodize-aggresive" -> GLOBAL_SW(PodizeAggresive) + "-fpodize-very-aggresive" -> GLOBAL_SW(PodizeVeryAggresive) + "-fpodize-extremely-aggresive" -> GLOBAL_SW(PodizeExtremelyAggresive) +#endif {- Data Parallel Haskell -} + + "-v" -> GLOBAL_SW(Verbose) + + "-fglasgow-exts" -> GLOBAL_SW(GlasgowExts) + "-prelude" -> GLOBAL_SW(CompilingPrelude) + + "-fscc-profiling" -> GLOBAL_SW(SccProfilingOn) + "-fauto-sccs-on-exported-toplevs" -> GLOBAL_SW(AutoSccsOnExportedToplevs) + "-fauto-sccs-on-all-toplevs" -> GLOBAL_SW(AutoSccsOnAllToplevs) + "-fauto-sccs-on-individual-cafs" -> GLOBAL_SW(AutoSccsOnIndividualCafs) +--UNUSED: "-fauto-sccs-on-individual-dicts" -> GLOBAL_SW(AutoSccsOnIndividualDicts) + + "-fstg-reduction-counts" -> GLOBAL_SW(DoTickyProfiling) + + "-dppr-user" -> GLOBAL_SW(PprStyle_User) + "-dppr-debug" -> GLOBAL_SW(PprStyle_Debug) + "-dppr-all" -> GLOBAL_SW(PprStyle_All) + + "-fhide-builtin-names"-> GLOBAL_SW(HideBuiltinNames) + "-fmin-builtin-names" -> GLOBAL_SW(HideMostBuiltinNames) + + "-fconcurrent" -> GLOBAL_SW(ForConcurrent) + + "-fomit-unspecialised-code" -> GLOBAL_SW(OmitUnspecialisedCode) + "-fshow-pragma-name-errs" -> GLOBAL_SW(ShowPragmaNameErrs) + "-fname-shadowing-not-ok" -> GLOBAL_SW(NameShadowingNotOK) + "-fsignatures-required" -> GLOBAL_SW(SigsRequired) + "-fomit-reexported-instances" -> GLOBAL_SW(OmitReexportedInstances) + "-darity-checks" -> GLOBAL_SW(EmitArityChecks) +--UNUSED: "-dno-stk-chks" -> GLOBAL_SW(OmitStkChecks) + "-dno-black-holing"-> GLOBAL_SW(OmitBlackHoling) + + _ | starts_with_fasm -> GLOBAL_SW(AsmTarget after_fasm) + | starts_with_G -> GLOBAL_SW(SccGroup after_G) -- profiling "group" + | starts_with_C -> GLOBAL_SW(ProduceC after_C) -- main C output + | starts_with_S -> GLOBAL_SW(ProduceS after_S) -- main .s output + | starts_with_hi -> GLOBAL_SW(ProduceHi after_hi) -- interface +--UNUSED: | starts_with_hu -> GLOBAL_SW(ProduceHu after_hu) -- usage info + + | starts_with_uut -> GLOBAL_SW(UnfoldingUseThreshold (read after_uut)) + | starts_with_uct -> GLOBAL_SW(UnfoldingCreationThreshold (read after_uct)) + | starts_with_uot -> GLOBAL_SW(UnfoldingOverrideThreshold (read after_uot)) + + | starts_with_gtn -> GLOBAL_SW(EnsureSplittableC after_gtn) + + _ -> writeMn stderr ("*** WARNING: bad option: "++opt1++"\n") `thenMn` ( \ _ -> + -- NB: the driver is really supposed to handle bad options + IGNORE_ARG() ) + + ---------------- + + starts_with :: String -> String -> Maybe String + + starts_with [] str = Just str + starts_with (c:cs) (s:ss) + = if c /= s then Nothing else starts_with cs ss + + ---------------- + + -- ToDo: DPH-ify "simpl_sep"! + + simpl_sep :: [String] -- cmd-line opts (input) + -> [SimplifierSwitch] -- simplifier-switch accumulator + -> [GlobalSwitch] -- switch accumulator + -> [CoreToDo] -> [StgToDo] -- to_do accumulators + -> MainIO CmdLineInfo -- result + + -- "simpl_sep" tailcalls "sep" once it's seen one set + -- of SimplifierSwitches for a CoreDoSimplify. + +#ifdef DEBUG + simpl_sep input@[] simpl_sw glob_sw core_td stg_td + = panic "simpl_sep []" +#endif + + -- The SimplifierSwitches should be delimited by "(" and ")". + + simpl_sep ("(":opts) [{-better be empty-}] glob_sw core_td stg_td + = simpl_sep opts [] glob_sw core_td stg_td + + simpl_sep (")":opts) simpl_sw glob_sw core_td stg_td + = let + this_CoreDoSimplify = CoreDoSimplify (isAmongSimpl simpl_sw) + in + sep opts glob_sw (this_CoreDoSimplify : core_td) stg_td + + simpl_sep (opt1:opts) simpl_sw glob_sw core_td stg_td + = let + maybe_suut = starts_with "-fsimpl-uf-use-threshold" opt1 + maybe_suct = starts_with "-fsimpl-uf-creation-threshold" opt1 + maybe_msi = starts_with "-fmax-simplifier-iterations" opt1 + starts_with_suut = maybeToBool maybe_suut + starts_with_suct = maybeToBool maybe_suct + starts_with_msi = maybeToBool maybe_msi + (Just after_suut) = maybe_suut + (Just after_suct) = maybe_suct + (Just after_msi) = maybe_msi + in + case opt1 of -- the non-"just match a string" options are at the end... + "-fshow-simplifier-progress" -> GLOBAL_SIMPL_SW(ShowSimplifierProgress) + + "-fcode-duplication-ok" -> GLOBAL_SIMPL_SW(SimplOkToDupCode) + "-ffloat-lets-exposing-whnf" -> GLOBAL_SIMPL_SW(SimplFloatLetsExposingWHNF) + "-ffloat-primops-ok" -> GLOBAL_SIMPL_SW(SimplOkToFloatPrimOps) + "-falways-float-lets-from-lets" -> GLOBAL_SIMPL_SW(SimplAlwaysFloatLetsFromLets) + "-fdo-case-elim" -> GLOBAL_SIMPL_SW(SimplDoCaseElim) + "-fdo-eta-reduction" -> GLOBAL_SIMPL_SW(SimplDoEtaReduction) + "-fdo-lambda-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoLambdaEtaExpansion) +--UNUSED: "-fdo-monad-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoMonadEtaExpansion) + "-fdo-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoFoldrBuild) + "-fdo-new-occur-anal" -> GLOBAL_SIMPL_SW(SimplDoNewOccurAnal) + "-fdo-arity-expand" -> GLOBAL_SIMPL_SW(SimplDoArityExpand) + "-fdo-inline-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoInlineFoldrBuild) + "-freuse-con" -> GLOBAL_SIMPL_SW(SimplReuseCon) + "-fcase-of-case" -> GLOBAL_SIMPL_SW(SimplCaseOfCase) + "-flet-to-case" -> GLOBAL_SIMPL_SW(SimplLetToCase) + "-fpedantic-bottoms" -> GLOBAL_SIMPL_SW(SimplPedanticBottoms) + "-fkeep-spec-pragma-ids" -> GLOBAL_SIMPL_SW(KeepSpecPragmaIds) + "-fkeep-unused-bindings" -> GLOBAL_SIMPL_SW(KeepUnusedBindings) +--UNUSED: "-finline-in-lambdas-ok" -> GLOBAL_SIMPL_SW(SimplOkToInlineInLambdas) + "-fmay-delete-conjurable-ids" -> GLOBAL_SIMPL_SW(SimplMayDeleteConjurableIds) + "-fessential-unfoldings-only" -> GLOBAL_SIMPL_SW(EssentialUnfoldingsOnly) + "-fignore-inline-pragma" -> GLOBAL_SIMPL_SW(IgnoreINLINEPragma) + + _ | starts_with_msi -> GLOBAL_SIMPL_SW(MaxSimplifierIterations (read after_msi)) + | starts_with_suut -> GLOBAL_SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut)) + | starts_with_suct -> GLOBAL_SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct)) + + _ -> writeMn stderr ("*** WARNING: bad simplifier option: "++opt1++"\n") `thenMn` ( \ _ -> + -- NB: the driver is really supposed to handle bad options + simpl_sep opts simpl_sw glob_sw core_td stg_td ) +\end{code} + +%************************************************************************ +%* * +\subsection[CmdLineOpts-order]{Switch ordering} +%* * +%************************************************************************ + +In spite of the @Produce*@ and @SccGroup@ constructors, these things +behave just like enumeration types. + +\begin{code} +instance Eq GlobalSwitch where + a == b = tagOf_Switch a _EQ_ tagOf_Switch b + +instance Ord GlobalSwitch where + a < b = tagOf_Switch a _LT_ tagOf_Switch b + a <= b = tagOf_Switch a _LE_ tagOf_Switch b + +instance Eq SimplifierSwitch where + a == b = tagOf_SimplSwitch a _EQ_ tagOf_SimplSwitch b + +instance Ord SimplifierSwitch where + a < b = tagOf_SimplSwitch a _LT_ tagOf_SimplSwitch b + a <= b = tagOf_SimplSwitch a _LE_ tagOf_SimplSwitch b + +tagOf_Switch (ProduceC _) =(ILIT(0) :: FAST_INT) +tagOf_Switch (ProduceS _) = ILIT(1) +tagOf_Switch (ProduceHi _) = ILIT(2) +--UNUSED:tagOf_Switch (ProduceHu _) = ILIT(3) +tagOf_Switch (AsmTarget _) = ILIT(4) +--UNUSED:tagOf_Switch ForParallel = ILIT(5) +tagOf_Switch ForConcurrent = ILIT(6) +--UNUSED:tagOf_Switch ForGRIP = ILIT(7) +tagOf_Switch Haskell_1_3 = ILIT(8) +tagOf_Switch GlasgowExts = ILIT(9) +tagOf_Switch CompilingPrelude = ILIT(10) +tagOf_Switch HideBuiltinNames = ILIT(11) +tagOf_Switch HideMostBuiltinNames = ILIT(12) +tagOf_Switch (EnsureSplittableC _) = ILIT(13) +tagOf_Switch Verbose = ILIT(14) +tagOf_Switch PprStyle_User = ILIT(15) +tagOf_Switch PprStyle_Debug = ILIT(16) +tagOf_Switch PprStyle_All = ILIT(17) +tagOf_Switch DoCoreLinting = ILIT(18) +tagOf_Switch EmitArityChecks = ILIT(19) +tagOf_Switch OmitInterfacePragmas = ILIT(20) +tagOf_Switch OmitDerivedRead = ILIT(21) +tagOf_Switch OmitReexportedInstances = ILIT(22) +tagOf_Switch (UnfoldingUseThreshold _) = ILIT(23) +tagOf_Switch (UnfoldingCreationThreshold _) = ILIT(24) +tagOf_Switch (UnfoldingOverrideThreshold _) = ILIT(25) +tagOf_Switch ReportWhyUnfoldingsDisallowed = ILIT(26) +tagOf_Switch UseGetMentionedVars = ILIT(27) +tagOf_Switch ShowPragmaNameErrs = ILIT(28) +tagOf_Switch NameShadowingNotOK = ILIT(29) +tagOf_Switch SigsRequired = ILIT(30) +tagOf_Switch SccProfilingOn = ILIT(31) +tagOf_Switch AutoSccsOnExportedToplevs = ILIT(32) +tagOf_Switch AutoSccsOnAllToplevs = ILIT(33) +tagOf_Switch AutoSccsOnIndividualCafs = ILIT(34) +--UNUSED:tagOf_Switch AutoSccsOnIndividualDicts = ILIT(35) +tagOf_Switch (SccGroup _) = ILIT(36) +tagOf_Switch DoTickyProfiling = ILIT(37) +tagOf_Switch DoSemiTagging = ILIT(38) +tagOf_Switch FoldrBuildOn = ILIT(39) +tagOf_Switch FoldrBuildTrace = ILIT(40) +tagOf_Switch SpecialiseImports = ILIT(41) +tagOf_Switch ShowImportSpecs = ILIT(42) +tagOf_Switch OmitUnspecialisedCode = ILIT(43) +tagOf_Switch SpecialiseOverloaded = ILIT(44) +tagOf_Switch SpecialiseUnboxed = ILIT(45) +tagOf_Switch SpecialiseAll = ILIT(46) +tagOf_Switch SpecialiseTrace = ILIT(47) +--UNUSED:tagOf_Switch OmitStkChecks = ILIT(48) +tagOf_Switch OmitBlackHoling = ILIT(49) +tagOf_Switch StgDoLetNoEscapes = ILIT(50) +tagOf_Switch IgnoreStrictnessPragmas = ILIT(51) +tagOf_Switch IrrefutableTuples = ILIT(52) +tagOf_Switch IrrefutableEverything = ILIT(53) +tagOf_Switch AllStrict = ILIT(54) +tagOf_Switch AllDemanded = ILIT(55) +-- NOT REALLY USED: tagOf_Switch D_dump_type_info = ILIT(56) +tagOf_Switch D_dump_rif2hs = ILIT(57) +tagOf_Switch D_dump_rn4 = ILIT(58) +tagOf_Switch D_dump_tc = ILIT(59) +tagOf_Switch D_dump_deriv = ILIT(60) +tagOf_Switch D_dump_ds = ILIT(61) +tagOf_Switch D_dump_simpl = ILIT(62) +tagOf_Switch D_dump_spec = ILIT(63) +tagOf_Switch D_dump_occur_anal = ILIT(64) +tagOf_Switch D_dump_stranal = ILIT(65) +tagOf_Switch D_dump_stg = ILIT(66) +tagOf_Switch D_dump_absC = ILIT(67) +tagOf_Switch D_dump_flatC = ILIT(68) +tagOf_Switch D_dump_realC = ILIT(69) +tagOf_Switch D_dump_asm = ILIT(70) +tagOf_Switch D_dump_core_passes = ILIT(71) +tagOf_Switch D_dump_core_passes_info = ILIT(72) +tagOf_Switch D_verbose_core2core = ILIT(73) +tagOf_Switch D_verbose_stg2stg = ILIT(74) +tagOf_Switch D_simplifier_stats = ILIT(75) {-note below-} + +{- +tagOf_Switch Extra__Flag1 = ILIT(76) +tagOf_Switch Extra__Flag2 = ILIT(77) +tagOf_Switch Extra__Flag3 = ILIT(78) +tagOf_Switch Extra__Flag4 = ILIT(79) +tagOf_Switch Extra__Flag5 = ILIT(80) +tagOf_Switch Extra__Flag6 = ILIT(81) +tagOf_Switch Extra__Flag7 = ILIT(82) +tagOf_Switch Extra__Flag8 = ILIT(83) +tagOf_Switch Extra__Flag9 = ILIT(84) +-} + +#ifndef DPH +tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance + s -> tagOf_Switch s + +lAST_SWITCH_TAG = IBOX(tagOf_Switch D_simplifier_stats) + +#else {- Data Parallel Haskell -} + +tagOf_Switch PodizeIntelligent = ILIT(90) +tagOf_Switch PodizeAggresive = ILIT(91) +tagOf_Switch PodizeVeryAggresive = ILIT(92) +tagOf_Switch PodizeExtremelyAggresive = ILIT(93) +tagOf_Switch D_dump_pod = ILIT(94) +tagOf_Switch D_dump_psimpl = ILIT(95) +tagOf_Switch D_dump_nextC = ILIT(96) + +tagOf_Switch _ = case (panic "tagOf_Switch") of -- BUG avoidance + s -> tagOf_Switch s + +lAST_SWITCH_TAG = IBOX(tagOf_Switch D_dump_nextC) + +#endif {- Data Parallel Haskell -} +\end{code} + +(Note For Will): Could you please leave a little extra room between +your last option and @D_dump_spec@... Thanks... jon... + +\begin{code} +tagOf_SimplSwitch SimplOkToDupCode =(ILIT(0) :: FAST_INT) +tagOf_SimplSwitch SimplFloatLetsExposingWHNF = ILIT(1) +tagOf_SimplSwitch SimplOkToFloatPrimOps = ILIT(2) +tagOf_SimplSwitch SimplAlwaysFloatLetsFromLets = ILIT(3) +tagOf_SimplSwitch SimplDoCaseElim = ILIT(4) +tagOf_SimplSwitch SimplReuseCon = ILIT(5) +tagOf_SimplSwitch SimplCaseOfCase = ILIT(6) +tagOf_SimplSwitch SimplLetToCase = ILIT(7) +--UNUSED:tagOf_SimplSwitch SimplOkToInlineInLambdas = ILIT(8) +tagOf_SimplSwitch SimplMayDeleteConjurableIds = ILIT(9) +tagOf_SimplSwitch SimplPedanticBottoms = ILIT(10) +tagOf_SimplSwitch SimplDoArityExpand = ILIT(11) +tagOf_SimplSwitch SimplDoFoldrBuild = ILIT(12) +tagOf_SimplSwitch SimplDoNewOccurAnal = ILIT(13) +tagOf_SimplSwitch SimplDoInlineFoldrBuild = ILIT(14) +tagOf_SimplSwitch IgnoreINLINEPragma = ILIT(15) +tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16) +--UNUSED:tagOf_SimplSwitch SimplDoMonadEtaExpansion = ILIT(17) +tagOf_SimplSwitch SimplDoEtaReduction = ILIT(18) +tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19) +tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20) +tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21) +tagOf_SimplSwitch (SimplUnfoldingUseThreshold _) = ILIT(22) +tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(23) +tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(24) +tagOf_SimplSwitch KeepUnusedBindings = ILIT(25) + +{- +tagOf_SimplSwitch Extra__SimplFlag1 = ILIT(26) +tagOf_SimplSwitch Extra__SimplFlag2 = ILIT(27) +tagOf_SimplSwitch Extra__SimplFlag3 = ILIT(28) +tagOf_SimplSwitch Extra__SimplFlag4 = ILIT(29) +tagOf_SimplSwitch Extra__SimplFlag5 = ILIT(30) +tagOf_SimplSwitch Extra__SimplFlag6 = ILIT(31) +tagOf_SimplSwitch Extra__SimplFlag8 = ILIT(32) +-} + +tagOf_SimplSwitch _ = case (panic "tagOf_SimplSwitch") of -- BUG avoidance + s -> tagOf_SimplSwitch s + +lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch KeepUnusedBindings) +\end{code} + +%************************************************************************ +%* * +\subsection[CmdLineOpts-lookup]{Switch lookup} +%* * +%************************************************************************ + +\begin{code} +isAmong :: [GlobalSwitch] -> GlobalSwitch -> SwitchResult +isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult + +isAmong on_switches + = let + tidied_on_switches = foldl rm_dups [] on_switches + + sw_tbl :: Array Int SwitchResult + + sw_tbl = (array (0, lAST_SWITCH_TAG) -- bounds... + all_undefined) + // defined_elems + + all_undefined = [ i := SwBool False | i <- [0 .. lAST_SWITCH_TAG ] ] + + defined_elems = map mk_assoc_elem tidied_on_switches + in +#ifndef __GLASGOW_HASKELL__ + \ switch -> sw_tbl ! IBOX((tagOf_Switch switch)) -- but this is fast! +#else + -- and this is faster! + -- (avoid some unboxing, bounds checking, and other horrible things:) + case sw_tbl of { _Array bounds_who_needs_'em stuff -> + \ switch -> + case (indexArray# stuff (tagOf_Switch switch)) of + _Lift v -> v + } +#endif + where + mk_assoc_elem k@(ProduceC str) = IBOX(tagOf_Switch k) := SwString str + mk_assoc_elem k@(ProduceS str) = IBOX(tagOf_Switch k) := SwString str + mk_assoc_elem k@(ProduceHi str) = IBOX(tagOf_Switch k) := SwString str +--UNUSED: mk_assoc_elem k@(ProduceHu str) = IBOX(tagOf_Switch k) := SwString str + mk_assoc_elem k@(SccGroup str) = IBOX(tagOf_Switch k) := SwString str + mk_assoc_elem k@(AsmTarget str) = IBOX(tagOf_Switch k) := SwString str + mk_assoc_elem k@(EnsureSplittableC str) = IBOX(tagOf_Switch k) := SwString str + + mk_assoc_elem k@(UnfoldingUseThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl + mk_assoc_elem k@(UnfoldingCreationThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl + mk_assoc_elem k@(UnfoldingOverrideThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl + + mk_assoc_elem k = IBOX(tagOf_Switch k) := SwBool True -- I'm here, Mom! + + -- cannot have duplicates if we are going to use the array thing + + rm_dups switches_so_far switch + = if switch `is_elem` switches_so_far + then switches_so_far + else switch : switches_so_far + where + sw `is_elem` [] = False + sw `is_elem` (s:ss) = (tagOf_Switch sw) _EQ_ (tagOf_Switch s) + || sw `is_elem` ss +\end{code} + +Same thing for @SimplifierSwitches@; for efficiency reasons, we +probably do {\em not} want something overloaded. + \begin{code} +isAmongSimpl on_switches + = let + tidied_on_switches = foldl rm_dups [] on_switches + + sw_tbl :: Array Int SwitchResult + + sw_tbl = (array (0, lAST_SIMPL_SWITCH_TAG) -- bounds... + all_undefined) + // defined_elems + + all_undefined = [ i := SwBool False | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] + + defined_elems = map mk_assoc_elem tidied_on_switches + in +#ifndef __GLASGOW_HASKELL__ + \ switch -> sw_tbl ! IBOX((tagOf_SimplSwitch switch)) -- but this is fast! +#else + -- and this is faster! + -- (avoid some unboxing, bounds checking, and other horrible things:) + case sw_tbl of { _Array bounds_who_needs_'em stuff -> + \ switch -> + case (indexArray# stuff (tagOf_SimplSwitch switch)) of + _Lift v -> v + } +#endif + where + mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) := SwInt lvl + mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i + mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i + + mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) := SwBool True -- I'm here, Mom! + + -- cannot have duplicates if we are going to use the array thing + + rm_dups switches_so_far switch + = if switch `is_elem` switches_so_far + then switches_so_far + else switch : switches_so_far + where + sw `is_elem` [] = False + sw `is_elem` (s:ss) = (tagOf_SimplSwitch sw) _EQ_ (tagOf_SimplSwitch s) + || sw `is_elem` ss +\end{code} + +%************************************************************************ +%* * +\subsection[CmdLineOpts-misc]{Misc functions for command-line options} +%* * +%************************************************************************ + + +\begin{code} +switchIsOn :: (switch -> SwitchResult) -> switch -> Bool + +switchIsOn lookup_fn switch + = case (lookup_fn switch) of + SwBool False -> False + _ -> True + +stringSwitchSet :: (switch -> SwitchResult) + -> (String -> switch) + -> Maybe String + +stringSwitchSet lookup_fn switch + = case (lookup_fn (switch (panic "stringSwitchSet"))) of + SwString str -> Just str + _ -> Nothing + +intSwitchSet :: (switch -> SwitchResult) + -> (Int -> switch) + -> Maybe Int + +intSwitchSet lookup_fn switch + = case (lookup_fn (switch (panic "intSwitchSet"))) of + SwInt int -> Just int + _ -> Nothing +\end{code} diff --git a/ghc/compiler/main/ErrUtils.hi b/ghc/compiler/main/ErrUtils.hi new file mode 100644 index 0000000..62a5f4d --- /dev/null +++ b/ghc/compiler/main/ErrUtils.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ErrUtils where +import Bag(Bag) +import Pretty(PprStyle, PrettyRep) +import SrcLoc(SrcLoc) +type Error = PprStyle -> Int -> Bool -> PrettyRep +addErrLoc :: SrcLoc -> [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 221222 _N_ _N_ _N_ _N_ #-} +addShortErrLocLine :: SrcLoc -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "SLL" _N_ _N_ #-} +dontAddErrLoc :: [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _N_ _N_ _N_ #-} +pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs new file mode 100644 index 0000000..5146016 --- /dev/null +++ b/ghc/compiler/main/ErrUtils.lhs @@ -0,0 +1,61 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[ErrsUtils]{Utilities for error reporting} + +This is an internal module---access to these functions is through +@Errors@. + +DPH errors are in here, too. + +\begin{code} +#include "HsVersions.h" + +module ErrUtils where + +import Bag ( Bag, bagToList ) +import Outputable +import Pretty -- to pretty-print error messages +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} + +\begin{code} +type Error = PprStyle -> Pretty + +addErrLoc :: SrcLoc -> String -> Error -> Error +addErrLoc locn title rest_of_err_msg sty + = ppHang (ppBesides [ppr PprForUser locn, + if null title then ppNil else ppStr (": " ++ title), + ppChar ':']) + 4 (rest_of_err_msg sty) + +addShortErrLocLine :: SrcLoc -> Error -> Error +addShortErrLocLine locn rest_of_err_msg sty + = ppHang (ppBeside (ppr PprForUser locn) (ppChar ':')) + 4 (rest_of_err_msg sty) + +dontAddErrLoc :: String -> Error -> Error +dontAddErrLoc title rest_of_err_msg sty + = ppHang (ppBesides [ppStr title, ppChar ':']) + 4 (rest_of_err_msg sty) + +pprBagOfErrors :: PprStyle -> Bag Error -> Pretty +pprBagOfErrors sty bag_of_errors + = let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in + ppAboves (map (\ p -> ppAbove ppSP p) pretties) + +#ifdef DPH +addWarningLoc :: SrcLoc -> Error -> Error +addWarningLoc locn rest_of_err_msg sty + = ppHang (ppBesides [ppStr "*** Warning *** ", + ppr PprForUser locn,ppStr ": "]) + 4 (ppAbove (rest_of_err_msg sty) + (ppSP)) + +addWarning :: Error -> Error +addWarning rest_of_err_msg sty + = ppBeside (ppStr "*** Warning *** : ") + (rest_of_err_msg sty) +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/main/Errors.hi b/ghc/compiler/main/Errors.hi new file mode 100644 index 0000000..76dfebe --- /dev/null +++ b/ghc/compiler/main/Errors.hi @@ -0,0 +1,173 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Errors where +import Bag(Bag) +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..), pprBagOfErrors) +import ErrsRn(badClassOpErr, badExportNameErr, badImportNameErr, derivingInIfaceErr, derivingNonStdClassErr, dupNamesErr, dupPreludeNameErr, dupSigDeclErr, duplicateImportsInInterfaceErr, inlineInRecursiveBindsErr, methodBindErr, missingSigErr, shadowedNameErr, unknownNameErr, unknownSigDeclErr, weirdImportExportConstraintErr) +import ErrsTc(UnifyErrContext(..), UnifyErrInfo(..), ambigErr, badMatchErr, badSpecialisationErr, classCycleErr, confusedNameErr, dataConArityErr, defaultErr, derivingEnumErr, derivingIxErr, derivingWhenInstanceExistsErr, dupInstErr, genCantGenErr, instTypeErr, methodTypeLacksTyVarErr, naughtyCCallContextErr, noInstanceErr, nonBoxedPrimCCallErr, notAsPolyAsSigErr, preludeInstanceErr, reduceErr, sigContextsErr, specCtxtGroundnessErr, specDataNoSpecErr, specDataUnboxedErr, specGroundnessErr, specInstUnspecInstNotFoundErr, topLevelUnboxedDeclErr, tyConArityErr, typeCycleErr, unifyErr, varyingArgsErr) +import GenSpecEtc(SignatureInfo) +import HsBinds(Binds, MonoBinds, ProtoNameMonoBinds(..), RenamedSig(..), Sig) +import HsExpr(ArithSeqInfo, Expr, Qual, RenamedExpr(..), TypecheckedExpr(..)) +import HsImpExp(IE) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match, RenamedGRHS(..), RenamedGRHSsAndBinds(..), RenamedMatch(..)) +import HsPat(InPat, ProtoNamePat(..), RenamedPat(..), TypecheckedPat) +import HsPragmas(ClassOpPragmas, GenPragmas, ImpStrictness, ImpUnfolding) +import HsTypes(MonoType, PolyType) +import Id(Id, IdDetails) +import IdInfo(DeforestInfo, IdInfo, UpdateInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import InstEnv(InstTemplate) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import ProtoName(ProtoName) +import SimplEnv(UnfoldingGuidance) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(TauType(..), UniType) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data UnifyErrContext + = PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType +data UnifyErrInfo = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] +data SignatureInfo {-# GHC_PRAGMA TySigInfo Id [TyVar] [Inst] UniType SrcLoc | ValSpecInfo Name UniType (Labda Name) SrcLoc | ValInlineInfo Name UnfoldingGuidance SrcLoc | ValDeforestInfo Name SrcLoc | ValMagicUnfoldingInfo Name _PackedString SrcLoc #-} +data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-} +type ProtoNameMonoBinds = MonoBinds ProtoName (InPat ProtoName) +type RenamedSig = Sig Name +data Sig a {-# GHC_PRAGMA Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +type RenamedExpr = Expr Name (InPat Name) +type TypecheckedExpr = Expr Id TypecheckedPat +data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-} +data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-} +data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-} +data Match a b {-# GHC_PRAGMA PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) #-} +type RenamedGRHS = GRHS Name (InPat Name) +type RenamedGRHSsAndBinds = GRHSsAndBinds Name (InPat Name) +type RenamedMatch = Match Name (InPat Name) +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type ProtoNamePat = InPat ProtoName +type RenamedPat = InPat Name +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TauType = UniType +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 1222222 _N_ _N_ _N_ _N_ #-} +derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LSL" _N_ _N_ #-} +dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LU(LS)L" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 00222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 5 XXXXX 5 \ (u0 :: [Char]) (u1 :: [ProtoName]) (u2 :: PprStyle) (u3 :: Int) (u4 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (PprStyle -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "duplicateImportsInInterfaceErr: NOT DONE YET?", u2, u3, u4 ] _N_ #-} +inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _S_ "S" _N_ _N_ #-} +methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SLL" _N_ _N_ #-} +shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-} +badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 12002222 _N_ _S_ "LLAAL" {_A_ 3 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-} +confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _N_ _N_ _N_ #-} +derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 22222 _N_ _N_ _N_ _N_ #-} +dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "U(LU(LL)U(AL))L" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-} +instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 0222222 _N_ _S_ "ALLLL" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 11222 _N_ _S_ "SLL" _N_ _N_ #-} +specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SLL" _N_ _N_ #-} +specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-} +unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 20222 _N_ _S_ "LAL" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/main/Errors.lhs b/ghc/compiler/main/Errors.lhs new file mode 100644 index 0000000..ae2e631 --- /dev/null +++ b/ghc/compiler/main/Errors.lhs @@ -0,0 +1,122 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Errors]{Error reporting} + +This module now merely re-exports the work of @ErrsRn@ and @ErrsTc@; +this is the public interface. (WDP 94/06) + +\begin{code} +#include "HsVersions.h" + +module Errors ( + Error(..), + pprBagOfErrors, + + -- renamer errors: + badClassOpErr, + badExportNameErr, + badImportNameErr, + derivingInIfaceErr, + derivingNonStdClassErr, + dupNamesErr, + dupPreludeNameErr, + dupSigDeclErr, + duplicateImportsInInterfaceErr, + inlineInRecursiveBindsErr, + missingSigErr, +-- mismatchedPragmasErr, UNUSED + shadowedNameErr, + unknownNameErr, + unknownSigDeclErr, + weirdImportExportConstraintErr, + + -- typechecker errors: + ambigErr, + badMatchErr, + badSpecialisationErr, + confusedNameErr, + classCycleErr, + typeCycleErr, + dataConArityErr, + defaultErr, + derivingEnumErr, + derivingIxErr, + derivingWhenInstanceExistsErr, +-- derivingNoSuperClassInstanceErr, UNUSED + dupInstErr, +-- extraMethodsErr, UNUSED + genCantGenErr, +-- genPrimTyVarErr, UNUSED + noInstanceErr, +-- instOpErr, UNUSED + instTypeErr, +-- methodInstErr, UNUSED + methodBindErr, + methodTypeLacksTyVarErr, +-- missingClassOpErr, UNUSED + naughtyCCallContextErr, + nonBoxedPrimCCallErr, + notAsPolyAsSigErr, +-- patMatchWithPrimErr, UNUSED + preludeInstanceErr, +-- purelyLocalErr, UNUSED + reduceErr, + sigContextsErr, + specGroundnessErr, + specCtxtGroundnessErr, + specDataNoSpecErr, + specDataUnboxedErr, + specInstUnspecInstNotFoundErr, + topLevelUnboxedDeclErr, + tyConArityErr, + unifyErr, + varyingArgsErr, +#ifdef DPH + podCompLhsError, + pprPodizedWarning, + PodWarning, +#endif {- Data Parallel Haskell -} + + UnifyErrContext(..), + UnifyErrInfo(..), + + -- and to make the interface self-sufficient + Bag, Class, ClassOp, MonoBinds, ProtoNameMonoBinds(..), Sig, + RenamedSig(..), Expr, RenamedExpr(..), GRHS, RenamedGRHS(..), + GRHSsAndBinds, RenamedGRHSsAndBinds(..), Match, IE, + RenamedMatch(..), InPat, ProtoNamePat(..), RenamedPat(..), + GenPragmas, Id, Inst, Name, PprStyle, Pretty(..), PrettyRep, + ProtoName, SrcLoc, TyCon, TyVar, TyVarTemplate, UniType, + TauType(..), Maybe, SignatureInfo, TypecheckedPat, + TypecheckedExpr(..) + ) where + +-- I don't know how much of this is needed... (WDP 94/06) + +import ErrsRn +import ErrsTc +import ErrUtils + +import AbsSyn -- we print a bunch of stuff in here +import UniType ( UniType(..) ) -- Concrete, to make some errors + -- more informative. +import AbsUniType ( TyVar, TyVarTemplate, TyCon, + TauType(..), Class, ClassOp + IF_ATTACK_PRAGMAS(COMMA pprUniType) + ) +import Bag ( Bag, bagToList ) +import GenSpecEtc ( SignatureInfo(..) ) +import HsMatches ( pprMatches, pprMatch, pprGRHS ) +import Id ( getIdUniType, Id, isSysLocalId ) +import Inst ( getInstOrigin, getDictClassAndType, Inst ) +import Maybes ( Maybe(..) ) +import Name ( cmpName ) +import Outputable +import Pretty -- to pretty-print error messages +#ifdef DPH +import PodizeMonad ( PodWarning(..) ) +#endif {- Data Parallel Haskell -} +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} diff --git a/ghc/compiler/main/ErrsRn.hi b/ghc/compiler/main/ErrsRn.hi new file mode 100644 index 0000000..558890e --- /dev/null +++ b/ghc/compiler/main/ErrsRn.hi @@ -0,0 +1,42 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ErrsRn where +import HsBinds(MonoBinds, Sig) +import HsImpExp(IE) +import HsPat(InPat) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 1222222 _N_ _N_ _N_ _N_ #-} +derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LSL" _N_ _N_ #-} +dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LU(LS)L" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 00222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 5 XXXXX 5 \ (u0 :: [Char]) (u1 :: [ProtoName]) (u2 :: PprStyle) (u3 :: Int) (u4 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (PprStyle -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "duplicateImportsInInterfaceErr: NOT DONE YET?", u2, u3, u4 ] _N_ #-} +inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _S_ "S" _N_ _N_ #-} +methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SLL" _N_ _N_ #-} +shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} + diff --git a/ghc/compiler/main/ErrsRn.lhs b/ghc/compiler/main/ErrsRn.lhs new file mode 100644 index 0000000..72b7dc3 --- /dev/null +++ b/ghc/compiler/main/ErrsRn.lhs @@ -0,0 +1,194 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[ErrsRn]{Reporting errors from the renamer} + +This is an internal module---access to these functions is through +@Errors@. + +\begin{code} +#include "HsVersions.h" + +module ErrsRn where + +import AbsSyn -- we print a bunch of stuff in here +import AbsUniType ( TyVarTemplate ) +import UniType ( UniType(..) ) + -- UniType is concrete, to make some errors + -- more informative. +import ErrUtils +import Name ( cmpName ) +import Outputable +import Pretty -- to pretty-print error messages +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} + +\begin{code} +badClassOpErr :: Name{-class-} -> ProtoName{-op-} -> SrcLoc -> Error + -- Class op expected but something else found +badClassOpErr clas op locn + = addErrLoc locn "" ( \ sty -> + ppBesides [ppChar '`', ppr sty op, ppStr "' is not an operation of class `", + ppr sty clas, ppStr "'."] ) + +---------------------------------------------------------------- +badExportNameErr :: String -> String -> Error + +badExportNameErr name whats_wrong + = dontAddErrLoc + "Error in the export list" ( \ sty -> + ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] ) + +---------------------------------------------------------------- +badImportNameErr :: String -> String -> String -> SrcLoc -> Error + +badImportNameErr mod name whats_wrong locn + = addErrLoc locn + ("Error in an import list for the module `"++mod++"'") ( \ sty -> + ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] ) + +---------------------------------------------------------------- +derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> Error + -- GHC doesn't support "deriving" in interfaces + +derivingInIfaceErr ty deriveds locn + = addErrLoc locn "Glasgow Haskell doesn't support `deriving' in interfaces" ( \ sty -> + ppBesides [ ppStr "type: ", ppr sty ty, + ppStr "; derived: ", interpp'SP sty deriveds ] ) + +---------------------------------------------------------------- +derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> Error + -- if "deriving" specified for a non-standard class + +derivingNonStdClassErr tycon clas locn + = addErrLoc locn "Can't have a derived instance of this class" ( \ sty -> + ppBesides [ppStr "type constructor: ", ppr sty tycon, + ppStr "; class: ", ppr sty clas] ) + +---------------------------------------------------------------- +dupNamesErr :: String -> [(ProtoName,SrcLoc)] -> Error + +dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty + = ppAboves (first_item : map dup_item dup_things) + where + first_item + = ppBesides [ ppr PprForUser locn1, + ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ", + ppr sty first_pname ] + + dup_item (pname, locn) + = ppBesides [ ppr PprForUser locn, + ppStr ": here was another declaration of `", ppr sty pname, ppStr "'" ] + +---------------------------------------------------------------- +dupPreludeNameErr :: String -> (ProtoName, SrcLoc) -> Error + +dupPreludeNameErr descriptor (nm, locn) + = addShortErrLocLine locn ( \ sty -> + ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor, + ppStr ": ", ppr sty nm ]) + +---------------------------------------------------------------- +dupSigDeclErr :: [RenamedSig] -> Error + -- Duplicate signatures in a group; the sigs have locns on them +dupSigDeclErr sigs + = let + undup_sigs = fst (removeDups cmp_sig sigs) + in + addErrLoc locn1 + ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty -> + ppAboves (map (ppr sty) undup_sigs) ) + where + (what_it_is, locn1) + = case (head sigs) of + Sig _ _ _ loc -> ("type signature",loc) + ClassOpSig _ _ _ loc -> ("class-method type signature", loc) + SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc) + InlineSig _ _ loc -> ("INLINE pragma",loc) + MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc) + + cmp_sig a b = get_name a `cmpName` get_name b + + get_name (Sig n _ _ _) = n + get_name (ClassOpSig n _ _ _) = n + get_name (SpecSig n _ _ _) = n + get_name (InlineSig n _ _) = n + get_name (MagicUnfoldingSig n _ _) = n + +---------------------------------------------------------------- +duplicateImportsInInterfaceErr :: String -> [ProtoName] -> Error +duplicateImportsInInterfaceErr iface dups + = panic "duplicateImportsInInterfaceErr: NOT DONE YET?" + +---------------------------------------------------------------- +inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> Error + +inlineInRecursiveBindsErr [(name, locn)] + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "INLINE pragma for a recursive definition: ", + ppr sty name] ) +inlineInRecursiveBindsErr names_n_locns + = \ sty -> + ppHang (ppStr "INLINE pragmas for some recursive definitions:") + 4 (ppAboves [ ppBesides [ppr PprForUser locn, ppStr ": ", ppr sty n] + | (n, locn) <- names_n_locns ]) + +---------------------------------------------------------------- +--mismatchedPragmasErr :: (Annotations, SrcLoc) +-- -> (Annotations, SrcLoc) +-- -> Error +{- UNUSED: +mismatchedPragmasErr (anns1, _) (anns2, _) + = dontAddErrLoc "Mismatched pragmas from interfaces" ( \ sty -> + ppSep [ppr sty anns1, ppr sty anns2] ) +-} + +---------------------------------------------------------------- +shadowedNameErr :: Name -> SrcLoc -> Error +shadowedNameErr shadow locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "more than one value with the same name (shadowing): ", + ppr sty shadow] ) + +---------------------------------------------------------------- +unknownNameErr :: String -> ProtoName -> SrcLoc -> Error +unknownNameErr descriptor undef_thing locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", + ppr sty undef_thing] ) + +---------------------------------------------------------------- +missingSigErr :: SrcLoc -> ProtoName -> Error + -- Top-level definition without a type signature + -- (when SigsRequired flag is in use) +missingSigErr locn var + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "a definition but no type signature for `", + ppr sty var, + ppStr "'."]) + +---------------------------------------------------------------- +unknownSigDeclErr :: String -> ProtoName -> SrcLoc -> Error + -- Signature/Pragma given for unknown variable +unknownSigDeclErr flavor var locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr flavor, ppStr " but no definition for `", + ppr sty var, + ppStr "'."]) + +---------------------------------------------------------------- +weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> Error + +weirdImportExportConstraintErr thing constraint locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "Illegal import/export constraint on `", + ppr sty thing, + ppStr "': ", ppr PprForUser constraint]) + +---------------------------------------------------------------- +methodBindErr :: ProtoNameMonoBinds -> SrcLoc -> Error +methodBindErr mbind locn + = addErrLoc locn "Can't handle multiple methods defined by one pattern binding" + (\ sty -> ppr sty mbind) +\end{code} diff --git a/ghc/compiler/main/ErrsTc.hi b/ghc/compiler/main/ErrsTc.hi new file mode 100644 index 0000000..f087597 --- /dev/null +++ b/ghc/compiler/main/ErrsTc.hi @@ -0,0 +1,82 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ErrsTc where +import Class(Class) +import GenSpecEtc(SignatureInfo) +import HsExpr(Expr) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import Inst(Inst) +import Maybes(Labda) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +data UnifyErrContext + = PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType +data UnifyErrInfo = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] +ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-} +badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 12002222 _N_ _S_ "LLAAL" {_A_ 3 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-} +confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _N_ _N_ _N_ #-} +derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 22222 _N_ _N_ _N_ _N_ #-} +dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "U(LU(LL)U(AL))L" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-} +instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-} +nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 0222222 _N_ _S_ "ALLLL" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-} +sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 11222 _N_ _S_ "SLL" _N_ _N_ #-} +specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SLL" _N_ _N_ #-} +specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-} +topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-} +typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-} +unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-} +varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 20222 _N_ _S_ "LAL" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/main/ErrsTc.lhs b/ghc/compiler/main/ErrsTc.lhs new file mode 100644 index 0000000..9d946e7 --- /dev/null +++ b/ghc/compiler/main/ErrsTc.lhs @@ -0,0 +1,935 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[ErrsTc]{Reporting errors from the typechecker} + +This is an internal module---access to these functions is through +@Errors@. + +DPH errors are in here, too. + +\begin{code} +#include "HsVersions.h" + +module ErrsTc ( + UnifyErrContext(..), UnifyErrInfo(..), + + ambigErr, + badMatchErr, + badSpecialisationErr, + classCycleErr, + confusedNameErr, + dataConArityErr, + defaultErr, + derivingEnumErr, + derivingIxErr, + derivingWhenInstanceExistsErr, + dupInstErr, + genCantGenErr, + instTypeErr, + methodTypeLacksTyVarErr, + naughtyCCallContextErr, + noInstanceErr, + nonBoxedPrimCCallErr, + notAsPolyAsSigErr, + preludeInstanceErr, + reduceErr, + sigContextsErr, + specCtxtGroundnessErr, + specDataNoSpecErr, + specDataUnboxedErr, + specGroundnessErr, + specInstUnspecInstNotFoundErr, + topLevelUnboxedDeclErr, + tyConArityErr, + typeCycleErr, + unifyErr, + varyingArgsErr + ) where + +import AbsSyn -- we print a bunch of stuff in here +import UniType ( UniType(..) ) -- Concrete, to make some errors + -- more informative. +import ErrUtils +import AbsUniType ( extractTyVarsFromTy, pprMaybeTy, + TyVar, TyVarTemplate, TyCon, + TauType(..), Class, ClassOp + IF_ATTACK_PRAGMAS(COMMA pprUniType) + ) +import Bag ( Bag, bagToList ) +import GenSpecEtc ( SignatureInfo(..) ) +import HsMatches ( pprMatches, pprMatch, pprGRHS ) +import Id ( getIdUniType, Id, isSysLocalId ) +import Inst ( getInstOrigin, getDictClassAndType, Inst ) +import Name ( cmpName ) +import Outputable +import Pretty -- to pretty-print error messages +#ifdef DPH +import PodizeMonad ( PodWarning(..) ) +#endif {- Data Parallel Haskell -} +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} + +\begin{code} +ambigErr :: [Inst] -> Error +ambigErr insts@(inst1:_) + = addErrLoc loc1 "Ambiguous overloading" ( \ sty -> + ppAboves (map (ppr_inst sty) insts) ) + where + (loc1, _) = getInstOrigin inst1 + +ppr_inst sty inst + = let + (clas, ty) = getDictClassAndType inst + (locn, msg) = getInstOrigin inst + in + ppSep [ ppBesides [ppStr "class `", ppr sty clas, + ppStr "', type `", ppr sty ty, ppStr "'"], + ppBesides [ppStr "(", msg sty, ppStr ")"] ] + +---------------------------------------------------------------- +badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> Error +badMatchErr sig_ty inferred_ty ctxt locn + = addErrLoc locn "Type signature mismatch" ( \ sty -> + let + thing + = case ctxt of + SigCtxt id _ -> ppBesides [ppChar '`', ppr sty id, ppChar '\''] + MethodSigCtxt op _ -> ppBesides [ppStr "class method `", ppr sty op, ppStr "'"] + ExprSigCtxt _ _ -> ppStr "an expression" + Rank2ArgCtxt _ _ -> ppStr "an expression with rank-2 polymorphic type(!)" + ctxt -> pprUnifyErrContext sty ctxt + -- the latter is ugly, but better than a patt-match failure + in + ppAboves [ppSep [ + ppStr "Signature for", thing, ppStr "doesn't match its inferred type." + ], + ppHang (ppStr "Signature:") 4 (ppr sty sig_ty), + ppHang (ppStr "Inferred type:") 4 (ppr sty inferred_ty) + ] ) + +---------------------------------------------------------------- +badSpecialisationErr :: String -> String -> Int -> [Maybe UniType] -> SrcLoc -> Error + +badSpecialisationErr flavor messg no_tyvars ty_maybes locn + = addErrLoc locn ("Bad "++flavor++" specialisation pragma: "++messg) ( \ sty -> + ppStr "MSG NOT DONE YET" + ) + +---------------------------------------------------------------- +confusedNameErr :: String + -> Name -- the confused name + -> SrcLoc + -> Error +confusedNameErr msg nm locn + = addErrLoc locn msg ( \ sty -> + ppr sty nm ) +{- + where + msg = if flag then "Type constructor used where a class is expected" + else "Class used where a type constructor is expected" +-} + +---------------------------------------------------------------- +typeCycleErr :: [[(Pretty, SrcLoc)]] -> Error +typeCycleErr = cycleErr "The following type synonyms refer to themselves:" + +classCycleErr :: [[(Pretty, SrcLoc)]] -> Error +classCycleErr = cycleErr "The following classes form a cycle:" + +cycleErr :: String -> [[(Pretty, SrcLoc)]] -> Error +cycleErr msg cycles sty + = ppHang (ppStr msg) + 4 (ppAboves (map pp_cycle cycles)) + where + pp_cycle things = ppAboves (map pp_thing things) + pp_thing (thing,loc) = ppHang (ppBesides [ppr PprForUser loc, ppStr ": "]) 4 thing + +---------------------------------------------------------------- +defaultErr :: [Inst]{-dicts-} -> [UniType] -> Error + -- when default-resolution fails... + +defaultErr dicts defaulting_tys sty + = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:") + 4 (ppAboves [ + ppHang (ppStr "Conflicting:") + 4 (ppInterleave ppSemi (map (ppr_inst sty) dicts)), + ppHang (ppStr "Defaulting types :") + 4 (ppr sty defaulting_tys), + ppStr "([Int, Double] is the default list of defaulting types.)" ]) + +---------------------------------------------------------------- +derivingEnumErr :: TyCon -> Error +derivingEnumErr tycon + = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty -> + ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] ) + +---------------------------------------------------------------- +derivingIxErr :: TyCon -> Error +derivingIxErr tycon + = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty -> + ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] ) + +---------------------------------------------------------------- +derivingWhenInstanceExistsErr :: Class -> TyCon -> Error +derivingWhenInstanceExistsErr clas tycon + = addErrLoc (getSrcLoc tycon) "`deriving' when an instance also exists" ( \ sty -> + ppBesides [ppStr "class `", ppr sty clas, + ppStr "', type `", ppr sty tycon, ppStr "'"] ) + +---------------------------------------------------------------- +{- UNUSED: +derivingNoSuperClassInstanceErr :: Class -> TyCon -> Class -> Error +derivingNoSuperClassInstanceErr clas tycon super_class + = addErrLoc (getSrcLoc tycon) "No instance for a superclass in a `deriving'" ( \ sty -> + ppSep [ppBesides [ppStr "the superclass `", ppr sty super_class, ppStr "' has no instance"], + ppBesides [ppStr "at the type `", ppr sty tycon, ppStr "';"], + ppBesides [ppStr "(the class being \"derived\" is `", ppr sty clas, ppStr "')"] + ]) +-} + +---------------------------------------------------------------- +dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error +dupInstErr (clas, info1@(ty1, locn1), info2@(ty2, locn2)) + -- Overlapping/duplicate instances for given class; msg could be more glamourous + = addErrLoc locn1 "Duplicate/overlapping instances" ( \ sty -> + ppSep [ ppBesides [ppStr "class `", ppr sty clas, ppStr "',"], + showOverlap sty info1 info2] ) + +---------------------------------------------------------------- +{- UNUSED? +extraMethodsErr :: [Id] {-dicts-} -> SrcLoc -> Error + -- when an instance decl has binds for methods that aren't in the class decl +extraMethodsErr extra_methods locn + = addErrLoc locn "Extra methods in instance declaration" ( \ sty -> + interpp'SP sty extra_methods ) +-} + +---------------------------------------------------------------- +genCantGenErr :: [Inst] -> Error +genCantGenErr insts@(inst1:_) + = addErrLoc loc1 "Cannot generalise these overloadings (in a _ccall_):" ( \ sty -> + ppAboves (map (ppr_inst sty) insts) ) + where + (loc1, _) = getInstOrigin inst1 + +---------------------------------------------------------------- +{- UNUSED: +genPrimTyVarErr :: [TyVar] -> SrcLoc -> Error + -- Attempt to generalise over a primitive type variable + +genPrimTyVarErr tyvars locn + = addErrLoc locn "These primitive type variables can't be made more general" ( \ sty -> + ppAbove (interpp'SP sty tyvars) + (ppStr "(Solution: add a type signature.)") ) +-} +---------------------------------------------------------------- +noInstanceErr :: Inst -> Error +noInstanceErr inst + = let (clas, ty) = getDictClassAndType inst + (locn, msg) = getInstOrigin inst + in + addErrLoc locn "No such instance" ( \ sty -> + ppSep [ ppBesides [ppStr "class `", ppr sty clas, + ppStr "', type `", ppr sty ty, ppStr "'"], + ppBesides [ppStr "(", msg sty, ppStr ")"] ] + ) + +---------------------------------------------------------------- +{- UNUSED: +instOpErr :: Id -> Class -> TyCon -> Error + +instOpErr dict clas tycon + -- no instance of "Class" for "TyCon" + -- the Id is the offending dictionary; has src location + -- (and we could get the Class and TyCon from it, but + -- since we already have it at hand ...) + = addErrLoc (getSrcLoc dict) "Invalid instance" ( \ sty -> + ppBesides [ ppStr "There is no instance of `", ppr sty tycon, + ppStr "' for class `", + ppr sty clas, ppChar '\'' ] ) +-} + +---------------------------------------------------------------- +instTypeErr :: UniType -> SrcLoc -> Error +instTypeErr ty locn + = addShortErrLocLine locn (\ sty -> + let + rest_of_msg = ppStr "' cannot be used as the instance type\n in an instance declaration." + in + case ty of + UniSyn tc _ _ -> ppBesides [ppStr "The type synonym `", ppr sty tc, rest_of_msg] + UniTyVar tv -> ppBesides [ppStr "The type variable `", ppr sty tv, rest_of_msg] + other -> ppBesides [ppStr "The type `", ppr sty ty, rest_of_msg] + ) + +---------------------------------------------------------------- +{- UNUSED: +methodInstErr :: (ClassOp, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error +methodInstErr (class_op, info1, info2) sty + -- Two instances for given class op + = ppHang (ppBesides [ ppStr "The class method `", ppr sty class_op, ppStr "' has been given more than one definition for"]) + 4 (showOverlap sty info1 info2) +-} + +showOverlap :: PprStyle -> (UniType, SrcLoc) -> (UniType, SrcLoc) -> Pretty +showOverlap sty (ty1,loc1) (ty2,loc2) + = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"], + ppBeside (ppStr "at ") (ppr sty loc1), + ppBeside (ppStr "and ") (ppr sty loc2)] + +---------------------------------------------------------------- +methodTypeLacksTyVarErr :: TyVarTemplate -> String -> SrcLoc -> Error +methodTypeLacksTyVarErr tyvar method_name locn + = addErrLoc locn "Method's type doesn't mention the class type variable" (\ sty -> + ppAboves [ppBeside (ppStr "Class type variable: ") (ppr sty tyvar), + ppBeside (ppStr "Method: ") (ppStr method_name)] ) + +---------------------------------------------------------------- +{- UNUSED: +missingClassOpErr :: Id -> [ClassOp] -> SrcLoc -> Error +missingClassOpErr op classops locn + = addErrLoc locn "Undefined class method" ( \ sty -> + ppBesides [ ppr sty op, ppStr "; valid method(s):", + interpp'SP sty classops ] ) +-} + +---------------------------------------------------------------- +naughtyCCallContextErr :: Name -> SrcLoc -> Error +naughtyCCallContextErr clas_name locn + = addErrLoc locn "Can't use this class in a context" (\ sty -> + ppr sty clas_name ) + +---------------------------------------------------------------- +nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> Error +nonBoxedPrimCCallErr clas inst_ty locn + = addErrLoc locn "Instance isn't for a `boxed-primitive' type" ( \ sty -> + ppBesides [ ppStr "class `", ppr sty clas, ppStr "'; type `", + ppr sty inst_ty, ppStr "'"] ) + +---------------------------------------------------------------- +notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> Error +notAsPolyAsSigErr sig_ty mono_tyvars ctxt locn + = addErrLoc locn "A type signature is more polymorphic than the inferred type" ( \ sty -> + ppAboves [ ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)", + pprUnifyErrContext sty ctxt, + ppHang (ppStr "Monomorphic type variable(s):") + 4 (interpp'SP sty mono_tyvars), + ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction" + ] ) + +---------------------------------------------------------------- +{- UNUSED: +patMatchWithPrimErr :: Error +patMatchWithPrimErr + = dontAddErrLoc + "Pattern-bindings may not involve primitive types." ( \ sty -> + ppNil ) +-} + +---------------------------------------------------------------- +preludeInstanceErr :: Class -> UniType -> SrcLoc -> Error +preludeInstanceErr clas ty locn + = addShortErrLocLine locn ( \ sty -> + ppHang (ppBesides [ppStr "Illegal instance: for Prelude class `", ppr sty clas, + ppStr "' and Prelude type `", ppr sty ty, ppStr "'."] ) + 4 (ppStr "(An instance decl must be in the same module as the type decl or the class decl)") ) + +---------------------------------------------------------------- +{- UNUSED: +purelyLocalErr :: Name -> SrcLoc -> Error +purelyLocalErr thing locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "`", ppr sty thing, + ppStr "' cannot be exported -- it would refer to an unexported local entity."] ) +-} + +---------------------------------------------------------------- +reduceErr :: [Inst] -> UnifyErrContext -> Error + -- Used by tcSimplifyCheckLIE + -- Could not express required dictionaries in terms of the signature +reduceErr insts ctxt + = dontAddErrLoc "Type signature lacks context required by inferred type" ( \ sty -> + ppAboves [ + pprUnifyErrContext sty ctxt, + ppHang (ppStr "Context reqd: ") + 4 (ppAboves (map (ppr_inst sty) insts)) + ]) + where + ppr_inst sty inst + = let (clas, ty) = getDictClassAndType inst + (locn, msg) = getInstOrigin inst + in + ppSep [ ppBesides [ppr sty locn, ppStr ": ", ppr sty clas, ppSP, ppr sty ty], + ppBesides [ppStr "(", msg sty, ppStr ")"] ] + +---------------------------------------------------------------- +{- +unexpectedPreludeThingErr :: Outputable a => String -> a -> SrcLoc -> Error + +unexpectedPreludeThingErr category thing locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "Prelude ", ppStr category, + ppStr " not expected here: ", ppr sty thing]) +-} + +---------------------------------------------------------------- +specGroundnessErr :: UnifyErrContext -> [UniType] -> Error + +specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys + = addShortErrLocLine locn ( \ sty -> + ppHang ( + ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"], + ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"], + ppStr "... not all type variables were instantiated", + ppStr "to type variables or ground types (nothing in between, please!):"]) + 4 (ppAboves (map (ppr sty) arg_tys)) + ) + +---------------------------------------------------------------- +specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> Error + +specCtxtGroundnessErr err_ctxt dicts + = addShortErrLocLine locn ( \ sty -> + ppHang ( + ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"], + ppBesides [ppStr " specialised to the type `", ppr sty spec_ty, ppStr "'"], + pp_spec_id sty, + ppStr "... not all overloaded type variables were instantiated", + ppStr "to ground types:"]) + 4 (ppAboves [ppCat [ppr sty c, ppr sty t] + | (c,t) <- map getDictClassAndType dicts]) + ) + where + (name, spec_ty, locn, pp_spec_id) + = case err_ctxt of + ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> ppNil) + ValSpecSpecIdCtxt n ty spec loc -> + (n, ty, loc, + \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"]) + +---------------------------------------------------------------- +specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> Error + +specDataNoSpecErr name arg_tys locn + = addShortErrLocLine locn ( \ sty -> + ppHang ( + ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"], + ppStr "... no unboxed type arguments in specialisation:"]) + 4 (ppAboves (map (ppr sty) arg_tys)) + ) + +---------------------------------------------------------------- +specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> Error + +specDataUnboxedErr name arg_tys locn + = addShortErrLocLine locn ( \ sty -> + ppHang ( + ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"], + ppStr "... not all type arguments were specialised to", + ppStr "specific unboxed types or (boxed) type variables:"]) + 4 (ppAboves (map (ppr sty) arg_tys)) + ) + +---------------------------------------------------------------- +specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> Error + +specInstUnspecInstNotFoundErr clas inst_ty locn + = addErrLoc locn "No local instance to specialise" ( \ sty -> + ppBesides [ ppStr "class `", ppr sty clas, ppStr "' at the type `", + ppr sty inst_ty, ppStr "'"] ) + +---------------------------------------------------------------- +-- The type signatures on a mutually-recursive group of definitions +-- must all have the same context (or none). For example: +-- f :: Eq a => ... +-- g :: (Eq a, Text a) => ... +-- is illegal if f and g are mutually recursive. This also +-- applies to variables bound in the same pattern binding. + +sigContextsErr :: [SignatureInfo] -> Error + +sigContextsErr infos + = dontAddErrLoc "A group of type signatures have mismatched contexts" ( \ sty -> + ppAboves (map (ppr_sig_info sty) infos) ) + where + ppr_sig_info sty (TySigInfo val tyvars insts tau_ty _) + = ppHang (ppBeside (ppr sty val) (ppStr " :: ")) + 4 (ppHang (if null insts + then ppNil + else ppBesides [ppStr "(", ppInterleave ppComma (map (ppr_inst sty) insts), ppStr ") => "]) + 4 (ppr sty tau_ty)) + + ppr_inst sty inst + = let (clas, ty) = getDictClassAndType inst + (locn, msg) = getInstOrigin inst + in + ppCat [ppr sty clas, ppr sty ty] + +---------------------------------------------------------------- +topLevelUnboxedDeclErr :: Id -> SrcLoc -> Error + -- Top level decl of something with a primitive type + +topLevelUnboxedDeclErr id locn + = addShortErrLocLine locn ( \ sty -> + ppBesides [ppStr "The top-level value `", ppr sty id, ppStr "' shouldn't have an unboxed type." ]) + +---------------------------------------------------------------- +dataConArityErr :: Id -> Int -> Int -> SrcLoc -> Error +tyConArityErr :: Name -> Int -> Int -> SrcLoc -> Error + +tyConArityErr = arityError "Type" +dataConArityErr = arityError "Constructor" + +arityError kind name n m locn = + addErrLoc locn errmsg + (\ sty -> + ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ", + n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']) + where + errmsg = kind ++ " has too " ++ quantity ++ " arguments" + quantity | m < n = "few" + | otherwise = "many" + n_arguments | n == 0 = ppStr "no arguments" + | n == 1 = ppStr "1 argument" + | True = ppCat [ppInt n, ppStr "arguments"] + +---------------------------------------------------------------- +unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error + +unifyErr unify_err_info unify_err_context locn + = addShortErrLocLine locn ( \ sty -> + pprUnifyErrInfo sty unify_err_info unify_err_context) + +---------------------------------------------------------------- +varyingArgsErr :: Name -> [RenamedMatch] -> Error + -- Different number of arguments in different equations + +varyingArgsErr name matches + = dontAddErrLoc "Varying number of arguments for function" ( \ sty -> + ppr sty name ) +{- +varyingArgsErr name matches + = addErrLoc locn "Function Definition Error" ( \ sty -> + ppBesides [ppStr "Function `", ppr sty name, ppStr "' should have a fixed number of arguments" ]) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[UnifyErr-types]{@UnifyErrInfo@ and @UnifyErrContext@ datatypes} +%* * +%************************************************************************ + +Here are the things that can go wrong during unification: + +\begin{code} +data UnifyErrInfo + = UnifyMisMatch UniType UniType + | TypeRec TyVar TauType -- Occurs check failure + + | UnifyListMisMatch [TauType] [TauType] -- Args to unifyList: diff lengths + -- produces system error +\end{code} + +@UnifyErrContext@ gives some context for unification +errors found in expressions. Also see the @UnifyErrInfo@ type (above), +as well as the general error-reporting type @Error@ (in @TcErrors@). +\begin{code} +data UnifyErrContext + = PredCtxt RenamedExpr + | AppCtxt RenamedExpr RenamedExpr + + | TooManyArgsCtxt RenamedExpr -- The offending function + -- We don't want the typechecked expr here, + -- because that may be full of + -- confusing dictionaries + + | FunAppCtxt RenamedExpr -- The offending function + (Maybe Id) -- same info (probably) in a more convenient form + RenamedExpr -- The offending arg + UniType -- Expected type of offending arg + UniType -- Inferred type for offending arg + Int -- Which arg number (first is 1) + + | OpAppCtxt RenamedExpr RenamedExpr RenamedExpr + | SectionLAppCtxt RenamedExpr RenamedExpr + | SectionRAppCtxt RenamedExpr RenamedExpr + | CaseCtxt RenamedExpr [RenamedMatch] + | BranchCtxt RenamedExpr RenamedExpr + | ListCtxt [RenamedExpr] + | PatCtxt RenamedPat + | CaseBranchesCtxt [RenamedMatch] + | FilterCtxt RenamedExpr + | GeneratorCtxt RenamedPat RenamedExpr + | GRHSsBranchCtxt [RenamedGRHS] + | GRHSsGuardCtxt RenamedExpr + | PatMonoBindsCtxt RenamedPat RenamedGRHSsAndBinds + | FunMonoBindsCtxt Name [RenamedMatch] + | MatchCtxt UniType UniType + | ArithSeqCtxt RenamedExpr + | CCallCtxt String [RenamedExpr] + | AmbigDictCtxt [Inst] -- Occurs check when simplifying ambiguous + -- dictionaries. Should never happen! + | SigCtxt Id UniType + | MethodSigCtxt Name UniType + | ExprSigCtxt RenamedExpr UniType + | ValSpecSigCtxt Name UniType SrcLoc + | ValSpecSpecIdCtxt Name UniType Name SrcLoc + + -- The next two contexts are associated only with TcSimplifyAndCheck failures + | BindSigCtxt [Id] -- Signature(s) for a group of bindings + | SuperClassSigCtxt -- Superclasses for this instance decl + + | CaseBranchCtxt RenamedMatch + | Rank2ArgCtxt TypecheckedExpr UniType +#ifdef DPH + | PodCtxt [RenamedExpr] + | ParFilterCtxt RenamedExpr + | DrawnCtxt [RenamedPat] RenamedPat RenamedExpr + | IndexCtxt [RenamedExpr] RenamedPat RenamedExpr + | ParPidPatCtxt RenamedPat + | ParPidExpCtxt RenamedExpr + | ParZFlhsCtxt RenamedExpr +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[Errors-print-unify]{Printing unification error info} +%* * +%************************************************************************ + +\begin{code} +ppUnifyErr :: Pretty -> Pretty -> Pretty +ppUnifyErr head rest = ppSep [head, {-if you want a blank line: ppSP,-} rest] + +pprUnifyErrInfo sty (UnifyMisMatch mt1 mt2) err_ctxt + = ppUnifyErr (ppSep [ppBesides [ppStr "Couldn't match the type `", ppr sty mt1, ppStr "'"], + ppBesides [ppStr "against `", ppr sty mt2, ppStr "'."]]) + (pprUnifyErrContext sty err_ctxt) + +pprUnifyErrInfo sty (TypeRec tyvar ty) err_ctxt + = ppUnifyErr (ppBesides [ppStr "Cannot construct the infinite type `", + ppr sty tyvar, + ppStr "' = `",ppr sty ty, ppStr "' (\"occurs check\")."]) + (pprUnifyErrContext sty err_ctxt) + +pprUnifyErrInfo sty (UnifyListMisMatch tys1 tys2) err_ctxt + = panic "pprUnifyErrInfo: unifying lists of types of different lengths" +\end{code} + +%************************************************************************ +%* * +\subsection[Errors-print-context]{Printing unification error context} +%* * +%************************************************************************ + +\begin{code} +pp_nest_hang :: String -> Pretty -> Pretty +pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff) + +context = "Error detected when type-checking " + +ppContext s = ppStr (context ++ s) + +pprUnifyErrContext sty (PredCtxt e) + = ppHang (ppStr "In a predicate expression:") 4 (ppr sty e) + +pprUnifyErrContext sty (AppCtxt f a) + = ppHang (ppStr "In a function application:") 4 (ppr sty (App f a)) + +pprUnifyErrContext sty (FunAppCtxt f maybe_id actual_arg expected_arg_ty actual_arg_ty n) + = let + + (have_extra_info, f_id, f_type) + = case maybe_id of + Nothing -> (False, bottom, bottom) + Just id -> (True, id, getIdUniType id) + + free_tyvars = extractTyVarsFromTy f_type + bottom = panic "no maybe_id" + in + ppAboves [ + ppHang (ppCat [ ppStr "In the", speakNth n, ppStr "argument of", + ppBesides [ppChar '`', ppr sty f, ppStr "',"] ]) + 4 (ppBesides [ppStr " namely `", ppr sty actual_arg, ppStr "'," ]), + + ppHang (ppStr "Expected type of the argument: ") + 4 (ppr sty expected_arg_ty), + + ppHang (ppStr "Inferred type of the argument: ") + 4 (ppr sty actual_arg_ty), + +{- OMIT + I'm not sure this adds anything + + if have_extra_info + then ppHang (ppCat [ppStr "The type of", + ppBesides [ppChar '`', ppr sty f_id, ppChar '\''], + ppStr "is"]) 4 + (ppBesides [ppChar '`', ppr sty f_type, ppStr "'."]) + else ppNil, +-} + + if not have_extra_info || null free_tyvars || isSysLocalId f_id + -- SysLocals are created for the local (monomorphic) versions + -- of recursive functions, and the monomorphism suggestion + -- below is sometimes positively misleading. Notably, + -- if you give an erroneous type sig, you may well end + -- up with a unification error like this, and it usually ain't due + -- to monomorphism. + then ppNil + else + ppAboves [ + ppSep [ppStr "Possible cause of error:", + ppBesides [ppChar '`', ppr sty f, ppChar '\''], + ppStr "is not polymorphic"], + ppSep [ppStr "it is monomorphic in the type variable(s):", + interpp'SP sty free_tyvars] + ] + ] + +pprUnifyErrContext sty (TooManyArgsCtxt f) + = ppHang (ppStr "Too many arguments in an application of the function") + 4 (ppBesides [ ppChar '`', ppr sty f, ppStr "'." ]) + +pprUnifyErrContext sty (SectionLAppCtxt expr op) + = ppHang (ppStr "In a left section:") 4 (ppr sty (SectionL expr op)) + +pprUnifyErrContext sty (SectionRAppCtxt op expr) + = ppHang (ppStr "In a right section:") 4 (ppr sty (SectionR op expr)) + +pprUnifyErrContext sty (OpAppCtxt a1 op a2) + = ppHang (ppStr "In an infix-operator application:") 4 (ppr sty (OpApp a1 op a2)) + +pprUnifyErrContext sty (CaseCtxt e as) + = ppHang (ppStr "In a case expression:") 4 (ppr sty (Case e as)) + +pprUnifyErrContext sty (BranchCtxt b1 b2) + = ppSep [ppStr "In the branches of a conditional:", + pp_nest_hang "`then' branch:" (ppr sty b1), + pp_nest_hang "`else' branch:" (ppr sty b2)] + +pprUnifyErrContext sty (ListCtxt es) + = ppHang (ppStr "In a list expression:") 4 ( + ppBesides [ppLbrack, interpp'SP sty es, ppRbrack]) + +pprUnifyErrContext sty (PatCtxt (ConPatIn name pats)) + = ppHang (ppStr "In a constructed pattern:") + 4 (ppCat [ppr sty name, interppSP sty pats]) + +pprUnifyErrContext sty (PatCtxt (ConOpPatIn pat1 op pat2)) + = ppHang (ppStr "In an infix-operator pattern:") + 4 (ppCat [ppr sty pat1, ppr sty op, ppr sty pat2]) + +pprUnifyErrContext sty (PatCtxt (ListPatIn ps)) + = ppHang (ppStr "In an explicit list pattern:") + 4 (ppBesides [ppLbrack, interpp'SP sty ps, ppRbrack]) + +pprUnifyErrContext sty (PatCtxt pat@(AsPatIn _ _)) + = ppHang (ppStr "In an as-pattern:") 4 (ppr sty pat) + +pprUnifyErrContext sty (CaseBranchesCtxt (m:ms)) + = ppAboves [ppStr "Inside two case alternatives:", + ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) [m])), + ppNest 4 (ppBeside (ppStr "... ") (pprMatches sty (True,ppNil) ms))] + +pprUnifyErrContext sty (FilterCtxt e) + = ppHang (ppStr "In a guard in a list-comprehension:") 4 (ppr sty e) + +pprUnifyErrContext sty (GeneratorCtxt p e) + = ppHang (ppStr "In a generator in a list-comprehension:") + 4 (ppSep [ppr sty p, ppStr "<-", ppr sty e]) + +pprUnifyErrContext sty (GRHSsBranchCtxt grhss) + = ppAboves [ppStr "In some guarded right-hand-sides:", + ppNest 4 (ppAboves (map (pprGRHS sty False) grhss))] + +pprUnifyErrContext sty (GRHSsGuardCtxt g) + = ppHang (ppStr "In a guard on an equation:") 4 (ppr sty g) + +pprUnifyErrContext sty (PatMonoBindsCtxt pat grhss_and_binds) + = ppHang (ppStr "In a pattern binding:") + 4 (ppr sty (PatMonoBind pat grhss_and_binds mkUnknownSrcLoc)) + +pprUnifyErrContext sty (FunMonoBindsCtxt id matches) + = ppHang (ppStr "When combining a function's equation(s) & type signature (if applicable):") + 4 (ppBesides [ppr sty id, ppSP, pprMatches sty (False,ppNil) matches]) + +pprUnifyErrContext sty (CaseBranchCtxt match) + = ppHang (ppStr "When combining a \"case\" branch & type signature (if applicable):") + 4 (pprMatch sty True{-is_case-} match) + +pprUnifyErrContext sty (MatchCtxt ty1 ty2) + = ppAboves [ppStr "In a type signature:", + pp_nest_hang "Signature:" (ppr sty ty1), + pp_nest_hang "Inferred type:" (ppr sty ty2)] + +pprUnifyErrContext sty (ArithSeqCtxt expr) + = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr) + +pprUnifyErrContext sty (CCallCtxt label args) + = ppAboves [ppStr "In a _ccall_ or _casm_:", + pp_nest_hang "C-calling magic:" (ppStr label), + pp_nest_hang "Arguments:" (ppInterleave ppComma (map (ppr sty) args))] + +-- OLD: kill +pprUnifyErrContext sty (AmbigDictCtxt dicts) + = ppStr "Ambiguous dictionary occurs check: should never happen!" + +pprUnifyErrContext sty (SigCtxt id tau_ty) + = ppHang (ppBesides [ppStr "In the type signature for ", + ppr sty id, + ppStr ":"] + ) 4 (ppr sty tau_ty) + +pprUnifyErrContext sty (MethodSigCtxt name ty) + = ppHang (ppBesides [ ppStr "When matching the definition of class method `", + ppr sty name, ppStr "' to its signature :" ] + ) 4 (ppr sty ty) + +pprUnifyErrContext sty (ExprSigCtxt expr ty) + = ppHang (ppStr "In an expression with a type signature:") + 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"), + ppr sty ty]) + +pprUnifyErrContext sty (BindSigCtxt ids) + = ppHang (ppStr "When checking type signatures for: ") + 4 (ppInterleave (ppStr ", ") (map (ppr sty) ids)) + +pprUnifyErrContext sty SuperClassSigCtxt + = ppStr "When checking superclass constraints on instance declaration" + +pprUnifyErrContext sty (Rank2ArgCtxt expr ty) + = ppHang (ppStr "In an argument which has rank-2 polymorphic type:") + 4 (ppSep [ppBeside (ppr sty expr) (ppStr " ::"), + ppr sty ty]) + +pprUnifyErrContext sty (ValSpecSigCtxt v ty src_loc) + = ppHang (ppStr "In a SPECIALIZE pragma for a value:") + 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"), + ppr sty ty]) + +pprUnifyErrContext sty (ValSpecSpecIdCtxt v ty spec src_loc) + = ppHang (ppStr "When checking type of explicit id in SPECIALIZE pragma:") + 4 (ppSep [ppBeside (ppr sty v) (ppStr " ::"), + ppr sty ty, + ppBeside (ppStr " = ") (ppr sty spec)]) + +#ifdef DPH +pprUnifyErrContext sty (PodCtxt es) + = ppAboves [ppStr "In a POD expression:", + ppBesides [ppStr "<<", interpp'SP sty es, ppStr ">>"]] + +pprUnifyErrContext sty (ParFilterCtxt e) + = ppHang (ppStr "In a guard of a POD comprehension:") 4 + (ppr sty e) + +pprUnifyErrContext sty (DrawnCtxt ps p e) + = ppHang (ppStr "In parallel drawn from generator:") + 4 (ppSep [ppStr "(|" ,interpp'SP sty ps, ppStr ";" , + ppr sty p ,ppStr "|)", ppStr "<<-", ppr sty e]) + +pprUnifyErrContext sty (IndexCtxt es p e) + = ppHang (ppStr "In parallel index from generator:") + 4 (ppSep [ppStr "(|",interpp'SP sty es, ppStr ";" , + ppr sty p ,ppStr "|)" , ppStr "<<=", ppr sty e]) + +pprUnifyErrContext sty (ParPidPatCtxt p) + = ppHang (ppStr "In pattern for processor ID has to be in class Pid:") + 4 (ppr sty p) + +pprUnifyErrContext sty (ParPidExpCtxt e) + = ppHang (ppStr "In expression for processor ID has to be in class Pid:") + 4 (ppr sty e) + +pprUnifyErrContext sty (ParZFlhsCtxt e) + = ppHang (ppStr "In LHS of a POD comprehension has to be in class Processor") + 4 (ppr sty e) + +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifdef DPH +pprPodizedWarning :: PodWarning -> Error +pprPodizedWarning (EntryNotPodized b) + = addWarningLoc (getSrcLoc b) (\ sty -> + ppBeside (ppStr "Unable to parallelise entry: ") + (ppr sty b) + ) + +pprPodizedWarning (NoGoNestedPodized b) + = addWarningLoc (getSrcLoc b) (\ sty -> + ppBeside (ppStr "Sorry no nested parallelism yet: ") + (ppr sty b) + ) + +pprPodizedWarning (ContextNotAvailable b c) + = addWarningLoc (getSrcLoc b) (\ sty -> + ppAbove (ppBesides [ppStr "No parallelisation of binding for a ", + ppStr (show_context c) , ppStr ": ",ppr sty b]) + (ppBesides [ppStr "Maybe you should re-compile this module ", + ppStr "with the `",ppStr (which_flag c), + ppStr "' flag."]) + ) + +pprPodizedWarning (ImportNotAvailable b c) + = addWarningLoc (getSrcLoc b) (\ sty -> + ppAboves [ppBesides [ppStr "No parallelisation of binding for a ", + ppStr (show_context c),ppStr ": ", ppr sty b], + ppBesides [ppStr "If you re-compile the module `", + ppStr (fst (getOrigName b)), ppStr "`"], + ppBesides [ppStr "with the `",ppStr (which_flag c), + ppStr "' flag I may do a better job :-)"]] + ) + + +pprPodizedWarning (ArgsInDifferentContexts b) + = addWarningLoc (getSrcLoc b) (\ sty -> + ppBesides [ppStr "Higher Order argument used in different ", + ppStr "parallel contexts : ",ppr sty b] + ) + +pprPodizedWarning (NoPodization) + = addWarning (\ sty -> + ppStr "Program not podized") + +pprPodizedWarning (PodizeStats ci pi vl pl) + = addWarning (\ sty -> + (ppHang (ppStr "Podization Statistics:") + 5 + (ppAboves [ppCat [ppStr "Info collecting passes =",ppr sty ci], + ppCat [ppStr "Podization passes =",ppr sty pi], + ppCat [ppStr "Vanilla's deleted =",ppr sty vl], + ppCat [ppStr "Podized deleted =",ppr sty pl]])) + ) + +show_context :: Int -> String +show_context 1 = "\"vector\"" +show_context 2 = "\"matrix\"" +show_context 3 = "\"cube\"" +show_context n = "\""++(show n)++"-D Pod\"" + +which_flag :: Int -> String +which_flag 1 = "-fpodize-vector" +which_flag 2 = "-fpodize-matrix" +which_flag 3 = "-fpodize-cube" +#endif {- Data Parallel Haskell -} +\end{code} + + +@speakNth@ converts an integer to a verbal index; eg 1 maps to ``first'' etc. +\begin{code} +speakNth :: Int -> Pretty +speakNth 1 = ppStr "first" +speakNth 2 = ppStr "second" +speakNth 3 = ppStr "third" +speakNth 4 = ppStr "fourth" +speakNth 5 = ppStr "fifth" +speakNth 6 = ppStr "sixth" +speakNth n = ppBesides [ ppInt n, ppStr "th" ] -- Wrong for eg "31th" + -- but who cares? +\end{code} diff --git a/ghc/compiler/main/Main.hi b/ghc/compiler/main/Main.hi new file mode 100644 index 0000000..612391d --- /dev/null +++ b/ghc/compiler/main/Main.hi @@ -0,0 +1,5 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Main where +mainPrimIO :: _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs new file mode 100644 index 0000000..e1af1c6 --- /dev/null +++ b/ghc/compiler/main/Main.lhs @@ -0,0 +1,510 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[GHC_Main]{Main driver for Glasgow Haskell compiler} + +\begin{code} +#include "HsVersions.h" + +module Main ( +#ifdef __GLASGOW_HASKELL__ + mainPrimIO +#else + main +#endif + ) where + +import MainMonad +import CmdLineOpts + +import AbsCSyn +import AbsPrel ( builtinNameInfo ) +import AbsSyn +import AbsUniType ( isDataTyCon, TauType(..), UniType, TyVar, TyCon, Class ) +import Bag ( emptyBag, isEmptyBag, Bag ) +import CE ( CE(..), UniqFM ) +import CodeGen ( codeGen ) +import CoreToStg ( topCoreBindsToStg ) +import Desugar ( deSugar ) +import DsMonad ( DsMatchContext, DsMatchKind, pprDsWarnings ) +import E ( getE_TCE, E, GVE(..) ) + -- most of above needed by mkInterface +#ifndef DPH +import Errors ( pprBagOfErrors, Error(..) ) +#else +import Errors ( pprBagOfErrors, pprPodizedWarning, Error(..) ) +#endif {- Data Parallel Haskell -} +import Id ( mkInstId, Id, Inst ) +import Maybes ( maybeToBool, Maybe(..), MaybeErr(..) ) +import MkIface ( mkInterface ) +import Outputable +import PlainCore ( CoreExpr, CoreBinding, pprPlainCoreBinding, + PlainCoreProgram(..), PlainCoreBinding(..) + ) +import Pretty ( PprStyle(..), ppShow, ppAboves, ppAppendFile + IF_ATTACK_PRAGMAS(COMMA ppAbove) + ) +#ifdef USE_NEW_READER +import ReadPrefix2 ( rdModule ) +#else +import {-hide from mkdependHS-} + ReadPrefix ( rdModule ) +#endif +import Rename -- renameModule ... +import SimplCore -- core2core +import SimplStg ( stg2stg ) +--ANDY: import SimplHaskell +import StgSyn ( pprPlainStgBinding, StgBinding, StgRhs, CostCentre, + StgBinderInfo, PlainStgProgram(..), PlainStgBinding(..) + ) +import TCE ( rngTCE, {- UNUSED: printTypeInfoForPop,-} TCE(..) + IF_ATTACK_PRAGMAS(COMMA eltsUFM) + ) +import Typecheck -- typecheckModule ... +import SplitUniq +import Unique -- lots of UniqueSupplies, etc. +import Util + +#if ! OMIT_NATIVE_CODEGEN +import AsmCodeGen ( dumpRealAsm +# if __GLASGOW_HASKELL__ + , writeRealAsm +# endif + ) +#endif + +#ifdef USE_SEMANTIQUE_STRANAL +import ProgEnv ( ProgEnv(..), TreeProgEnv(..), createProgEnv ) +import StrAnal ( ppShowStrAnal, OAT ) +#endif +#ifdef DPH +import PodizeCore ( podizeCore , PodWarning) +import AbsCTopApal ( nuAbsCToApal ) +import NextUsed ( pprTopNextUsedC, getTopLevelNexts, AbsCNextUsed, + TopAbsCNextUsed(..) , MagicId) + +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifndef __GLASGOW_HASKELL__ +main :: Dialogue + +main = mainIOtoDialogue main_io + +main_io :: MainIO () +main_io +#else +mainPrimIO +#endif + = BSCC("mainIO") + BSCC("rdInput") readMn stdin ESCC `thenMn` \ input_pgm -> + getArgsMn `thenMn` \ raw_cmd_line -> + classifyOpts raw_cmd_line `thenMn` \ cmd_line_info -> + BSCC("doPasses") + doIt cmd_line_info input_pgm + ESCC ESCC +\end{code} + +\begin{code} +doIt :: CmdLineInfo -> String -> MainIO () +#ifndef DPH +doIt (switch_lookup_fn, core_cmds, stg_cmds) input_pgm +#else +doIt (switch_lookup_fn, core_cmds, podize_cmds, pcore_cmds, stg_cmds) input_pgm +#endif {- Data Parallel Haskell -} + -- + -- Help functions and boring global variables (e.g., printing style) + -- are figured out first; the "business end" follows, in the + -- body of the let. + -- + = let + -- ****** help functions: + + switch_is_on switch = switchIsOn switch_lookup_fn switch + -- essentially, converts SwBool answer to Bool + + string_switch_is_on switch + = maybeToBool (stringSwitchSet switch_lookup_fn switch) + + doOutput switch io_action + = BSCC("doOutput") + case (stringSwitchSet switch_lookup_fn switch) of + Nothing -> returnMn () + Just fname -> + fopen fname "a+" `thenMn` \ file -> + if (file == ``NULL'') then + error ("doOutput: failed to open:"++fname) + else + io_action file `thenMn` \ () -> + fclose file `thenMn` \ status -> + if status == 0 + then returnMn () + else error ("doOutput: closed failed: "{-++show status++" "-}++fname) + ESCC + + doDump switch hdr string + = BSCC("doDump") + if (switch_is_on switch) + then writeMn stderr hdr `thenMn_` + writeMn stderr ('\n': string) `thenMn_` + writeMn stderr "\n" + else returnMn () + ESCC + + -- ****** printing styles and column width: + + pprCols = (80 :: Int) -- could make configurable + + (pprStyle, pprErrorsStyle) + = if switch_is_on PprStyle_All then + (PprShowAll, PprShowAll) + else if switch_is_on PprStyle_Debug then + (PprDebug, PprDebug) + else if switch_is_on PprStyle_User then + (PprForUser, PprForUser) + else -- defaults... + (PprDebug, PprForUser) + + pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p + in + -- non-tuple-ish bindings... + + -- ****** possibly fiddle builtin namespaces: + + BIND (BSCC("builtinEnv") + builtinNameInfo switch_is_on {-switch looker-upper-} + ESCC + ) + _TO_ (init_val_lookup_fn, init_tc_lookup_fn) -> + + -- ********************************************** + -- Welcome to the business end of the main module + -- of the Glorious Glasgow Haskell compiler! + -- ********************************************** +#ifndef DPH + doDump Verbose "Glasgow Haskell Compiler, version 0.26" "" `thenMn_` +#else + doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.26)" "" + `thenMn_` +#endif {- Data Parallel Haskell -} + + -- ******* READER +#ifdef USE_NEW_READER + BSCC("rdModule") + rdModule + ESCC + `thenMn` \ (mod_name, export_list_fns, absyn_tree) -> + + BIND (\x -> x) _TO_ bar_foo -> + -- so BINDs and BENDs add up... +#else + BIND BSCC("rdModule") + rdModule input_pgm + ESCC + _TO_ (mod_name, export_list_fns, absyn_tree) -> +#endif + let + -- reader things used (much?) later + ds_mod_name = mod_name + if_mod_name = mod_name + co_mod_name = mod_name + st_mod_name = mod_name + cc_mod_name = mod_name + -- also: export_list_fns + in + doDump D_dump_rif2hs "Parsed, Haskellised:" + (pp_show (ppr pprStyle absyn_tree)) `thenMn_` + + -- UniqueSupplies for later use + getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer + getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker + getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer + getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier + getSplitUniqSupplyMn 'C' `thenMn` \ c2s_uniqs -> -- core-to-stg + getSplitUniqSupplyMn 'T' `thenMn` \ st_uniqs -> -- stg-to-stg passes + getSplitUniqSupplyMn 'F' `thenMn` \ fl_uniqs -> -- absC flattener + getSplitUniqSupplyMn 'P' `thenMn` \ prof_uniqs -> -- profiling tidy-upper + getSplitUniqSupplyMn 'L' `thenMn` \ pre_ncg_uniqs -> -- native-code generator + let + ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs + in + -- ******* RENAMER + BIND BSCC("Renamer") + renameModule switch_is_on + (init_val_lookup_fn, init_tc_lookup_fn) + absyn_tree + rn_uniqs + ESCC + _TO_ (mod4, import_names, final_name_funs, rn_errs_bag) -> + let + -- renamer things used (much?) later + cc_import_names = import_names + in + + doDump D_dump_rn4 "Renamer-pass4:" + (pp_show (ppr pprStyle mod4)) `thenMn_` + + if (not (isEmptyBag rn_errs_bag)) then + -- Stop right here + writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag)) + `thenMn_` writeMn stderr "\n" + `thenMn_` exitMn 1 + + else -- No renaming errors, carry on with... + + -- ******* TYPECHECKER + BIND (case BSCC("TypeChecker") + typecheckModule switch_is_on tc_uniqs final_name_funs mod4 + ESCC + of + Succeeded stuff + -> (emptyBag, stuff) + Failed tc_errs_bag + -> (tc_errs_bag, + panic "main: tickled tc_results even though there were errors")) + + _TO_ (tc_errs_bag, tc_results) -> + + let + ppr_b :: (Inst, TypecheckedExpr) -> Pretty + ppr_b (i,e) = ppr pprStyle (VarMonoBind (mkInstId i) e) + in + if (not (isEmptyBag tc_errs_bag)) then + -- Must stop *before* trying to dump tc output, because + -- if it fails it does not give you any useful stuff back! + writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag)) + `thenMn_` writeMn stderr "\n" + `thenMn_` exitMn 1 + + else ( -- No typechecking errors either -- so, go for broke! + + BIND tc_results + _TO_ (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds), + interface_stuff@(_,_,_,_,_), -- @-pat just for strictness... + tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) -> + let +-- big_tce = getE_TCE big_env +-- big_elts = rngTCE big_tce + + this_mod_tce = getE_TCE this_mod_env + this_mod_elts = rngTCE this_mod_tce + + local_tycons = [tc | tc <- this_mod_elts, + isLocallyDefined tc, -- from this module only + isDataTyCon tc ] -- algebraic types only + in +-- pprTrace "Envs:" (ppAboves [ +-- ppr pprStyle if_global_ids, +-- ppr pprStyle if_tce, +-- ppr pprStyle if_ce, +-- ppr pprStyle this_mod_env, +-- ppr pprStyle big_env +-- ]) ( + + doDump D_dump_tc "Typechecked:" + (pp_show + (ppAboves [ppr pprStyle class_binds, + ppr pprStyle inst_binds, + ppAboves (map ppr_b const_binds), + ppr pprStyle val_binds])) `thenMn_` + + doDump D_dump_deriv "Derived instances:" + (pp_show (ddump_deriv pprStyle)) `thenMn_` + +--NOT REALLY USED: +-- doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_` + -- ******* DESUGARER + let + (desugared,ds_warnings) + = BSCC("DeSugarer") + deSugar ds_uniqs switch_lookup_fn ds_mod_name typechecked_quad + ESCC + in + (if isEmptyBag ds_warnings then + returnMn () + else + writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings)) + `thenMn_` writeMn stderr "\n" + ) `thenMn_` + + doDump D_dump_ds "Desugared:" (pp_show (ppAboves + (map (pprPlainCoreBinding pprStyle) desugared))) `thenMn_` + + -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op) + core2core core_cmds switch_lookup_fn co_mod_name pprStyle + sm_uniqs local_tycons tycon_specs desugared + `thenMn` \ (simplified, inlinings_env, + SpecData _ _ _ gen_tycons all_tycon_specs + spec_errs spec_warn spec_tyerrs) -> + + doDump D_dump_simpl "Simplified:" (pp_show (ppAboves + (map (pprPlainCoreBinding pprStyle) simplified))) `thenMn_` + +-- ANDY: +-- doDump D_dump_core_passes_info "(Haskell) Simplified:" +-- (coreToHaskell simplified) `thenMn_` + +#ifdef DPH + -- ******* PODIZE (VECTORIZE) THE CORE PROGRAM + let + (warn,podized) = BSCC("PodizeCore") + podizeCore podize_cmds switch_is_on + uniqSupply_p simplified + ESCC + in + (if (not (null warn)) + then writeMn stderr "\n" `thenMn_` + writeMn stderr (ppShow pprCols (ppAboves + (map (\w -> pprPodizedWarning w pprErrorsStyle) warn))) `thenMn_` + writeMn stderr "\n" + else returnMn ()) `thenMn_` + + doDump D_dump_pod "Podization:" (pp_show (ppAboves + (map (pprPlainCoreBinding pprStyle) podized))) `thenMn_` + + -- ******** CORE-TO-CORE SIMPLIFICATION OF PODIZED PROGRAM + let + psimplified = BSCC("PodizeCore2Core") + core2core pcore_cmds switch_is_on pprStyle + uniqSupply_S podized + ESCC + in + doDump D_dump_psimpl "Par Simplified:" (pp_show (ppAboves + (map (pprPlainCoreBinding pprStyle) psimplified))) `thenMn_` + +#endif {- Data Parallel Haskell -} + +#ifdef USE_SEMANTIQUE_STRANAL + -- ******* SEMANTIQUE STRICTNESS ANALYSER + doDump D_dump_stranal_sem "Strictness:" (ppShowStrAnal simplified big_env) `thenMn_` +#endif + + -- ******* STG-TO-STG SIMPLIFICATION + let +#ifndef DPH + stg_binds = BSCC("Core2Stg") + topCoreBindsToStg c2s_uniqs simplified + ESCC +#else + stg_binds = BSCC("Core2Stg") + topCoreBindsToStg c2s_uniqs psimplified + ESCC +#endif {- Data Parallel Haskell -} + in + + stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds + `thenMn` \ (stg_binds2, cost_centre_info) -> + + doDump D_dump_stg "STG syntax:" (pp_show (ppAboves + (map (pprPlainStgBinding pprStyle) stg_binds2))) `thenMn_` + + -- ******* INTERFACE GENERATION (needs STG output) +{- let + mod_name = "_TestName_" + export_list_fns = (\ x -> False, \ x -> False) + inlinings_env = nullIdEnv + fixities = [] + if_global_ids = [] + if_ce = nullCE + if_tce = nullTCE + if_inst_info = emptyBag + in +-} let + mod_interface + = BSCC("MkInterface") + mkInterface switch_is_on if_mod_name export_list_fns + inlinings_env all_tycon_specs + interface_stuff + stg_binds2 + ESCC + in + doOutput ProduceHi BSCC("PrintInterface") + ( \ file -> + ppAppendFile file 1000{-pprCols-} mod_interface ) + ESCC `thenMn_` + + -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C! + let + abstractC = BSCC("CodeGen") + codeGen cc_mod_name -- module name for CC labelling + cost_centre_info + cc_import_names -- import names for CC registering + switch_lookup_fn + gen_tycons -- type constructors generated locally + all_tycon_specs -- tycon specialisations + stg_binds2 + ESCC + + flat_abstractC = BSCC("FlattenAbsC") + flattenAbsC fl_uniqs abstractC + ESCC + in + doDump D_dump_absC "Abstract C:" (dumpRealC switch_is_on abstractC) `thenMn_` + + doDump D_dump_flatC "Flat Abstract C:" (dumpRealC switch_is_on flat_abstractC) `thenMn_` + + -- 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) + (True, True) -> error "ERROR: Can't do both .hc and .s at the same time" + + c_output_d = BSCC("PrintRealC") + dumpRealC switch_is_on flat_absC_c + ESCC + +#ifdef __GLASGOW_HASKELL__ + c_output_w = BSCC("PrintRealC") + (\ f -> writeRealC switch_is_on f flat_absC_c) + ESCC +#else + c_output_w = c_output_d +#endif + +#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 = BSCC("nativeCode") + dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs + ESCC + +#ifdef __GLASGOW_HASKELL__ + ncg_output_w = BSCC("nativeCode") + (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs) + ESCC +#else + ncg_output_w = ncg_output_d +#endif +#endif + in + doDump D_dump_asm "" ncg_output_d `thenMn_` + doOutput ProduceS ncg_output_w `thenMn_` + +#ifndef DPH + -- ********* GHC Finished !!!! + doDump D_dump_realC "" c_output_d `thenMn_` + doOutput ProduceC c_output_w `thenMn_` + +#else + -- ********* DPH needs native code generator, nearly finished..... + let + next_used_flatC = getTopLevelNexts flat_abstractC [] + apal_module = nuAbsCToApal uniqSupply_L mod_name next_used_flatC + in + doDump D_dump_nextC "Next Used annotated C:" (ppShow pprCols + (pprTopNextUsedC next_used_flatC)) `thenMn_` + doOutput ProduceC ("! /* DAP assembler (APAL): */\n"++apal_module) `thenMn_` + +#endif {- Data Parallel Haskell -} + exitMn 0 + {-)-} BEND ) BEND BEND BEND BEND +\end{code} diff --git a/ghc/compiler/main/MainMonad.hi b/ghc/compiler/main/MainMonad.hi new file mode 100644 index 0000000..aeae1fa --- /dev/null +++ b/ghc/compiler/main/MainMonad.hi @@ -0,0 +1,52 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface MainMonad where +import PreludeArray(_ByteArray) +import PreludePrimIO(appendChanPrimIO, appendFilePrimIO, getArgsPrimIO, readChanPrimIO) +import SplitUniq(SplitUniqSupply, mkSplitUniqSupply) +import Stdio(_FILE(..), fclose, fopen, fwrite) +infixr 9 `thenMn` +infixr 9 `thenMn_` +type MainIO a = _State _RealWorld -> (a, _State _RealWorld) +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data _FILE = _FILE Addr# +appendChanPrimIO :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +appendFilePrimIO :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +exitMn :: Int -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fclose :: _FILE -> _State _RealWorld -> (Int, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fopen :: [Char] -> [Char] -> _State _RealWorld -> (_FILE, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +fwrite :: _ByteArray Int -> Int -> Int -> _FILE -> _State _RealWorld -> (Int, _State _RealWorld) + {-# GHC_PRAGMA _A_ 5 _U_ 11111 _N_ _S_ "U(AP)U(P)U(P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getArgsMn :: _State _RealWorld -> ([[Char]], _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePrimIO getArgsPrimIO _N_ #-} +getArgsPrimIO :: _State _RealWorld -> ([[Char]], _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +getSplitUniqSupplyMn :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +readChanPrimIO :: [Char] -> _State _RealWorld -> ([Char], _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkSplitUniqSupply :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +readMn :: [Char] -> _State _RealWorld -> ([Char], _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: [Char]) (u1 :: _State _RealWorld) -> _APP_ _ORIG_ PreludePrimIO readChanPrimIO [ u0, u1 ] _N_ #-} +returnMn :: a -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-} +thenMn :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: u0 -> _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u5, u6 ]; _NO_DEFLT_ } _N_ #-} +thenMn_ :: (_State _RealWorld -> (a, _State _RealWorld)) -> (_State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u6 ]; _NO_DEFLT_ } _N_ #-} +writeMn :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: [Char]) (u1 :: [Char]) (u2 :: _State _RealWorld) -> _APP_ _ORIG_ PreludePrimIO appendChanPrimIO [ u0, u1, u2 ] _N_ #-} +instance Eq _FILE + {-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Addr#) (u1 :: Addr#) -> case _#_ eqAddr# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> case _#_ eqAddr# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance _CCallable _FILE + {-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _TUP_0 [] [] _N_ #-} +instance _CReturnable _FILE + {-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _TUP_0 [] [] _N_ #-} + diff --git a/ghc/compiler/main/MainMonad.lhs b/ghc/compiler/main/MainMonad.lhs new file mode 100644 index 0000000..4d0960b --- /dev/null +++ b/ghc/compiler/main/MainMonad.lhs @@ -0,0 +1,258 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[MainMonad]{I/O monad used in @Main@ module of the compiler} + +\begin{code} +#include "HsVersions.h" + +module MainMonad ( + MainIO(..), +#ifndef __GLASGOW_HASKELL__ + mainIOtoDialogue, + appendFileMn, +#endif + returnMn, + thenMn, + thenMn_, +-- foldlMn, INLINEd at its two (important) uses... + readMn, + writeMn, + getArgsMn, + getSplitUniqSupplyMn, + exitMn, +#if __GLASGOW_HASKELL__ >= 23 + fopen, fclose, fwrite, _FILE(..), +#endif + + SplitUniqSupply + IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO) + IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO) + IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO) + IF_ATTACK_PRAGMAS(COMMA readChanPrimIO) + IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really + ) where + +#ifdef __GLASGOW_HASKELL__ + +# if __GLASGOW_HASKELL__ < 26 +import PreludePrimIO +# endif +import PreludeGlaST + +#endif + +import SplitUniq +import Outputable +import Util + +infixr 9 `thenMn` -- right-associative, please +infixr 9 `thenMn_` +\end{code} + +For Glasgow Haskell, we'll eventually be able to use the underlying +Glasgow I/O {\em directly}. However, for now we do the business +through regular a @Dialogue@. + +A value of type @MainIO a@ represents an I/O-performing computation +returning a value of type @a@. It is a function from the whole list +of responses-to-the-rest-of-the-program, to a triple consisting of: +\begin{enumerate} +\item +the value of type @a@; +\item +a function which prefixes the requests for the computation to +the front of a supplied list of requests; using a function here +avoids an expensive append operation in @thenMn@; +\item +the depleted list of responses. +\end{enumerate} + +\begin{code} +returnMn :: a -> MainIO a +thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b +thenMn_ :: MainIO a -> MainIO b -> MainIO b +--foldlMn :: (a -> b -> MainIO a) -> a -> [b] -> MainIO a + +readMn :: String{-channel-} -> MainIO String +writeMn :: String{-channel-} -> String -> MainIO () +#ifndef __GLASGOW_HASKELL__ +appendFileMn:: String{-filename-} -> String -> MainIO () +#endif +getArgsMn :: MainIO [String] +getSplitUniqSupplyMn :: Char -> MainIO SplitUniqSupply +exitMn :: Int -> MainIO () + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE returnMn #-} +{-# INLINE thenMn #-} +{-# INLINE thenMn_ #-} +#endif + +{- INLINEd at its uses +foldlMn f z [] = returnMn z +foldlMn f z (x:xs) = f z x `thenMn` \ zz -> + foldlMn f zz xs +-} + +exitMn val + = -- trace ("exitMn:"++(show val)) ( + if val /= 0 + then error "Compilation had errors\n" + else returnMn () + -- ) + +#ifdef __GLASGOW_HASKELL__ + +type MainIO a = PrimIO a + +returnMn = returnPrimIO +thenMn = thenPrimIO +thenMn_ = seqPrimIO + +readMn chan = readChanPrimIO chan +writeMn chan str = appendChanPrimIO chan str +getArgsMn = getArgsPrimIO + +getSplitUniqSupplyMn char = mkSplitUniqSupply char +\end{code} + +\begin{code} +#else {- ! __GLASGOW_HASKELL -} + +type MainIO a = (a -> Dialogue) -> Dialogue + +-- returnMn :: x -> MainIO x +returnMn x cont = cont x + +-- thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b +thenMn m k cont = m (\ a -> k a cont) + +-- thenMn_ :: MainIO a -> MainIO b -> MainIO b +thenMn_ m k cont = m (\ _ -> k cont) +\end{code} + +\begin{code} +mainIOtoDialogue :: MainIO () -> Dialogue + +mainIOtoDialogue io = io (\ _ _ -> []) + +readMn chan = readChanIO chan +writeMn chan str = appendChanIO chan str +appendFileMn fname str = appendFileIO fname str +getArgsMn = getArgsIO + +getSplitUniqSupplyMn char = returnMn (mkSplitUniqSupply char) +\end{code} + +\begin{code} +processRequestIO :: Request -> MainIO Response +processRequestIO req cont ~(resp:resps) = req : cont resp resps + +doneIO :: MainIO a +doneIO cont = \ _ -> [] + +data IoResult a = IoSucc a + | IoFail IOError + +type IOE a = MainIO (IoResult a) + +processRequestIOUnit :: Request -> IOE () +processRequestIOUnit req = + processRequestIO req `thenMn` \ resp -> + case resp of + Success -> returnMn (IoSucc ()) + Str str -> error "funny Response, expected a Success" + StrList strl -> error "funny Response, expected a Success" + Failure ioerr -> returnMn (IoFail ioerr) + +processRequestIOString :: Request -> IOE String +processRequestIOString req = + processRequestIO req `thenMn` \ resp -> + case resp of + Success -> error "funny Response, expected a String" + Str str -> returnMn (IoSucc str) + StrList strl -> error "funny Response, expected a String" + Failure ioerr -> returnMn (IoFail ioerr) + +processRequestIOStringList :: Request -> IOE [String] +processRequestIOStringList req = + processRequestIO req `thenMn` \ resp -> + case resp of + Success -> error "funny Response, expected a [String]" + Str str -> error "funny Response, expected a [String]" + StrList strl -> returnMn (IoSucc strl) + Failure ioerr -> returnMn (IoFail ioerr) + +readFileIOE :: String -> IOE String +writeFileIOE :: String -> String -> IOE () +appendFileIOE :: String -> String -> IOE () +deleteFileIOE :: String -> IOE () +statusFileIOE :: String -> IOE String +readChanIOE :: String -> IOE String +appendChanIOE :: String -> String -> IOE () +statusChanIOE :: String -> IOE String +echoIOE :: Bool -> IOE () +getArgsIOE :: IOE [String] +getEnvIOE :: String -> IOE String +setEnvIOE :: String -> String -> IOE () +sigActionIOE :: Int -> SigAct -> IOE () + +readFileIOE file = processRequestIOString ( ReadFile file ) +writeFileIOE file str = processRequestIOUnit ( WriteFile file str ) +appendFileIOE file str = processRequestIOUnit ( AppendFile file str ) +deleteFileIOE file = processRequestIOUnit ( DeleteFile file ) +statusFileIOE file = processRequestIOString ( StatusFile file ) +readChanIOE chan = processRequestIOString ( ReadChan chan ) +appendChanIOE chan str = processRequestIOUnit ( AppendChan chan str ) +statusChanIOE chan = processRequestIOString ( StatusChan chan ) +echoIOE bool = processRequestIOUnit ( Echo bool ) +getArgsIOE = processRequestIOStringList ( GetArgs ) +getEnvIOE var = processRequestIOString ( GetEnv var ) +setEnvIOE var obj = processRequestIOUnit ( SetEnv var obj ) +sigActionIOE sig act = processRequestIOUnit ( SigAction sig act ) + +handleErrIO :: IoResult a -> MainIO a +handleErrIO (IoSucc a) = returnMn a +handleErrIO (IoFail ioerr) = exitIO ioerr + +readFileIO :: String -> MainIO String +writeFileIO :: String -> String -> MainIO () +appendFileIO :: String -> String -> MainIO () +deleteFileIO :: String -> MainIO () +statusFileIO :: String -> MainIO String +readChanIO :: String -> MainIO String +appendChanIO :: String -> String -> MainIO () +statusChanIO :: String -> MainIO String +echoIO :: Bool -> MainIO () +getArgsIO :: MainIO [String] +getEnvIO :: String -> MainIO String +setEnvIO :: String -> String -> MainIO () +sigActionIO :: Int -> SigAct -> MainIO () + +readFileIO file = readFileIOE file `thenMn` handleErrIO +writeFileIO file str = writeFileIOE file str `thenMn` handleErrIO +appendFileIO file str = appendFileIOE file str `thenMn` handleErrIO +deleteFileIO file = deleteFileIOE file `thenMn` handleErrIO +statusFileIO file = statusFileIOE file `thenMn` handleErrIO +readChanIO chan = readChanIOE chan `thenMn` handleErrIO +appendChanIO chan str = appendChanIOE chan str `thenMn` handleErrIO +statusChanIO chan = statusChanIOE chan `thenMn` handleErrIO +echoIO bool = echoIOE bool `thenMn` handleErrIO +getArgsIO = getArgsIOE `thenMn` handleErrIO +getEnvIO var = getEnvIOE var `thenMn` handleErrIO +setEnvIO var obj = setEnvIOE var obj `thenMn` handleErrIO +sigActionIO sig act = sigActionIOE sig act `thenMn` handleErrIO + +exitIO :: IOError -> MainIO a + +exitIO (ReadError s) = error s +exitIO (WriteError s) = error s +exitIO (SearchError s) = error s +exitIO (FormatError s) = error s +exitIO (OtherError s) = error s +\end{code} + +\begin{code} +#endif {- ! __GLASGOW_HASKELL -} +\end{code} diff --git a/ghc/compiler/main/MkIface.hi b/ghc/compiler/main/MkIface.hi new file mode 100644 index 0000000..df08cd6 --- /dev/null +++ b/ghc/compiler/main/MkIface.hi @@ -0,0 +1,43 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface MkIface where +import Bag(Bag) +import CE(CE(..)) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import FiniteMap(FiniteMap) +import HsBinds(MonoBinds, Sig) +import HsDecls(FixityDecl) +import HsPat(InPat) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PrettyRep) +import SimplEnv(UnfoldingDetails) +import SrcLoc(SrcLoc) +import StgSyn(StgBinding, StgRhs) +import TCE(TCE(..)) +import TcInstDcls(InstInfo) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type CE = UniqFM Class +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +type TCE = UniqFM TyCon +data InstInfo {-# GHC_PRAGMA InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +mkInterface :: (GlobalSwitch -> Bool) -> _PackedString -> (_PackedString -> Bool, _PackedString -> Bool) -> UniqFM UnfoldingDetails -> FiniteMap TyCon [[Labda UniType]] -> ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo) -> [StgBinding Id Id] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 7 _U_ 222221122 _N_ _S_ "LLLLLU(LSSSL)L" _N_ _N_ #-} + diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs new file mode 100644 index 0000000..f4eca63 --- /dev/null +++ b/ghc/compiler/main/MkIface.lhs @@ -0,0 +1,607 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[MkIface]{Print an interface for a module} + +\begin{code} +#include "HsVersions.h" + +module MkIface ( + mkInterface, + + -- and to make the interface self-sufficient... + Bag, CE(..), GlobalSwitch, FixityDecl, Id, + Name, PrettyRep, StgBinding, TCE(..), UniqFM, InstInfo + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import AbsPrel ( mkLiftTy, pRELUDE_CORE, pRELUDE_BUILTIN ) +import AbsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds, + RenamedMonoBinds(..), Name, RenamedPat(..), Sig + ) +import AbsUniType +import Bag +import CE +import CmdLineOpts -- ( GlobalSwitch(..) ) +import FiniteMap +import Id +import IdInfo -- plenty from here +import Maybes ( catMaybes, Maybe(..) ) +import Outputable +import Pretty +import StgSyn +import TCE +import TcInstDcls ( InstInfo(..) ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[main-MkIface]{Main routine for making interfaces} +%* * +%************************************************************************ + +Misc points: +\begin{enumerate} +\item +We get the general what-to-export information from the ``environments'' +produced by the typechecker (the \tr{[RenamedFixityDecl]} through +\tr{Bag InstInfo} arguments). + +\item +{\em However:} Whereas (for example) an \tr{InstInfo} will have +\tr{Ids} in it that identify the constant methods for that instance, +those particular \tr{Ids} {\em do not have} the best @IdInfos@!!! +Those @IdInfos@ were figured out long after the \tr{InstInfo} was +created. + +That's why we actually look at the final \tr{PlainStgBindings} that go +into the code-generator: they have the best @IdInfos@ on them. +Whenever, we are about to print info about an @Id@, we look in the +Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@ +with presumably-better @IdInfo@. + +\item +We play this same game whether for values, classes (for their +method-selectors and default-methods), or instances (for their +@DictFunIds@ or constant-methods). + +Of course, for imported things, what we got from the typechecker is +all we're gonna get. + +\item +We {\em sort} things in the interface into some ``canonical'' order; +otherwise, with heavily-recursive modules, you can have (unchanged) +information ``move around'' in the interface file---deeply unfriendly +to \tr{make}. +\end{enumerate} + +\begin{code} +mkInterface :: (GlobalSwitch -> Bool) + -> FAST_STRING + -> (FAST_STRING -> Bool, -- is something in export list, explicitly? + FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules? + -> IdEnv UnfoldingDetails + -> FiniteMap TyCon [[Maybe UniType]] + -> ([RenamedFixityDecl], -- interface info from the typecheck + [Id], + CE, + TCE, + Bag InstInfo) + -> [PlainStgBinding] + -> Pretty + +mkInterface sw_chkr modname export_list_fns inline_env tycon_specs + (fixity_decls, global_ids, ce, tce, inst_infos) + stg_binds + = let + -- first, gather up the things we want to export: + + exported_tycons = [ tc | tc <- rngTCE tce, + isExported tc, + is_exportable_tycon_or_class sw_chkr export_list_fns tc ] + exported_classes = [ c | c <- rngCE ce, + isExported c, + is_exportable_tycon_or_class sw_chkr export_list_fns c ] + exported_inst_infos = [ i | i <- bagToList inst_infos, + is_exported_inst_info sw_chkr export_list_fns i ] + exported_vals + = [ v | v <- global_ids, + isExported v && not (isDataCon v) && not (isClassOpId v) ] + + -- We also have to worry about TyCons/Classes that are + -- *mentioned* in exported things (e.g., values' types or + -- instances), so that we can be sure to do an import decl for + -- them, for original-naming purposes: + + (mentioned_tycons, mentioned_classes) + = foldr ( \ (tcs1, cls1) (tcs2, cls2) + -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) ) + (emptyBag, emptyBag) + (map getMentionedTyConsAndClassesFromClass exported_classes ++ + map getMentionedTyConsAndClassesFromTyCon exported_tycons ++ + map getMentionedTyConsAndClassesFromId exported_vals ++ + map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos) + + mentionable_classes + = filter (is_mentionable sw_chkr) (bagToList mentioned_classes) + mentionable_tycons + = [ tc | tc <- bagToList mentioned_tycons, + is_mentionable sw_chkr tc, + not (isPrimTyCon tc) ] + + nondup_mentioned_tycons = fst (removeDups cmpTyCon mentionable_tycons) + nondup_mentioned_classes = fst (removeDups cmpClass mentionable_classes) + + -- Next: as discussed in the notes, we want the top-level + -- Ids straight from the final STG code, so we can use + -- their IdInfos to print pragmas; we slurp them out here, + -- then pass them to the printing functions, which may + -- use them. + + better_ids = collectExportedStgBinders stg_binds + + -- Make a lookup function for convenient access: + + better_id_fn i + = if not (isLocallyDefined i) + then i -- can't be among our "better_ids" + else + let + eq_fn = if isTopLevId i -- can't trust uniqs + then (\ x y -> getOrigName x == getOrigName y) + else eqId + in + case [ x | x <- better_ids, x `eq_fn` i ] of + [] -> pprPanic "better_id_fn:" (ppr PprShowAll i) + i + [x] -> x + _ -> panic "better_id_fn" + + -- Finally, we sort everything lexically, so that we always + -- get the same interface from the same information: + + sorted_mentioned_tycons = sortLt ltLexical nondup_mentioned_tycons + sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes + + sorted_tycons = sortLt ltLexical exported_tycons + sorted_classes = sortLt ltLexical exported_classes + sorted_vals = sortLt ltLexical exported_vals + sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos + in + if (any_purely_local sorted_tycons sorted_classes sorted_vals) then + -- this will be less of a HACK when we teach + -- 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 5 #-}"), + ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")], + + do_import_decls sw_chkr modname + sorted_vals sorted_mentioned_classes sorted_mentioned_tycons, + -- Mustn't give the data constructors to do_import_decls, + -- because they aren't explicitly imported; their tycon is. + -- ToDo: modify if we ever add renaming properly. + + ppAboves (map (do_fixity sw_chkr) fixity_decls), + ppAboves (map (pprIfaceClass sw_chkr better_id_fn inline_env) sorted_classes), + ppAboves (map (do_tycon sw_chkr tycon_specs) sorted_tycons), + ppAboves (map (do_value sw_chkr better_id_fn inline_env) sorted_vals), + ppAboves (map (do_instance sw_chkr better_id_fn inline_env) sorted_inst_infos), + + ppChar '\n' + ] +-- ) + where + any_purely_local tycons classes vals + = any bad_tc tycons || any bad_cl classes || any bad_id vals + where + bad_cl cl + = case (maybePurelyLocalClass cl) of + Nothing -> False + Just xs -> naughty_trace cl xs + + bad_id id + = case (maybePurelyLocalType (getIdUniType id)) of + Nothing -> False + Just xs -> naughty_trace id xs + + bad_tc tc + = case (maybePurelyLocalTyCon tc) of + Nothing -> False + Just xs -> if exported_abs then False else naughty_trace tc xs + where + exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False } + + naughty_trace x things + = pprTrace "Can't export -- `" + (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ", + ppInterleave pp'SP things]) + True +\end{code} + +%************************************************************************ +%* * +\subsection[imports-MkIface]{Generating `import' declarations in an interface} +%* * +%************************************************************************ + +Not handling renaming yet (ToDo) + +We gather up lots of (module, name) pairs for which we might print an +import declaration. We sort them, for the usual canonicalisation +reasons. NB: We {\em assume} the lists passed in don't have duplicates in +them! expect). + +All rather horribly turgid (WDP). + +\begin{code} +do_import_decls + :: (GlobalSwitch -> Bool) + -> FAST_STRING + -> [Id] -> [Class] -> [TyCon] + -> Pretty + +do_import_decls sw_chkr mod_name vals classes tycons + = let + -- Conjure up (module, name, maybe_renaming) triples for all + -- the potentially import-decls things: + + vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] + vals_names = map get_val_triple vals + classes_names = map get_class_triple classes + tycons_names = map get_tycon_triple tycons + + -- sort the (module, name, renaming) triples and chop + -- them into per-module groups: + + ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names) + + per_module_groups = runs same_module ie_list + in + ppAboves (map print_a_decl per_module_groups) + where + lt, same_module :: (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) + -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) -> Bool + + lt (m1, ie1, _) (m2, ie2, _) + = case _CMP_STRING_ m1 m2 of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False } + + same_module (m1, _, _) (m2, _, _) = m1 == m2 + + compiling_the_prelude = sw_chkr CompilingPrelude + + print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty + {- + Obviously, if the module in question is this one, + don't print an import declaration. + + If it's a Prelude* module, we don't print the TyCons/ + Classes, because the compiler supposedly knows about + them already (and they are PreludeCore things anyway). + + But if we are compiling a Prelude module, then we + try to do it as "normally" as possible. + -} + print_a_decl (ielist@((m,_,_) : _)) + | m == mod_name + || (not compiling_the_prelude && + (m == pRELUDE_CORE || m == pRELUDE_BUILTIN)) + = ppNil + + | otherwise + = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen, + ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]), + ppRparen, + case (grab_non_Nothings [rns | (_,_,rns) <- ielist]) of + [] -> ppNil + renamings -> pp_renamings renamings + ] + where + isnt_tycon_ish :: FAST_STRING -> Bool + isnt_tycon_ish str = not (isConop str) + + grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING] + + grab_non_Nothings rns = catMaybes (concat rns) + + pp_str :: FAST_STRING -> Pretty + pp_str pstr + = if isAvarop pstr then ppStr ("("++str++")") else ppPStr pstr + where + str = _UNPK_ pstr + + pp_renamings strs + = ppBesides [ ppPStr SLIT(" renaming "), ppLparen, ppIntersperse pp'SP{-'-} (map ppPStr strs), ppRparen ] +\end{code} + +Most of the huff and puff here is to ferret out renaming strings. + +\begin{code} +get_val_triple :: Id -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) +get_class_triple :: Class -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) +get_tycon_triple :: TyCon -> (FAST_STRING, FAST_STRING, [Maybe FAST_STRING]) + +get_val_triple id + = case (generic_triple id) of { (a,b,rn) -> + (a,b,[rn]) } + +get_class_triple clas + = case (generic_triple clas) of { (orig_mod, orig_nm, clas_rn) -> + let + nm_to_print = case (getExportFlag clas) of + ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK! + ExportAbs -> orig_nm + NotExported -> orig_nm + +-- Ops don't have renaming info (bug) ToDo +-- ops = getClassOps clas +-- ops_rns = [ rn | (_,_,rn) <- map generic_triple ops ] + in + (orig_mod, nm_to_print, [clas_rn]) } + +get_tycon_triple tycon + = case (generic_triple tycon) of { (orig_mod, orig_nm, tycon_rn) -> + let + nm_to_print = case (getExportFlag tycon) of + ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK! + ExportAbs -> orig_nm + NotExported -> orig_nm + + cons = getTyConDataCons tycon + cons_rns = [ rn | (_,_,rn) <- map generic_triple cons ] + in + (orig_mod, nm_to_print, tycon_rn : cons_rns) } + +generic_triple thing + = case (getOrigName thing) of { (orig_mod, orig_nm) -> + case (getOccurrenceName thing) of { occur_name -> + (orig_mod, orig_nm, + if orig_nm == occur_name + then Nothing + else Just (orig_nm _APPEND_ SLIT(" to ") _APPEND_ occur_name) + )}} +\end{code} + +%************************************************************************ +%* * +\subsection[fixities-MkIface]{Generating fixity declarations in an interface} +%* * +%************************************************************************ + + +\begin{code} +do_fixity :: (GlobalSwitch -> Bool) -> RenamedFixityDecl -> Pretty + +do_fixity sw_chkr fixity_decl + = case (getExportFlag (get_name fixity_decl)) of + ExportAll -> ppr (PprInterface sw_chkr) fixity_decl + _ -> ppNil + where + get_name (InfixL n _) = n + get_name (InfixR n _) = n + get_name (InfixN n _) = n +\end{code} + +%************************************************************************ +%* * +\subsection[tycons-MkIface]{Generating tycon declarations in an interface} +%* * +%************************************************************************ + +\begin{code} +do_tycon :: (GlobalSwitch -> Bool) -> FiniteMap TyCon [[Maybe UniType]] -> TyCon -> Pretty + +do_tycon sw_chkr tycon_specs_map tycon + = pprTyCon (PprInterface sw_chkr) tycon tycon_specs + where + tycon_specs = lookupWithDefaultFM tycon_specs_map [] tycon +\end{code} + +%************************************************************************ +%* * +\subsection[values-MkIface]{Generating a value's signature in an interface} +%* * +%************************************************************************ + +\begin{code} +do_value :: (GlobalSwitch -> Bool) + -> (Id -> Id) + -> IdEnv UnfoldingDetails + -> Id + -> Pretty + +do_value sw_chkr better_id_fn inline_env val + = let + sty = PprInterface sw_chkr + better_val = better_id_fn val + name_str = getOccurrenceName better_val -- NB: not orig name! + + id_info = getIdInfo better_val + + val_ty = let + orig_ty = getIdUniType val + final_ty = getIdUniType better_val + in +-- ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) + ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False) + orig_ty + + -- Note: We export the type of the original val + -- The type of an unboxed val will have been *lifted* by the desugarer + -- In this case we export an unlifted type, but id_info which assumes + -- a lifted Id i.e. extracted from better_val (above) + -- The importing module must lift the Id before using the imported id_info + + pp_id_info + = if sw_chkr OmitInterfacePragmas + || boringIdInfo id_info + then ppNil + else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), + ppIdInfo sty better_val True{-specs, absolutely-} + better_id_fn inline_env id_info, + ppPStr SLIT("#-}")] + in + ppAbove (ppCat [ppr_non_op name_str, + ppPStr SLIT("::"), pprUniType sty val_ty]) + pp_id_info + +-- sadly duplicates Outputable.pprNonOp (ToDo) + +ppr_non_op str + = if isAvarop str -- NOT NEEDED: || isAconop + then ppBesides [ppLparen, ppPStr str, ppRparen] + else ppPStr str +\end{code} + +%************************************************************************ +%* * +\subsection[instances-MkIface]{Generating instance declarations in an interface} +%* * +%************************************************************************ + +The types of ``dictionary functions'' (dfuns) have just the required +info for instance declarations in interfaces. However, the dfuns that +GHC really uses have {\em extra} dictionaries passed to them (for +efficiency). When we print interfaces, we want to omit that +dictionary information. (It can be reconsituted on the other end, +from instance and class decls). + +\begin{code} +do_instance :: (GlobalSwitch -> Bool) + -> (Id -> Id) + -> IdEnv UnfoldingDetails + -> InstInfo + -> Pretty + +do_instance sw_chkr better_id_fn inline_env + (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _) + = let + sty = PprInterface sw_chkr + + better_dfun = better_id_fn dfun_id + better_dfun_info = getIdInfo better_dfun + better_constms = map better_id_fn constm_ids + + class_op_strs = map getClassOpString (getClassOps clas) + + pragma_begin + = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"), + ppIdInfo sty better_dfun False{-NO specs-} + better_id_fn inline_env better_dfun_info] + + pragma_end = ppPStr SLIT("#-}") + + pp_modname = if _NULL_ modname + then ppNil + else ppCat [ppStr "_M_", ppPStr modname] + + name_pragma_pairs + = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals, + ppIdInfo sty constm True{-YES, specs-} + better_id_fn inline_env + (getIdInfo constm)] + | (op, constm) <- class_op_strs `zip` better_constms ] + +#ifdef DEBUG + pp_the_list [] = panic "MkIface: no class_ops or better_constms?" +#endif + pp_the_list [p] = p + pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps) + + real_stuff + = ppCat [ppPStr SLIT("instance"), + ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))] + in + if sw_chkr OmitInterfacePragmas + || boringIdInfo better_dfun_info + then real_stuff + else ppAbove real_stuff + ({-ppNest 8 -} -- ppNest does nothing + if null better_constms + then ppCat [pragma_begin, pragma_end] + else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end]) + -- ToDo: specialised instances + ) +\end{code} + +%************************************************************************ +%* * +\subsection[utils-InstInfos]{Utility functions for @InstInfos@} +%* * +%************************************************************************ + +ToDo: perhaps move. + +Classes/TyCons are ``known,'' more-or-less. Prelude TyCons are +``completely'' known---they don't need to be mentioned in interfaces. +Classes usually don't need to be mentioned in interfaces, but if we're +compiling the prelude, then we treat them without special favours. +\begin{code} +is_exportable_tycon_or_class sw_chkr export_list_fns tc + = if not (fromPreludeCore tc) then + True + else + in_export_list_or_among_dotdot_modules + (sw_chkr CompilingPrelude) -- ignore M.. stuff if compiling prelude + export_list_fns tc + +in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc + = if in_export_list (getOccurrenceName tc) then + True + else +-- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccurrenceName tc))) ( + if ignore_Mdotdots then + False + else + any among_dotdot_modules (getInformingModules tc) +-- ) + +is_mentionable sw_chkr tc + = not (from_PreludeCore_or_Builtin tc) || (sw_chkr CompilingPrelude) + where + from_PreludeCore_or_Builtin thing + = let + mod_name = fst (getOrigName thing) + in + mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN + +is_exported_inst_info sw_chkr export_list_fns + (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) + = let + is_fun_tycon = isFunType ty + + seems_exported = instanceIsExported clas ty from_here + + (tycon, _, _) = getUniDataTyCon ty + in + if (sw_chkr OmitReexportedInstances && not from_here) then + False -- Flag says to violate Haskell rules, blatantly + + else if not (sw_chkr CompilingPrelude) + || not (is_fun_tycon || fromPreludeCore tycon) + || not (fromPreludeCore clas) then + seems_exported -- take what we got + + else -- compiling Prelude & tycon/class are Prelude things... + from_here + || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas + || (not is_fun_tycon + && in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon) +\end{code} + +\begin{code} +lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _) + = ltLexical dfun1 dfun2 +\end{code} + +\begin{code} +getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _) + = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) -> + case [ c | (c, _) <- dfun_theta ] of { theta_classes -> + (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas) + }} +\end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.hi b/ghc/compiler/nativeGen/AbsCStixGen.hi new file mode 100644 index 0000000..96ac402 --- /dev/null +++ b/ghc/compiler/nativeGen/AbsCStixGen.hi @@ -0,0 +1,28 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsCStixGen where +import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import ClosureInfo(ClosureInfo) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import MachDesc(RegLoc, Target) +import Maybes(Labda) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep) +import SplitUniq(SUniqSM(..), SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +genCodeAbstractC :: Target -> AbstractC -> SplitUniqSupply -> [[StixTree]] + {-# GHC_PRAGMA _A_ 2 _U_ 221 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs new file mode 100644 index 0000000..67d4e15 --- /dev/null +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -0,0 +1,616 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" + +module AbsCStixGen ( + genCodeAbstractC, + + -- and, of course, that's not enough... + AbstractC, Target, StixTree, SplitUniqSupply, SUniqSM(..) + ) where + +import AbsCSyn +import AbsPrel ( PrimOp(..), primOpNeedsWrapper, isCompareOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import CgCompInfo ( mIN_UPD_SIZE ) +import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI, + closureUpdReqd + ) +import MachDesc +import Maybes ( Maybe(..), maybeToBool ) +import Outputable +import PrimKind ( isFloatingKind ) +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import Stix +import StixInfo ( genCodeInfoTable ) +import SplitUniq +import Unique +import Util +\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. + +\begin{code} + +genCodeAbstractC + :: Target + -> AbstractC + -> SUniqSM [[StixTree]] + +genCodeAbstractC target absC = + mapSUs (genCodeTopAbsC target) (mkAbsCStmtList absC) `thenSUs` \ trees -> + returnSUs ([StComment SLIT("Native Code")] : trees) + +\end{code} + +Here we handle top-level things, like @CCodeBlock@s and +@CClosureInfoTable@s. + +\begin{code} + +genCodeTopAbsC + :: Target + -> AbstractC + -> SUniqSM [StixTree] + +genCodeTopAbsC target (CCodeBlock label absC) = + genCodeAbsC target absC `thenSUs` \ code -> + returnSUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label]) + +genCodeTopAbsC target stmt@(CStaticClosure label _ _ _) = + genCodeStaticClosure target stmt `thenSUs` \ code -> + returnSUs (StSegment DataSegment : StLabel label : code []) + +genCodeTopAbsC target stmt@(CRetUnVector _ _) = returnSUs [] + +genCodeTopAbsC target stmt@(CFlatRetVector label _) = + genCodeVecTbl target stmt `thenSUs` \ code -> + returnSUs (StSegment TextSegment : code [StLabel label]) + +genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow Nothing _ _) + + | slow_is_empty + = genCodeInfoTable target stmt `thenSUs` \ itbl -> + returnSUs (StSegment TextSegment : itbl []) + + | otherwise + = genCodeInfoTable target stmt `thenSUs` \ itbl -> + genCodeAbsC target slow `thenSUs` \ slow_code -> + returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : + slow_code [StFunEnd slow_lbl])) + where + slow_is_empty = not (maybeToBool (nonemptyAbsC slow)) + slow_lbl = entryLabelFromCI cl_info + +genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) = +-- ToDo: what if this is empty? ------------------------^^^^ + genCodeInfoTable target stmt `thenSUs` \ itbl -> + genCodeAbsC target slow `thenSUs` \ slow_code -> + genCodeAbsC target fast `thenSUs` \ fast_code -> + returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl : + slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl : + fast_code [StFunEnd fast_lbl]))) + where + slow_lbl = entryLabelFromCI cl_info + fast_lbl = fastLabelFromCI cl_info + +genCodeTopAbsC target absC = + genCodeAbsC target absC `thenSUs` \ code -> + returnSUs (StSegment TextSegment : code []) + +\end{code} + +Now the individual AbstractC statements. + +\begin{code} + +genCodeAbsC + :: Target + -> AbstractC + -> SUniqSM StixTreeList + +\end{code} + +@AbsCNop@s just disappear. + +\begin{code} + +genCodeAbsC target AbsCNop = returnSUs id + +\end{code} + +OLD:@CComment@s are passed through as the corresponding @StComment@s. + +\begin{code} + +--UNUSED:genCodeAbsC target (CComment s) = returnSUs (\xs -> StComment s : xs) + +\end{code} + +Split markers are a NOP in this land. + +\begin{code} + +genCodeAbsC target CSplitMarker = returnSUs id + +\end{code} + +AbstractC instruction sequences are handled individually, and the +resulting StixTreeLists are joined together. + +\begin{code} + +genCodeAbsC target (AbsCStmts c1 c2) = + genCodeAbsC target c1 `thenSUs` \ b1 -> + genCodeAbsC target c2 `thenSUs` \ b2 -> + returnSUs (b1 . b2) + +\end{code} + +Initialising closure headers in the heap...a fairly complex ordeal if +done properly. For now, we just set the info pointer, but we should +really take a peek at the flags to determine whether or not there are +other things to be done (setting cost centres, age headers, global +addresses, etc.) + +\begin{code} + +genCodeAbsC target (CInitHdr cl_info reg_rel _ _) = + let + lhs = amodeToStix target (CVal reg_rel PtrKind) + lbl = infoTableLabelFromCI cl_info + in + returnSUs (\xs -> StAssign PtrKind lhs (StCLbl lbl) : xs) + +\end{code} + +Assignment, the curse of von Neumann, is the center of the code we +produce. In most cases, the type of the assignment is determined +by the type of the destination. However, when the destination can +have mixed types, the type of the assignment is ``StgWord'' (we use +PtrKind for lack of anything better). Think: do we also want a cast +of the source? Be careful about floats/doubles. + +\begin{code} + +genCodeAbsC target (CAssign lhs rhs) + | getAmodeKind lhs == VoidKind = returnSUs id + | otherwise = + let pk = getAmodeKind lhs + pk' = if mixedTypeLocn lhs && not (isFloatingKind pk) then IntKind else pk + lhs' = amodeToStix target lhs + rhs' = amodeToStix' target rhs + in + returnSUs (\xs -> StAssign pk' lhs' rhs' : xs) + +\end{code} + +Unconditional jumps, including the special ``enter closure'' operation. +Note that the new entry convention requires that we load the InfoPtr (R2) +with the address of the info table before jumping to the entry code for Node. + +\begin{code} + +genCodeAbsC target (CJump dest) = + returnSUs (\xs -> StJump (amodeToStix target dest) : xs) + +genCodeAbsC target (CFallThrough (CLbl lbl _)) = + returnSUs (\xs -> StFallThrough lbl : xs) + +genCodeAbsC target (CReturn dest DirectReturn) = + returnSUs (\xs -> StJump (amodeToStix target dest) : xs) + +genCodeAbsC target (CReturn table (StaticVectoredReturn n)) = + returnSUs (\xs -> StJump dest : xs) + where + dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table) + (StInt (toInteger (-n-1)))) + +genCodeAbsC target (CReturn table (DynamicVectoredReturn am)) = + returnSUs (\xs -> StJump dest : xs) + where + dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table) dyn_off) + dyn_off = StPrim IntSubOp [StPrim IntNegOp [amodeToStix target am], StInt 1] + +\end{code} + +Now the PrimOps, some of which may need caller-saves register wrappers. + +\begin{code} + +genCodeAbsC target (COpStmt results op args liveness_mask vols) + -- ToDo (ADR?): use that liveness mask + | primOpNeedsWrapper op = + let + saves = volatileSaves target vols + restores = volatileRestores target vols + in + primToStix target (nonVoid results) op (nonVoid args) + `thenSUs` \ code -> + returnSUs (\xs -> saves ++ code (restores ++ xs)) + + | otherwise = primToStix target (nonVoid results) op (nonVoid args) + where + nonVoid = filter ((/= VoidKind) . getAmodeKind) + +\end{code} + +Now the dreaded conditional jump. + +Now the if statement. Almost *all* flow of control are of this form. +@ + if (am==lit) { absC } else { absCdef } +@ + => +@ + IF am = lit GOTO l1: + absC + jump l2: + l1: + absCdef + l2: +@ + +\begin{code} + +genCodeAbsC target (CSwitch discrim alts deflt) + = case alts of + [] -> genCodeAbsC target deflt + + [(tag,alt_code)] -> case maybe_empty_deflt of + Nothing -> genCodeAbsC target alt_code + Just dc -> mkIfThenElse target discrim tag alt_code dc + + [(tag1@(MachInt i1 _), alt_code1), + (tag2@(MachInt i2 _), alt_code2)] + | deflt_is_empty && i1 == 0 && i2 == 1 + -> mkIfThenElse target discrim tag1 alt_code1 alt_code2 + | deflt_is_empty && i1 == 1 && i2 == 0 + -> mkIfThenElse target discrim tag2 alt_code2 alt_code1 + + -- If the @discrim@ is simple, then this unfolding is safe. + other | simple_discrim -> mkSimpleSwitches target discrim alts deflt + + -- Otherwise, we need to do a bit of work. + other -> getSUnique `thenSUs` \ u -> + genCodeAbsC target (AbsCStmts + (CAssign (CTemp u pk) discrim) + (CSwitch (CTemp u pk) alts deflt)) + + where + maybe_empty_deflt = nonemptyAbsC deflt + deflt_is_empty = case maybe_empty_deflt of + Nothing -> True + Just _ -> False + + pk = getAmodeKind discrim + + simple_discrim = case discrim of + CReg _ -> True + CTemp _ _ -> True + other -> False +\end{code} + + + +Finally, all of the disgusting AbstractC macros. + +\begin{code} + +genCodeAbsC target (CMacroStmt macro args) = macroCode target macro args + +genCodeAbsC target (CCallProfCtrMacro macro _) = + returnSUs (\xs -> StComment macro : xs) + +genCodeAbsC target (CCallProfCCMacro macro _) = + returnSUs (\xs -> StComment macro : xs) + +\end{code} + +Here, we generate a jump table if there are more than four (integer) alternatives and +the jump table occupancy is greater than 50%. Otherwise, we generate a binary +comparison tree. (Perhaps this could be tuned.) + +\begin{code} + +intTag :: BasicLit -> Integer +intTag (MachChar c) = toInteger (ord c) +intTag (MachInt i _) = i +intTag _ = panic "intTag" + +fltTag :: BasicLit -> Rational + +fltTag (MachFloat f) = f +fltTag (MachDouble d) = d +fltTag _ = panic "fltTag" + +mkSimpleSwitches + :: Target + -> CAddrMode -> [(BasicLit,AbstractC)] -> AbstractC + -> SUniqSM StixTreeList + +mkSimpleSwitches target am alts absC = + getUniqLabelNCG `thenSUs` \ udlbl -> + getUniqLabelNCG `thenSUs` \ ujlbl -> + let am' = amodeToStix target am + joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts + sortedAlts = naturalMergeSortLe leAlt joinedAlts + -- naturalMergeSortLe, because we often get sorted alts to begin with + + lowTag = intTag (fst (head sortedAlts)) + highTag = intTag (fst (last sortedAlts)) + + -- 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 + mkJumpTable target am' sortedAlts lowTag highTag udlbl + else + mkBinaryTree target am' floating sortedAlts choices lowest highest udlbl + ) + `thenSUs` \ alt_code -> + genCodeAbsC target absC `thenSUs` \ dflt_code -> + + returnSUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs))) + + where + floating = isFloatingKind (getAmodeKind am) + choices = length alts + + (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y + (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y + (x,_) `leAlt` (y,_) = fltTag x <= fltTag y + +\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. + +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 + -> [(BasicLit, AbstractC)] -- alternatives + -> Integer -- low tag + -> Integer -- high tag + -> CLabel -- default label + -> SUniqSM StixTreeList + +mkJumpTable target am alts lowTag highTag dflt = + getUniqLabelNCG `thenSUs` \ utlbl -> + mapSUs genLabel alts `thenSUs` \ branches -> + let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag]) + cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag]) + + offset = StPrim IntSubOp [am, StInt lowTag] + jump = StJump (StInd PtrKind (StIndex PtrKind (StCLbl utlbl) offset)) + + tlbl = StLabel utlbl + table = StData PtrKind (mkTable branches [lowTag..highTag] []) + in + mapSUs mkBranch branches `thenSUs` \ alts -> + + returnSUs (\xs -> cjmpLo : cjmpHi : jump : + StSegment DataSegment : tlbl : table : + StSegment TextSegment : foldr1 (.) alts xs) + + where + genLabel x = getUniqLabelNCG `thenSUs` \ lbl -> returnSUs (lbl, x) + + mkBranch (lbl,(_,alt)) = + genCodeAbsC target alt `thenSUs` \ alt_code -> + returnSUs (\xs -> StLabel lbl : alt_code xs) + + mkTable _ [] tbl = reverse tbl + mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl) + mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl + | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl) + | otherwise = mkTable alts xs (StCLbl dflt : tbl) + +\end{code} + +We generate binary comparison trees when a jump table is inappropriate. +We expect to be given a list of alternatives, sorted by tag, and for +convenience, the length of the alternative list. We recursively break +the list in half and do a comparison on the first tag of the second half +of the list. (Odd lists are broken so that the second half of the list +is longer.) We can handle either integer or floating kind alternatives, +so long as they are not mixed. (We assume that the type of the discriminant +determines the type of the alternatives.) + +As with the jump table approach, if a join is necessary after the switch, the +alternatives should already finish with a jump to the join point. + +\begin{code} + +mkBinaryTree + :: Target + -> StixTree -- discriminant + -> Bool -- floating point? + -> [(BasicLit, AbstractC)] -- alternatives + -> Int -- number of choices + -> BasicLit -- low tag + -> BasicLit -- high tag + -> CLabel -- default code label + -> SUniqSM StixTreeList + +mkBinaryTree target am floating [(tag,alt)] _ lowTag highTag udlbl + | rangeOfOne = genCodeAbsC target alt + | otherwise = + let tag' = amodeToStix target (CLit tag) + cmpOp = if floating then DoubleNeOp else IntNeOp + test = StPrim cmpOp [am, tag'] + cjmp = StCondJump udlbl test + in + genCodeAbsC target alt `thenSUs` \ alt_code -> + returnSUs (\xs -> cjmp : alt_code xs) + + where + rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag + -- When there is only one possible tag left in range, we skip the comparison + +mkBinaryTree target am floating alts choices lowTag highTag udlbl = + getUniqLabelNCG `thenSUs` \ uhlbl -> + let tag' = amodeToStix target (CLit splitTag) + cmpOp = if floating then DoubleGeOp else IntGeOp + test = StPrim cmpOp [am, tag'] + cjmp = StCondJump uhlbl test + in + mkBinaryTree target am floating alts_lo half lowTag splitTag udlbl + `thenSUs` \ lo_code -> + mkBinaryTree target am floating alts_hi (choices - half) splitTag highTag udlbl + `thenSUs` \ hi_code -> + + returnSUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs)) + + where + half = choices `div` 2 + (alts_lo, alts_hi) = splitAt half alts + splitTag = fst (head alts_hi) + +\end{code} + +\begin{code} + +mkIfThenElse + :: Target + -> CAddrMode -- discriminant + -> BasicLit -- tag + -> AbstractC -- if-part + -> AbstractC -- else-part + -> SUniqSM StixTreeList + +mkIfThenElse target discrim tag alt deflt = + getUniqLabelNCG `thenSUs` \ ujlbl -> + getUniqLabelNCG `thenSUs` \ utlbl -> + let discrim' = amodeToStix target discrim + tag' = amodeToStix target (CLit tag) + cmpOp = if (isFloatingKind (getAmodeKind discrim)) then DoubleNeOp else IntNeOp + test = StPrim cmpOp [discrim', tag'] + cjmp = StCondJump utlbl test + dest = StLabel utlbl + join = StLabel ujlbl + in + genCodeAbsC target (mkJoin alt ujlbl) `thenSUs` \ alt_code -> + genCodeAbsC target deflt `thenSUs` \ dflt_code -> + returnSUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs))) + +mkJoin :: AbstractC -> CLabel -> AbstractC + +mkJoin code lbl + | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrKind)) + | otherwise = code + +\end{code} + +%--------------------------------------------------------------------------- + +This answers the question: Can the code fall through to the next +line(s) of code? This errs towards saying True if it can't choose, +because it is used for eliminating needless jumps. In other words, if +you might possibly {\em not} jump, then say yes to falling through. + +\begin{code} +mightFallThrough :: AbstractC -> Bool + +mightFallThrough absC = ft absC True + where + ft AbsCNop if_empty = if_empty + + ft (CJump _) if_empty = False + ft (CReturn _ _) if_empty = False + ft (CSwitch _ alts deflt) if_empty + = ft deflt if_empty || + or [ft alt if_empty | (_,alt) <- alts] + + ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty) + ft _ if_empty = if_empty + +{- Old algorithm, which called nonemptyAbsC for every subexpression! ========= +fallThroughAbsC (AbsCStmts c1 c2) = + case nonemptyAbsC c2 of + Nothing -> fallThroughAbsC c1 + Just x -> fallThroughAbsC x +fallThroughAbsC (CJump _) = False +fallThroughAbsC (CReturn _ _) = False +fallThroughAbsC (CSwitch _ choices deflt) + = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt) + || or (map (fallThroughAbsC . snd) choices) +fallThroughAbsC other = True + +isEmptyAbsC :: AbstractC -> Bool +isEmptyAbsC = not . maybeToBool . nonemptyAbsC +================= End of old, quadratic, algorithm -} +\end{code} + +Vector tables are trivial! + +\begin{code} + +genCodeVecTbl + :: Target + -> AbstractC + -> SUniqSM StixTreeList + +genCodeVecTbl target (CFlatRetVector label amodes) = + returnSUs (\xs -> vectbl : xs) + where + vectbl = StData PtrKind (reverse (map (amodeToStix target) amodes)) + +\end{code} + +Static closures are not so hard either. + +\begin{code} + +genCodeStaticClosure + :: Target + -> AbstractC + -> SUniqSM StixTreeList + +genCodeStaticClosure target (CStaticClosure _ cl_info cost_centre amodes) = + returnSUs (\xs -> table : xs) + where + table = StData PtrKind (StCLbl info_lbl : body) + info_lbl = infoTableLabelFromCI cl_info + + body = if closureUpdReqd cl_info then + take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros) + else + amodes' + + zeros = StInt 0 : zeros + + amodes' = map amodeZeroVoid amodes + + -- Watch out for VoidKinds...cf. PprAbsC + amodeZeroVoid item + | getAmodeKind item == VoidKind = StInt 0 + | otherwise = amodeToStix target item + +\end{code} + diff --git a/ghc/compiler/nativeGen/AlphaCode.hi b/ghc/compiler/nativeGen/AlphaCode.hi new file mode 100644 index 0000000..540276d --- /dev/null +++ b/ghc/compiler/nativeGen/AlphaCode.hi @@ -0,0 +1,86 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AlphaCode where +import AbsCSyn(MagicId) +import AsmRegAlloc(MachineCode, MachineRegisters, Reg) +import BitSet(BitSet) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import FiniteMap(FiniteMap) +import Maybes(Labda) +import OrdList(OrdList) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import Stix(CodeSegment) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data Addr = AddrImm Imm | AddrReg Reg | AddrRegImm Reg Imm +type AlphaCode = OrdList AlphaInstr +data AlphaInstr + = LD Size Reg Addr | LDA Reg Addr | LDAH Reg Addr | LDGP Reg Addr | LDI Size Reg Imm | ST Size Reg Addr | CLR Reg | ABS Size RI Reg | NEG Size Bool RI Reg | ADD Size Bool Reg RI Reg | SADD Size Size Reg RI Reg | SUB Size Bool Reg RI Reg | SSUB Size Size Reg RI Reg | MUL Size Bool Reg RI Reg | DIV Size Bool Reg RI Reg | REM Size Bool Reg RI Reg | NOT RI Reg | AND Reg RI Reg | ANDNOT Reg RI Reg | OR Reg RI Reg | ORNOT Reg RI Reg | XOR Reg RI Reg | XORNOT Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | ZAP Reg RI Reg | ZAPNOT Reg RI Reg | NOP | CMP Cond Reg RI Reg | FCLR Reg | FABS Reg Reg | FNEG Size Reg Reg | FADD Size Reg Reg Reg | FDIV Size Reg Reg Reg | FMUL Size Reg Reg Reg | FSUB Size Reg Reg Reg | CVTxy Size Size Reg Reg | FCMP Size Cond Reg Reg Reg | FMOV Reg Reg | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm | JMP Reg Addr Int | BSR Imm Int | JSR Reg Addr Int | LABEL CLabel | FUNBEGIN CLabel | FUNEND CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm] +data AlphaRegs {-# GHC_PRAGMA SRegs BitSet BitSet #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-} +data BitSet {-# GHC_PRAGMA MkBS Word# #-} +data CLabel +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data Cond = EQ | LT | LE | ULT | ULE | NE | GT | GE | ALWAYS | NEVER +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-} +data RI = RIReg Reg | RIImm Imm +data Size = B | BU | W | WU | L | Q | FF | DF | GF | SF | TF +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +argRegs :: [(Reg, Reg)] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +baseRegOffset :: MagicId -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +callerSaves :: MagicId -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +f0 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +freeRegs :: [Reg] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gp :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [29#] _N_ #-} +kindToSize :: PrimKind -> Size + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +printLabeledCodes :: PprStyle -> [AlphaInstr] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +pv :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ra :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [26#] _N_ #-} +reservedRegs :: [Int] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +sp :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [30#] _N_ #-} +stgRegMap :: MagicId -> Labda Reg + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +strImmLab :: [Char] -> Imm + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +v0 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +zero :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [31#] _N_ #-} +instance MachineCode AlphaInstr + {-# GHC_PRAGMA _M_ AlphaCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(AlphaInstr -> RegUsage), (AlphaInstr -> RegLiveness -> RegLiveness), (AlphaInstr -> (Reg -> Reg) -> AlphaInstr), (Reg -> Reg -> OrdList AlphaInstr), (Reg -> Reg -> OrdList AlphaInstr)] [_CONSTM_ MachineCode regUsage (AlphaInstr), _CONSTM_ MachineCode regLiveness (AlphaInstr), _CONSTM_ MachineCode patchRegs (AlphaInstr), _CONSTM_ MachineCode spillReg (AlphaInstr), _CONSTM_ MachineCode loadReg (AlphaInstr)] _N_ + regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_, + patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_, + spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_, + loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance MachineRegisters AlphaRegs + {-# GHC_PRAGMA _M_ AlphaCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> AlphaRegs), (PrimKind -> AlphaRegs -> [Int]), (AlphaRegs -> Int# -> AlphaRegs), (AlphaRegs -> [Int] -> AlphaRegs), (AlphaRegs -> Int# -> AlphaRegs), (AlphaRegs -> [Int] -> AlphaRegs)] [_CONSTM_ MachineRegisters mkMRegs (AlphaRegs), _CONSTM_ MachineRegisters possibleMRegs (AlphaRegs), _CONSTM_ MachineRegisters useMReg (AlphaRegs), _CONSTM_ MachineRegisters useMRegs (AlphaRegs), _CONSTM_ MachineRegisters freeMReg (AlphaRegs), _CONSTM_ MachineRegisters freeMRegs (AlphaRegs)] _N_ + mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_, + possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_, + useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_, + useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_, + freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_, + freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/AlphaCode.lhs b/ghc/compiler/nativeGen/AlphaCode.lhs new file mode 100644 index 0000000..91d3aca --- /dev/null +++ b/ghc/compiler/nativeGen/AlphaCode.lhs @@ -0,0 +1,1413 @@ +% +% (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 ... + CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..), + UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet + ) where + +IMPORT_Trace + +import AbsCSyn ( MagicId(..) ) +import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..), + Reg(..), RegUsage(..), RegLiveness(..) + ) +import BitSet +import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC ) +import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG ) +import FiniteMap +import Maybes ( Maybe(..), maybeToBool ) +import OrdList ( OrdList, mkUnitList, flattenOrdList ) +import Outputable +import PrimKind ( PrimKind(..) ) +import 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 + | 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 FloatKind (SRegs _ floats) = [ x + 32 | x <- listBS floats] + possibleMRegs DoubleKind (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 + -- Alas, we don't do anything clever with our OrdLists +--OLD: +-- flatten = flattenOrdList + + 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 :: PrimKind -> Size +kindToSize PtrKind = Q +kindToSize CodePtrKind = Q +kindToSize DataPtrKind = Q +kindToSize RetKind = Q +kindToSize InfoPtrKind = Q +kindToSize CostCentreKind = Q +kindToSize CharKind = BU +kindToSize IntKind = Q +kindToSize WordKind = Q +kindToSize AddrKind = Q +kindToSize FloatKind = TF +kindToSize DoubleKind = TF +kindToSize ArrayKind = Q +kindToSize ByteArrayKind = Q +kindToSize StablePtrKind = Q +kindToSize MallocPtrKind = Q + +\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 + +--OLD: +--endUsage :: RegUsage +--endUsage = RU emptyUniqSet freeSet + +-- 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.hi b/ghc/compiler/nativeGen/AlphaDesc.hi new file mode 100644 index 0000000..9245388 --- /dev/null +++ b/ghc/compiler/nativeGen/AlphaDesc.hi @@ -0,0 +1,24 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AlphaDesc where +import AbsCSyn(MagicId) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import MachDesc(RegLoc, Target) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import Stix(CodeSegment, StixReg, StixTree) +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +mkAlpha :: (GlobalSwitch -> SwitchResult) -> Target + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/AlphaDesc.lhs b/ghc/compiler/nativeGen/AlphaDesc.lhs new file mode 100644 index 0000000..e9ea4d0 --- /dev/null +++ b/ghc/compiler/nativeGen/AlphaDesc.lhs @@ -0,0 +1,206 @@ +% +% (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 + + PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult + + ) where + +import AbsCSyn +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..), + RegUsage(..), RegLiveness(..), FutureLive(..) + ) +import CLabelInfo ( CLabel ) +import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, + switchIsOn, SwitchResult(..) + ) +import HeapOffs ( hpRelToInt ) +import MachDesc +import Maybes ( Maybe(..) ) +import OrdList +import Outputable +import PrimKind ( PrimKind(..) ) +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import AlphaCode +import AlphaGen ( alphaCodeGen ) +import Stix +import StixMacro +import StixPrim +import SplitUniq +import Unique +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 PtrKind (sStLitLbl SLIT("StorageMgrInfo")) + HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+8")) + TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*8)]) + where + r2 = VanillaReg PtrKind ILIT(2) + 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 PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1) + where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm + +intLikeSize target = + size PtrKind * (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 + +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 + target = mkTarget switches fhs' vhs' alphaReg' id size vsaves' vrests' + hprel as as' csz isz mhs' dhs' ps mc hc + alphaCodeGen False mungeLabel + in target + +\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.hi b/ghc/compiler/nativeGen/AlphaGen.hi new file mode 100644 index 0000000..fb46055 --- /dev/null +++ b/ghc/compiler/nativeGen/AlphaGen.hi @@ -0,0 +1,18 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AlphaGen where +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +alphaCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/AlphaGen.lhs b/ghc/compiler/nativeGen/AlphaGen.lhs new file mode 100644 index 0000000..3eb5a04 --- /dev/null +++ b/ghc/compiler/nativeGen/AlphaGen.lhs @@ -0,0 +1,1120 @@ +% +% (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 AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( runRegAllocate, extractMappedRegNos, mkReg, + Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..), + MachineRegisters(..), MachineCode(..) + ) +import CLabelInfo ( CLabel, isAsmTemp ) +import AlphaCode {- everything -} +import MachDesc +import Maybes ( maybeToBool, Maybe(..) ) +import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) +import Outputable +import PrimKind ( PrimKind(..), isFloatingKind ) +import AlphaDesc +import Stix +import SplitUniq +import Unique +import 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]] -> SUniqSM Unpretty +alphaCodeGen sty trees = + mapSUs genAlphaCode trees `thenSUs` \ dynamicCodes -> + let + staticCodes = scheduleAlphaCode dynamicCodes + pretty = printLabeledCodes sty staticCodes + in + returnSUs 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 PrimKind (CodeBlock AlphaInstr) + | Any PrimKind (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 -> PrimKind +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 -> SUniqSM (CodeBlock AlphaInstr) +returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs) + +returnInstrs :: [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr) +returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs) + +returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr) +returnSeq code instrs = returnSUs (\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] -> SUniqSM (AlphaCode) + +genAlphaCode trees = + mapSUs getCode trees `thenSUs` \ blocks -> + returnSUs (foldr (.) id blocks asmVoid) + +\end{code} + +Code extractor for an entire stix tree---stix statement level. + +\begin{code} + +getCode + :: StixTree -- a stix statement + -> SUniqSM (CodeBlock AlphaInstr) + +getCode (StSegment seg) = returnInstr (SEGMENT seg) + +getCode (StAssign pk dst src) + | isFloatingKind 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) = + mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) -> + returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) + (foldr1 (.) codes xs)) + where + getData :: StixTree -> SUniqSM (CodeBlock AlphaInstr, Imm) + getData (StInt i) = returnSUs (id, ImmInteger i) +#if __GLASGOW_HASKELL__ >= 23 +-- getData (StDouble d) = returnSUs (id, strImmLab (_showRational 30 d)) + getData (StDouble d) = returnSUs (id, ImmLab (prettyToUn (ppRational d))) +#else + getData (StDouble d) = returnSUs (id, strImmLab (show d)) +#endif + getData (StLitLbl s) = returnSUs (id, ImmLab s) + getData (StLitLit s) = returnSUs (id, strImmLab (cvtLitLit (_UNPK_ s))) + getData (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl) + getData (StCLbl l) = returnSUs (id, ImmCLbl l) + +getCode (StCall fn VoidKind args) = genCCall fn VoidKind args + +getCode (StComment s) = returnInstr (COMMENT s) + +\end{code} + +Generate code to get a subtree into a register. + +\begin{code} + +getReg :: StixTree -> SUniqSM Register + +getReg (StReg (StixMagicId stgreg)) = + case stgRegMap stgreg of + Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id) + -- cannae be Nothing + +getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id) + +getReg (StDouble d) = + getUniqLabelNCG `thenSUs` \ lbl -> + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, +#if __GLASGOW_HASKELL__ >= 23 +-- DATA TF [strImmLab (_showRational 30 d)], + DATA TF [ImmLab (prettyToUn (ppRational d))], +#else + DATA TF [strImmLab (show d)], +#endif + SEGMENT TextSegment, + LDA tmp (AddrImm (ImmCLbl lbl)), + LD TF dst (AddrReg tmp)] + in + returnSUs (Any DoubleKind code) + +getReg (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII True (_UNPK_ s), + SEGMENT TextSegment, + LDA dst (AddrImm (ImmCLbl lbl))] + in + returnSUs (Any PtrKind code) + +getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = + getUniqLabelNCG `thenSUs` \ lbl -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII False (init xs), + SEGMENT TextSegment, + LDA dst (AddrImm (ImmCLbl lbl))] + in + returnSUs (Any PtrKind code) + where + xs = _UNPK_ (_TAIL_ s) + +getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) + +getReg (StCall fn kind args) = + genCCall fn kind args `thenSUs` \ call -> + returnSUs (Fixed reg kind call) + where + reg = if isFloatingKind 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 + IntDivOp -> call SLIT("stg_div") IntKind + 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") DoubleKind + FloatLogOp -> call SLIT("log") DoubleKind + FloatSqrtOp -> call SLIT("sqrt") DoubleKind + + FloatSinOp -> call SLIT("sin") DoubleKind + FloatCosOp -> call SLIT("cos") DoubleKind + FloatTanOp -> call SLIT("tan") DoubleKind + + FloatAsinOp -> call SLIT("asin") DoubleKind + FloatAcosOp -> call SLIT("acos") DoubleKind + FloatAtanOp -> call SLIT("atan") DoubleKind + + FloatSinhOp -> call SLIT("sinh") DoubleKind + FloatCoshOp -> call SLIT("cosh") DoubleKind + FloatTanhOp -> call SLIT("tanh") DoubleKind + + FloatPowerOp -> call SLIT("pow") DoubleKind + + 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") DoubleKind + DoubleLogOp -> call SLIT("log") DoubleKind + DoubleSqrtOp -> call SLIT("sqrt") DoubleKind + + DoubleSinOp -> call SLIT("sin") DoubleKind + DoubleCosOp -> call SLIT("cos") DoubleKind + DoubleTanOp -> call SLIT("tan") DoubleKind + + DoubleAsinOp -> call SLIT("asin") DoubleKind + DoubleAcosOp -> call SLIT("acos") DoubleKind + DoubleAtanOp -> call SLIT("atan") DoubleKind + + DoubleSinhOp -> call SLIT("sinh") DoubleKind + DoubleCoshOp -> call SLIT("cosh") DoubleKind + DoubleTanhOp -> call SLIT("tanh") DoubleKind + + DoublePowerOp -> call SLIT("pow") DoubleKind + + OrdOp -> coerceIntCode IntKind args + 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 `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = kindToSize pk + code__2 dst = code . mkSeqInstr (LD size dst src) + in + returnSUs (Any pk code__2) + +getReg (StInt i) + | is8Bits i = + let + code dst = mkSeqInstr (OR zero (RIImm src) dst) + in + returnSUs (Any IntKind code) + | otherwise = + let + code dst = mkSeqInstr (LDI Q dst src) + in + returnSUs (Any IntKind code) + where + src = ImmInt (fromInteger i) + +getReg leaf + | maybeToBool imm = + let + code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) + in + returnSUs (Any PtrKind 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 -> SUniqSM Amode + +getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) + +getAmode (StPrim IntSubOp [x, StInt i]) = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnSUs (Amode (AddrRegImm reg off) code) + + +getAmode (StPrim IntAddOp [x, StInt i]) = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnSUs (Amode (AddrRegImm reg off) code) + +getAmode leaf + | maybeToBool imm = + returnSUs (Amode (AddrImm imm__2) id) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg other `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + in + returnSUs (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 + -> SUniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code + +-- We have to use up all of our argument registers first. + +getCallArg ((iDst,fDst):dsts, offset) arg = + getReg arg `thenSUs` \ register -> + let + reg = if isFloatingKind pk then fDst else iDst + code = registerCode register reg + src = registerName register reg + pk = registerKind register + in + returnSUs ( + if isFloatingKind pk then + ((dsts, offset), if isFixed register then + 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 `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerKind register + sz = kindToSize pk + in + returnSUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) + +\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 :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr) + +assignIntCode pk (StInd _ dst) src = + getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ 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 + returnSUs code__2 + +assignIntCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ 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 + returnSUs code__2 + +assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr) + +assignFltCode pk (StInd _ dst) src = + getNewRegNCG pk `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ 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 + returnSUs code__2 + +assignFltCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ 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 + returnSUs 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 + -> SUniqSM (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 `thenSUs` \ register -> + getNewRegNCG PtrKind `thenSUs` \ 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 + returnSUs (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 + -> SUniqSM (CodeBlock AlphaInstr) + +genCondJump lbl (StPrim op [x, StInt 0]) = + getReg x `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ 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 `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + code = registerCode register tmp + value = registerName register tmp + pk = registerKind register + target = ImmCLbl lbl + in + returnSUs (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 `thenSUs` \ register -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + result = registerName register tmp + target = ImmCLbl lbl + in + returnSUs (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 `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + result = registerName register tmp + target = ImmCLbl lbl + in + returnSUs (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 + -> PrimKind -- type of the result + -> [StixTree] -- arguments (of mixed type) + -> SUniqSM (CodeBlock AlphaInstr) + +genCCall fn kind args = + mapAccumLNCG getCallArg (argRegs,stackArgLoc) args + `thenSUs` \ ((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 [] = returnSUs (b, []) + mapAccumLNCG f b (x:xs) = + f b x `thenSUs` \ (b__2, x__2) -> + mapAccumLNCG f b__2 xs `thenSUs` \ (b__3, xs__2) -> + returnSUs (b__3, x__2:xs__2) + +\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] + -> SUniqSM Register + +trivialCode instr [x, StInt y] + | is8Bits y = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (fromInteger y) + code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) + in + returnSUs (Any IntKind code__2) + +trivialCode instr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Any IntKind code__2) + +trivialFCode + :: (Reg -> Reg -> Reg -> AlphaInstr) + -> [StixTree] + -> SUniqSM Register + +trivialFCode instr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG DoubleKind `thenSUs` \ tmp1 -> + getNewRegNCG DoubleKind `thenSUs` \ 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 + returnSUs (Any DoubleKind 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] + -> SUniqSM Register + +intNECode args = + trivialCode (CMP EQ) args `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) + in + returnSUs (Any IntKind code__2) + +cmpFCode + :: (Reg -> Reg -> Reg -> AlphaInstr) + -> Cond + -> [StixTree] + -> SUniqSM Register + +cmpFCode instr cond args = + trivialFCode instr args `thenSUs` \ register -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + getUniqLabelNCG `thenSUs` \ 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 + returnSUs (Any IntKind 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] + -> SUniqSM Register + +trivialUCode instr [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) + in + returnSUs (Any IntKind code__2) + +trivialUFCode + :: (Reg -> Reg -> AlphaInstr) + -> [StixTree] + -> SUniqSM Register + +trivialUFCode instr [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr src dst) + in + returnSUs (Any DoubleKind 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 :: PrimKind -> [StixTree] -> SUniqSM Register +coerceIntCode pk [x] = + getReg x `thenSUs` \ register -> + case register of + Fixed reg _ code -> returnSUs (Fixed reg pk code) + Any _ code -> returnSUs (Any pk code) + +coerceFltCode :: [StixTree] -> SUniqSM Register +coerceFltCode [x] = + getReg x `thenSUs` \ register -> + case register of + Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code) + Any _ code -> returnSUs (Any DoubleKind code) + +\end{code} + +Integer to character conversion. + +\begin{code} + +chrCode [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst) + in + returnSUs (Any IntKind code__2) + +\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] -> SUniqSM Register +coerceInt2FP [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Any DoubleKind code__2) + +coerceFP2Int :: [StixTree] -> SUniqSM Register +coerceFP2Int [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG DoubleKind `thenSUs` \ 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 + returnSUs (Any IntKind 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 :: PrimKind -> 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 + CharKind -> 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 :: PrimKind -> SUniqSM Reg +getNewRegNCG pk = + getSUnique `thenSUs` \ u -> + returnSUs (mkReg u pk) + +\end{code} diff --git a/ghc/compiler/nativeGen/AsmCodeGen.hi b/ghc/compiler/nativeGen/AsmCodeGen.hi new file mode 100644 index 0000000..9aedf3a --- /dev/null +++ b/ghc/compiler/nativeGen/AsmCodeGen.hi @@ -0,0 +1,24 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AsmCodeGen where +import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import ClosureInfo(ClosureInfo) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CostCentre(CostCentre) +import Maybes(Labda) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import SplitUniq(SUniqSM(..), SplitUniqSupply) +import Stdio(_FILE) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> [Char] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLU(ALL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 5 _U_ 21212 _N_ _S_ "SU(P)LU(ALL)L" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs new file mode 100644 index 0000000..bbb4cc9 --- /dev/null +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -0,0 +1,454 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" +#include "../../includes/platform.h" +#include "../../includes/GhcConstants.h" + +module AsmCodeGen ( +#ifdef __GLASGOW_HASKELL__ + writeRealAsm, +#endif + dumpRealAsm, + + -- And, I guess we need these... + AbstractC, GlobalSwitch, SwitchResult, + SplitUniqSupply, SUniqSM(..) + ) where + +import AbsCSyn ( AbstractC ) +import AbsCStixGen ( genCodeAbstractC ) +import AbsPrel ( PrimKind, 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_dec_osf1_TARGET +import AlphaDesc ( mkAlpha ) +#else +#if sparc_TARGET_ARCH +import SparcDesc ( mkSparc ) +#endif +#endif +import Stix +import SplitUniq +import Unique +import Unpretty +import Util +#if defined(__HBC__) +import + Word +#endif +\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. + +\begin{code} + +#ifdef __GLASGOW_HASKELL__ +# if __GLASGOW_HASKELL__ < 23 +# define _FILE _Addr +# endif +writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> PrimIO () + +writeRealAsm flags file absC uniq_supply + = uppAppendFile file 80 (runNCG (code flags absC) uniq_supply) + +#endif + +dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> String + +dumpRealAsm flags absC uniq_supply = uppShow 80 (runNCG (code flags absC) uniq_supply) + +runNCG m uniq_supply = m uniq_supply + +code flags absC = + genCodeAbstractC target absC `thenSUs` \ treelists -> + let + stix = map (map (genericOpt target)) treelists + in + codeGen target sty stix + where + sty = PprForAsm (switchIsOn flags) (underscore target) (fmtAsmLbl target) + + target = case stringSwitchSet flags AsmTarget of +#if ! OMIT_NATIVE_CODEGEN +#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 +#if alpha_TARGET_ARCH + Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags +#endif +#endif + _ -> error + ("ERROR:Trying to generate assembly language for an unsupported architecture\n"++ + "(or one for which this build is not configured).") + +\end{code} + +%************************************************************************ +%* * +\subsection[NCOpt]{The Generic Optimiser} +%* * +%************************************************************************ + +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. + +\begin{code} + +genericOpt + :: Target + -> StixTree + -> StixTree + +\end{code} + +For most nodes, just optimize the children. + +\begin{code} + +genericOpt target (StInd pk addr) = + StInd pk (genericOpt target addr) + +genericOpt target (StAssign pk dst src) = + StAssign pk (genericOpt target dst) (genericOpt target src) + +genericOpt target (StJump addr) = + StJump (genericOpt target addr) + +genericOpt target (StCondJump addr test) = + StCondJump addr (genericOpt target test) + +genericOpt target (StCall fn pk args) = + StCall fn pk (map (genericOpt target) args) + +\end{code} + +Fold indices together when the types match. + +\begin{code} + +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) + +\end{code} + +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) + +\end{code} + +Replace register leaves with appropriate StixTrees for the given target. +(Oh, so this is why we've been hauling the target around!) + +\begin{code} + +genericOpt target leaf@(StReg (StixMagicId id)) = + case stgReg target id of + Always tree -> genericOpt target tree + Save _ -> leaf + +genericOpt target other = other + +\end{code} + +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 + 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) + 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) + 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) + IntDivOp -> StInt (x `div` y) + IntRemOp -> StInt (x `rem` y) + 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) + 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. + +\begin{code} + +primOpt op [x@(StInt _), y] | commutableOp op = primOpt op [y, x] +--OLD: +--primOpt op [x@(StDouble _), y] | commutableOp op = primOpt op [y, x] + +\end{code} + +We can often do something with constants of 0 and 1 ... + +\begin{code} + +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 + IntDivOp -> x + IntQuotOp -> x + IntRemOp -> StInt 0 + _ -> StPrim op args + +-- The following code tweaks a bug in early versions of GHC (pre-0.21) + +{- OLD: (death to constant folding in ncg) +primOpt op args@[x, y@(StDouble 0.0)] = + case op of + FloatAddOp -> x + FloatSubOp -> x + FloatMulOp -> y + DoubleAddOp -> x + DoubleSubOp -> x + DoubleMulOp -> y + _ -> StPrim op args + +primOpt op args@[x, y@(StDouble 1.0)] = + case op of + FloatMulOp -> x + FloatDivOp -> x + DoubleMulOp -> x + DoubleDivOp -> x + _ -> StPrim op args + +primOpt op args@[x, y@(StDouble 2.0)] = + case op of + FloatMulOp -> StPrim FloatAddOp [x, x] + DoubleMulOp -> StPrim DoubleAddOp [x, x] + _ -> StPrim op args +-} + +\end{code} + +Now look for multiplication/division by powers of 2 (integers). + +\begin{code} + +primOpt op args@[x, y@(StInt n)] = + case op of + IntMulOp -> case exact_log2 n of + Nothing -> StPrim op args + Just p -> StPrim SllOp [x, StInt p] + IntQuotOp -> case exact_log2 n of + Nothing -> StPrim op args + Just p -> StPrim SraOp [x, StInt p] + _ -> StPrim op args + +\end{code} + +Anything else is just too hard. + +\begin{code} + +primOpt op args = StPrim op args + +\end{code} + +The commutable ops are those for which we will try to move constants to the +right hand side for strength reduction. + +\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} + +#ifdef __GLASGOW_HASKELL__ + +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#)) + +# if __GLASGOW_HASKELL__ >= 23 + shiftr x y = shiftRA# x y +# else + shiftr x y = shiftR# x y +# endif + +#else {-probably HBC-} + +exact_log2 :: Integer -> Maybe Integer +exact_log2 x + | x <= 0 || x >= 2147483648 = Nothing + | otherwise = + if x' `bitAnd` (-x') /= x' then Nothing + else Just (toInteger (pow2 x')) + + where x' = ((fromInteger x) :: Word) + pow2 x | x == bit0 = 0 :: Int + | otherwise = 1 + pow2 (x `bitRsh` 1) + +#endif {-probably HBC-} + +\end{code} diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.hi b/ghc/compiler/nativeGen/AsmRegAlloc.hi new file mode 100644 index 0000000..2c1bed2 --- /dev/null +++ b/ghc/compiler/nativeGen/AsmRegAlloc.hi @@ -0,0 +1,94 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AsmRegAlloc where +import CLabelInfo(CLabel) +import FiniteMap(FiniteMap) +import OrdList(OrdList) +import Outputable(NamedThing) +import PrimKind(PrimKind) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +class MachineCode a where + regUsage :: a -> RegUsage + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> RegUsage) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> RegUsage) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.regUsage\"", u2 ] _N_ #-} + regLiveness :: a -> RegLiveness -> RegLiveness + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(ASAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> RegLiveness -> RegLiveness) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) (u3 :: RegLiveness) -> _APP_ _TYAPP_ patError# { (u0 -> RegLiveness -> RegLiveness) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.regLiveness\"", u2, u3 ] _N_ #-} + patchRegs :: a -> (Reg -> Reg) -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> (Reg -> Reg) -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) (u3 :: Reg -> Reg) -> _APP_ _TYAPP_ patError# { (u0 -> (Reg -> Reg) -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.patchRegs\"", u2, u3 ] _N_ #-} + spillReg :: Reg -> Reg -> OrdList a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: Reg -> Reg -> OrdList u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: Reg) (u3 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Reg -> OrdList u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.spillReg\"", u2, u3 ] _N_ #-} + loadReg :: Reg -> Reg -> OrdList a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAAS)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: Reg -> Reg -> OrdList u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: Reg) (u3 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Reg -> OrdList u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.loadReg\"", u2, u3 ] _N_ #-} +class MachineRegisters a where + mkMRegs :: [Int] -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: [Int]) -> _APP_ _TYAPP_ patError# { ([Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.mkMRegs\"", u2 ] _N_ #-} + possibleMRegs :: PrimKind -> a -> [Int] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(ASAAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PrimKind -> u0 -> [Int]) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: PrimKind) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (PrimKind -> u0 -> [Int]) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.possibleMRegs\"", u2, u3 ] _N_ #-} + useMReg :: a -> Int# -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Int# -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: Int#) -> _APP_ _TYAPP_ patError# { (u0 -> Int# -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.useMReg\"", u2, u3 ] _N_ #-} + useMRegs :: a -> [Int] -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAASAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: [Int]) -> _APP_ _TYAPP_ patError# { (u0 -> [Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.useMRegs\"", u2, u3 ] _N_ #-} + freeMReg :: a -> Int# -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Int# -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: Int#) -> _APP_ _TYAPP_ patError# { (u0 -> Int# -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.freeMReg\"", u2, u3 ] _N_ #-} + freeMRegs :: a -> [Int] -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: [Int]) -> _APP_ _TYAPP_ patError# { (u0 -> [Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.freeMRegs\"", u2, u3 ] _N_ #-} +data CLabel +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data FutureLive = FL (UniqFM Reg) (FiniteMap CLabel (UniqFM Reg)) +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data Reg = FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind +data RegLiveness = RL (UniqFM Reg) FutureLive +data RegUsage = RU (UniqFM Reg) (UniqFM Reg) +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +extractMappedRegNos :: [Reg] -> [Int] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkReg :: Unique -> PrimKind -> Reg + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: PrimKind) -> _!_ _ORIG_ AsmRegAlloc UnmappedReg [] [u0, u1] _N_ #-} +runRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b] + {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLS" _N_ _SPECIALISE_ [ AlphaRegs, AlphaInstr ] 2 { _A_ 0 _U_ 221 _N_ _N_ _N_ _N_ } #-} +instance Eq Reg + {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Reg -> Reg -> Bool), (Reg -> Reg -> Bool)] [_CONSTM_ Eq (==) (Reg), _CONSTM_ Eq (/=) (Reg)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Reg + {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Reg}}, (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Reg), (Reg -> Reg -> Reg), (Reg -> Reg -> _CMP_TAG)] [_DFUN_ Eq (Reg), _CONSTM_ Ord (<) (Reg), _CONSTM_ Ord (<=) (Reg), _CONSTM_ Ord (>=) (Reg), _CONSTM_ Ord (>) (Reg), _CONSTM_ Ord max (Reg), _CONSTM_ Ord min (Reg), _CONSTM_ Ord _tagCmp (Reg)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance NamedThing Reg + {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Reg -> ExportFlag), (Reg -> Bool), (Reg -> (_PackedString, _PackedString)), (Reg -> _PackedString), (Reg -> [_PackedString]), (Reg -> SrcLoc), (Reg -> Unique), (Reg -> Bool), (Reg -> UniType), (Reg -> Bool)] [_CONSTM_ NamedThing getExportFlag (Reg), _CONSTM_ NamedThing isLocallyDefined (Reg), _CONSTM_ NamedThing getOrigName (Reg), _CONSTM_ NamedThing getOccurrenceName (Reg), _CONSTM_ NamedThing getInformingModules (Reg), _CONSTM_ NamedThing getSrcLoc (Reg), _CONSTM_ NamedThing getTheUnique (Reg), _CONSTM_ NamedThing hasType (Reg), _CONSTM_ NamedThing getType (Reg), _CONSTM_ NamedThing fromPreludeCore (Reg)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-} +instance Text Reg + {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Reg, [Char])]), (Int -> Reg -> [Char] -> [Char]), ([Char] -> [([Reg], [Char])]), ([Reg] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Reg), _CONSTM_ Text showsPrec (Reg), _CONSTM_ Text readList (Reg), _CONSTM_ Text showList (Reg)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Reg, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 2 _U_ 012 _N_ _S_ "AS" {_A_ 1 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs new file mode 100644 index 0000000..9d11e22 --- /dev/null +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -0,0 +1,498 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" +#include "../../includes/platform.h" +#include "../../includes/GhcConstants.h" + +module AsmRegAlloc ( + FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..), + MachineRegisters(..), MachineCode(..), + + mkReg, runRegAllocate, + extractMappedRegNos, + + -- And, for self-sufficiency + CLabel, OrdList, PrimKind, UniqSet(..), UniqFM, + FiniteMap, Unique + ) where + +IMPORT_Trace + +import CLabelInfo ( CLabel ) +import FiniteMap +import MachDesc +import Maybes ( maybeToBool, Maybe(..) ) +import OrdList -- ( mkUnitList, mkSeqList, mkParList, OrdList ) +import Outputable +import Pretty +import PrimKind ( PrimKind(..) ) +import UniqSet +import Unique +import Util + +#if ! OMIT_NATIVE_CODEGEN + +#if sparc_TARGET_ARCH +import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing + +{-# SPECIALIZE + runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr] + #-} +#endif +#if alpha_TARGET_ARCH +import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing + +{-# SPECIALIZE + runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr] + #-} +#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 PrimKind -- A machine "register" actually held in a memory + -- allocated table of registers which didn't fit + -- in real registers. + + | UnmappedReg Unique PrimKind -- One of an infinite supply of registers, + -- always mapped to one of the earlier two + -- before we're done. + -- No thanks: deriving (Eq) + +mkReg :: Unique -> PrimKind -> 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' _) = cmpUnique 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 } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif + +instance NamedThing Reg where + -- the *only* method that should be defined is "getTheUnique"! + -- (so we can use UniqFMs/UniqSets on Regs + getTheUnique (UnmappedReg u _) = u + getTheUnique (FixedReg i) = mkPseudoUnique1 IBOX(i) + getTheUnique (MappedReg i) = mkPseudoUnique2 IBOX(i) + getTheUnique (MemoryReg i _) = mkPseudoUnique3 i +\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 :: PrimKind -> 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 +-- OLD: +-- flatten :: OrdList a -> [a] + regUsage :: a -> RegUsage + regLiveness :: a -> RegLiveness -> RegLiveness + patchRegs :: a -> (Reg -> Reg) -> a + spillReg :: Reg -> Reg -> OrdList a + loadReg :: Reg -> Reg -> OrdList a + +\end{code} + +First we try something extremely simple. +If that fails, we have to do things the hard way. + +\begin{code} + +runRegAllocate + :: (MachineRegisters a, MachineCode b) + => a + -> [Int] + -> (OrdList b) + -> [b] + +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 + +\end{code} + +Here is the simple register allocator. Just dole out registers until +we run out, or until one gets clobbered before its last use. Don't +do anything fancy with branches. Just pretend that you've got a block +of straight-line code and hope for the best. Experience indicates that +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 + -> [Reg] -- live static registers + -> RegAssignment -- mapping of dynamics to statics + -> [b] -- code + -> Maybe [b] + +simpleRegAlloc _ _ _ [] = Just [] +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) } + + lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x} + + deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live] + newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env] + + newAlloc = foldr allocateNewReg (Just (free, [])) newDsts + (free2, new) = case newAlloc of Just x -> x + + env2 = env `addListToFM` new + + live2 = map snd new ++ [x | x <- live, x `not_elem` dsts] + + instrs2 = simpleRegAlloc free2 live2 env2 instrs + instrs3 = case instrs2 of Just x -> x + + allocateNewReg + :: MachineRegisters a + => Reg + -> Maybe (a, [(Reg, Reg)]) + -> Maybe (a, [(Reg, Reg)]) + + allocateNewReg _ Nothing = Nothing + + allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) = + if null choices then Nothing + else Just (free2, prs2) + where + choices = possibleMRegs pk free + 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 +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) + (RH regs' 1 emptyFM) noFuture instrs + of (RH _ loc' _, _, instrs') -> + if loc' == 1 then instrs' else + case mapAccumB do_RegAlloc_Nil + (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem 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 + +do_RegAlloc_Nil = doRegAlloc [] -- out here to avoid CAF (sigh) +do_RegAlloc_Nil + :: (MachineRegisters a, MachineCode b) + => RegHistory a + -> RegFuture + -> b + -> (RegHistory a, RegFuture, b) + +noFuture :: RegFuture +noFuture = RF emptyUniqSet (FL emptyUniqSet emptyFM) emptyFM +\end{code} + +Here we patch instructions that reference ``registers'' which are really in +memory somewhere (the mapping is under the control of the machine-specific +code generator). We place the appropriate load sequences before any instructions +that use memory registers as sources, and we place the appropriate spill sequences +after any instructions that use memory registers as destinations. The offending +instructions are rewritten with new dynamic registers, so we have to run register +allocation again after all of this is said and done. + +\begin{code} + +patchMem + :: MachineCode a + => [a] + -> OrdList a + +patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs + +patchMem' + :: MachineCode a + => a + -> OrdList a + +patchMem' instr = + if null memSrcs && null memDsts then mkUnitList instr + else mkSeqList + (foldr mkParList mkEmptyList loadSrcs) + (mkSeqList instr' + (foldr mkParList mkEmptyList spillDsts)) + + where + (RU srcs dsts) = regUsage instr + + memToDyn (MemoryReg i pk) = UnmappedReg (mkBuiltinUnique i) pk + memToDyn other = other + + memSrcs = [ r | r@(MemoryReg _ _) <- uniqSetToList srcs] + memDsts = [ r | r@(MemoryReg _ _) <- uniqSetToList dsts] + + loadSrcs = map load memSrcs + spillDsts = map spill memDsts + + load mem = loadReg mem (memToDyn mem) + spill mem = spillReg (memToDyn mem) mem + + instr' = mkUnitList (patchRegs instr memToDyn) + +\end{code} + +\begin{code} + +doRegAlloc + :: (MachineRegisters a, MachineCode b) + => [Int] + -> RegHistory a + -> RegFuture + -> b + -> (RegHistory a, RegFuture, b) + +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) + +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 + reg_conflicts' = case new_conflicts of + [] -> reg_conflicts + _ -> addListToFM reg_conflicts new_conflicts + new_conflicts = if isEmptyUniqSet live_dynamics then [] + else [ (r, merge_conflicts r) + | r <- extractMappedRegNos (uniqSetToList 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 ] + +doRegAlloc' + :: (MachineRegisters a, MachineCode b) + => [Int] + -> RegHistory a + -> RegInfo b + -> b + -> (RegHistory a, b) + +doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) instr = + + (RH frs'' loc' env'', patchRegs instr dynToStatic) + + where + + -- free up new registers + free :: [Int] + 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' = (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 ] + + (frs'', loc', new) = foldr allocateNewRegs (frs', loc, []) new_dynamix + + env' = addListToFM env new + + env'' = delListFromFM env' lastu + + dynToStatic :: Reg -> Reg + dynToStatic dyn@(UnmappedReg _ _) = + case lookupFM env' dyn of + Just r -> r + Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn + dynToStatic other = other + + allocateNewRegs + :: MachineRegisters a + => Reg -> (a, Int, [(Reg, Reg)]) -> (a, Int, [(Reg, Reg)]) + + allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst) + where (fs', f, mem') = case acceptable fs of + [] -> (fs, MemoryReg mem pk, mem + 1) + (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem) + + 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 +\end{code} + +We keep a local copy of the Prelude function \tr{notElem}, +so that it can be specialised. (Hack me gently. [WDP 94/11]) +\begin{code} +not_elem x [] = True +not_elem x (y:ys) = x /= y && not_elem x ys +\end{code} diff --git a/ghc/compiler/nativeGen/Jmakefile b/ghc/compiler/nativeGen/Jmakefile new file mode 100644 index 0000000..d98775c --- /dev/null +++ b/ghc/compiler/nativeGen/Jmakefile @@ -0,0 +1,22 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) +HaskellSuffixRules() + +LitSuffixRule(.lit,/*none*/) /* no language really */ +LitSuffixRule(.lhs,.hs) /* Haskell */ +LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */ +LitSuffixRule(.lprl,.prl) /* Perl */ +LitSuffixRule(.lsh,.sh) /* Bourne shell */ +LitSuffixRule(.lc,.c) /* C */ +LitSuffixRule(.lh,.h) +LitSuffixRule(.llex,.lex) /* Lex */ +LitSuffixRule(.lflex,.flex) /* Flex */ + + + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTarget(root,lit) diff --git a/ghc/compiler/nativeGen/MachDesc.hi b/ghc/compiler/nativeGen/MachDesc.hi new file mode 100644 index 0000000..674a649 --- /dev/null +++ b/ghc/compiler/nativeGen/MachDesc.hi @@ -0,0 +1,95 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface MachDesc where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import ClosureInfo(ClosureInfo) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Maybes(Labda) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SplitUniq(SUniqSM(..), SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree, StixTreeList(..)) +import UniType(UniType) +import Unique(Unique) +import Unpretty(Unpretty(..)) +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-} +data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data CLabel +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data RegLoc = Save StixTree | Always StixTree +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data HeapOffset +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +type StixTreeList = [StixTree] -> [StixTree] +data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +type Unpretty = CSeq +amodeToStix :: Target -> CAddrMode -> StixTree + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAASAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CAddrMode -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ua; _NO_DEFLT_ } _N_ #-} +amodeToStix' :: Target -> CAddrMode -> StixTree + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAASAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CAddrMode -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ub; _NO_DEFLT_ } _N_ #-} +charLikeClosureSize :: Target -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAU(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uc; _NO_DEFLT_ } _N_ #-} +codeGen :: Target -> PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "U(AAAAAAAAAAAAAAAAAASAA)" {_A_ 1 _U_ 1222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uj; _NO_DEFLT_ } _N_ #-} +dataHS :: Target -> StixTree + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uf; _NO_DEFLT_ } _N_ #-} +fixedHeaderSize :: Target -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)AAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u2; _NO_DEFLT_ } _N_ #-} +fmtAsmLbl :: Target -> [Char] -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAAAAAAAAAAAAS)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [Char] -> [Char]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ul; _NO_DEFLT_ } _N_ #-} +heapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 1 _U_ 122222 _N_ _S_ "U(AAAAAAAAAAAAAAAAASAAA)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ui; _NO_DEFLT_ } _N_ #-} +hpRel :: Target -> HeapOffset -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAASAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: HeapOffset -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u9; _NO_DEFLT_ } _N_ #-} +intLikeClosureSize :: Target -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAU(P)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ud; _NO_DEFLT_ } _N_ #-} +macroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 1 _U_ 12222 _N_ _S_ "U(AAAAAAAAAAAAAAAASAAAA)" {_A_ 1 _U_ 12222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uh; _NO_DEFLT_ } _N_ #-} +mkTarget :: (GlobalSwitch -> SwitchResult) -> Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (StixTree -> StixTree) -> (PrimKind -> Int) -> ([MagicId] -> [StixTree]) -> ([MagicId] -> [StixTree]) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> Int -> Int -> StixTree -> StixTree -> ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) -> Bool -> ([Char] -> [Char]) -> Target + {-# GHC_PRAGMA _A_ 21 _U_ 222222222222222222222 _N_ _N_ _F_ _IF_ARGS_ 0 21 XXXXXXXXXXXXXXXXXXXXX 22 \ (u0 :: GlobalSwitch -> SwitchResult) (u1 :: Int) (u2 :: SMRep -> Int) (u3 :: MagicId -> RegLoc) (u4 :: StixTree -> StixTree) (u5 :: PrimKind -> Int) (u6 :: [MagicId] -> [StixTree]) (u7 :: [MagicId] -> [StixTree]) (u8 :: HeapOffset -> Int) (u9 :: CAddrMode -> StixTree) (ua :: CAddrMode -> StixTree) (ub :: Int) (uc :: Int) (ud :: StixTree) (ue :: StixTree) (uf :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ug :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uj :: Bool) (uk :: [Char] -> [Char]) -> _!_ _ORIG_ MachDesc Target [] [u0, u1, u2, u3, u4, u5, u6, u7, u8, u9, ua, ub, uc, ud, ue, uf, ug, uh, ui, uj, uk] _N_ #-} +mutHS :: Target -> StixTree + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAASAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ue; _NO_DEFLT_ } _N_ #-} +nativeOpt :: Target -> StixTree -> StixTree + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAASAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u5; _NO_DEFLT_ } _N_ #-} +primToStix :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 1 _U_ 122222 _N_ _S_ "U(AAAAAAAAAAAAAAASAAAAA)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ug; _NO_DEFLT_ } _N_ #-} +saveLoc :: Target -> MagicId -> StixTree + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASAAAAAAAAAAAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +sizeof :: Target -> PrimKind -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAASAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: PrimKind -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u6; _NO_DEFLT_ } _N_ #-} +stgReg :: Target -> MagicId -> RegLoc + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAASAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: MagicId -> RegLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u4; _NO_DEFLT_ } _N_ #-} +targetSwitches :: Target -> GlobalSwitch -> SwitchResult + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: GlobalSwitch -> SwitchResult) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u1; _NO_DEFLT_ } _N_ #-} +underscore :: Target -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAAAAAAAAEA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Bool) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uk; _NO_DEFLT_ } _N_ #-} +varHeaderSize :: Target -> SMRep -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AASAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SMRep -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u3; _NO_DEFLT_ } _N_ #-} +volatileRestores :: Target -> [MagicId] -> [StixTree] + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAASAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [MagicId] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u8; _NO_DEFLT_ } _N_ #-} +volatileSaves :: Target -> [MagicId] -> [StixTree] + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAASAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [MagicId] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u7; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/nativeGen/MachDesc.lhs b/ghc/compiler/nativeGen/MachDesc.lhs new file mode 100644 index 0000000..79b1965 --- /dev/null +++ b/ghc/compiler/nativeGen/MachDesc.lhs @@ -0,0 +1,113 @@ +% +% (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, mkTarget, RegLoc(..), + + saveLoc, + + targetSwitches, fixedHeaderSize, varHeaderSize, stgReg, + nativeOpt, sizeof, volatileSaves, volatileRestores, hpRel, + amodeToStix, amodeToStix', charLikeClosureSize, + intLikeClosureSize, mutHS, dataHS, primToStix, macroCode, + heapCheck, codeGen, underscore, fmtAsmLbl, + + -- and, for self-sufficiency... + AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, + RegRelative, CSeq, BasicLit, CLabel, GlobalSwitch, + SwitchResult, HeapOffset, PrimOp, PprStyle, + PrimKind, SMRep, StixTree, Unique, SplitUniqSupply, + StixTreeList(..), SUniqSM(..), Unpretty(..) + ) where + +import AbsCSyn +import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) +import Outputable +import OrdList ( OrdList ) +import PrimKind ( PrimKind ) +import SMRep ( SMRep ) +import Stix +import SplitUniq +import 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 + (GlobalSwitch -> SwitchResult) -- switches + Int -- fixedHeaderSize + (SMRep -> Int) -- varHeaderSize + (MagicId -> RegLoc) -- stgReg + (StixTree -> StixTree) -- nativeOpt + (PrimKind -> Int) -- sizeof + ([MagicId] -> [StixTree]) -- volatileSaves + ([MagicId] -> [StixTree]) -- volatileRestores + (HeapOffset -> Int) -- hpRel + (CAddrMode -> StixTree) -- amodeToStix + (CAddrMode -> StixTree) -- amodeToStix' + Int -- charLikeClosureSize + Int -- intLikeClosureSize + StixTree -- mutHS + StixTree -- dataHS + ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList) + -- primToStix + (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList) + -- macroCode + (StixTree -> StixTree -> StixTree -> SUniqSM StixTreeList) + -- heapCheck + + (PprStyle -> [[StixTree]] -> SUniqSM Unpretty) + -- codeGen + + Bool -- underscore + (String -> String) -- fmtAsmLbl + +mkTarget = Target + +targetSwitches (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = sw +fixedHeaderSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = fhs +varHeaderSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vhs +stgReg (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = reg +nativeOpt (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = opt +sizeof (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = size +volatileSaves (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vsave +volatileRestores (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vrest +hpRel (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = hprel +amodeToStix (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = am +amodeToStix' (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = am' +charLikeClosureSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = csz +intLikeClosureSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = isz +mutHS (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = mhs +dataHS (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = dhs +primToStix (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = ps +macroCode (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = mc +heapCheck (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = hc +codeGen (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = cg +underscore (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = us +fmtAsmLbl (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = fmt +\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/SparcCode.hi b/ghc/compiler/nativeGen/SparcCode.hi new file mode 100644 index 0000000..45e2629 --- /dev/null +++ b/ghc/compiler/nativeGen/SparcCode.hi @@ -0,0 +1,85 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SparcCode where +import AbsCSyn(MagicId) +import AsmRegAlloc(MachineCode, MachineRegisters, Reg) +import BitSet(BitSet) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import FiniteMap(FiniteMap) +import Maybes(Labda) +import OrdList(OrdList) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import Stix(CodeSegment) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data Addr = AddrRegReg Reg Reg | AddrRegImm Reg Imm +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-} +data BitSet {-# GHC_PRAGMA MkBS Word# #-} +data CLabel +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-} +data Cond = ALWAYS | NEVER | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS | VC | VS +data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq | LO Imm | HI Imm +data RI = RIReg Reg | RIImm Imm +data Size = SB | HW | UB | UHW | W | D | F | DF +type SparcCode = OrdList SparcInstr +data SparcInstr = LD Size Addr Reg | ST Size Reg Addr | ADD Bool Bool Reg RI Reg | SUB Bool Bool Reg RI Reg | AND Bool Reg RI Reg | ANDN Bool Reg RI Reg | OR Bool Reg RI Reg | ORN Bool Reg RI Reg | XOR Bool Reg RI Reg | XNOR Bool Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | SETHI Imm Reg | NOP | FABS Size Reg Reg | FADD Size Reg Reg Reg | FCMP Bool Size Reg Reg | FDIV Size Reg Reg Reg | FMOV Size Reg Reg | FMUL Size Reg Reg Reg | FNEG Size Reg Reg | FSQRT Size Reg Reg | FSUB Size Reg Reg Reg | FxTOy Size Size Reg Reg | BI Cond Bool Imm | BF Cond Bool Imm | JMP Addr | CALL Imm Int Bool | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm] +data SparcRegs {-# GHC_PRAGMA SRegs BitSet BitSet BitSet #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +argRegs :: [Reg] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +baseRegOffset :: MagicId -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +callerSaves :: MagicId -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +f0 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +fp :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [30#] _N_ #-} +freeRegs :: [Reg] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +g0 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-} +is13Bits :: Integral a => a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +kindToSize :: PrimKind -> Size + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +o0 :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +offset :: Addr -> Int -> Labda Addr + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +printLabeledCodes :: PprStyle -> [SparcInstr] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +reservedRegs :: [Int] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +sp :: Reg + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [14#] _N_ #-} +stgRegMap :: MagicId -> Labda Reg + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +strImmLit :: [Char] -> Imm + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance MachineCode SparcInstr + {-# GHC_PRAGMA _M_ SparcCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(SparcInstr -> RegUsage), (SparcInstr -> RegLiveness -> RegLiveness), (SparcInstr -> (Reg -> Reg) -> SparcInstr), (Reg -> Reg -> OrdList SparcInstr), (Reg -> Reg -> OrdList SparcInstr)] [_CONSTM_ MachineCode regUsage (SparcInstr), _CONSTM_ MachineCode regLiveness (SparcInstr), _CONSTM_ MachineCode patchRegs (SparcInstr), _CONSTM_ MachineCode spillReg (SparcInstr), _CONSTM_ MachineCode loadReg (SparcInstr)] _N_ + regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_, + patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_, + spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_, + loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instance MachineRegisters SparcRegs + {-# GHC_PRAGMA _M_ SparcCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> SparcRegs), (PrimKind -> SparcRegs -> [Int]), (SparcRegs -> Int# -> SparcRegs), (SparcRegs -> [Int] -> SparcRegs), (SparcRegs -> Int# -> SparcRegs), (SparcRegs -> [Int] -> SparcRegs)] [_CONSTM_ MachineRegisters mkMRegs (SparcRegs), _CONSTM_ MachineRegisters possibleMRegs (SparcRegs), _CONSTM_ MachineRegisters useMReg (SparcRegs), _CONSTM_ MachineRegisters useMRegs (SparcRegs), _CONSTM_ MachineRegisters freeMReg (SparcRegs), _CONSTM_ MachineRegisters freeMRegs (SparcRegs)] _N_ + mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_, + possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LLL)" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_, + useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LLL)P" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_, + useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LLL)L" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_, + freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LLL)P" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_, + freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LLL)L" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/SparcCode.lhs b/ghc/compiler/nativeGen/SparcCode.lhs new file mode 100644 index 0000000..1c3862e --- /dev/null +++ b/ghc/compiler/nativeGen/SparcCode.lhs @@ -0,0 +1,1398 @@ +% +% (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, --UNUSED: strImmLab, + + printLabeledCodes, + + baseRegOffset, stgRegMap, callerSaves, + + is13Bits, offset, + + kindToSize, + + g0, o0, f0, fp, sp, argRegs, + + freeRegs, reservedRegs, + + -- and, for self-sufficiency ... + CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..), + UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet + ) where + +IMPORT_Trace + +import AbsCSyn ( MagicId(..) ) +import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..), + Reg(..), RegUsage(..), RegLiveness(..) + ) +import BitSet +import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG ) +import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC ) +import FiniteMap +import Maybes ( Maybe(..), maybeToBool ) +import OrdList ( OrdList, mkUnitList, flattenOrdList ) +import Outputable +import PrimKind ( PrimKind(..) ) +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 () + +--UNUSED:strImmLab s = ImmLab (uppStr s) +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 < 0 = + uppBesides [ + pprReg r1, + uppChar '-', + uppInt (-i) + ] + +pprAddr sty (AddrRegImm r1 (ImmInteger i)) + | i == 0 = pprReg r1 + | i < 0 = + uppBesides [ + pprReg r1, + uppChar '-', + uppInteger (-i) + ] + +pprAddr sty (AddrRegImm r1 imm) = + uppBesides [ + pprReg r1, + uppChar '+', + pprImm sty imm + ] + +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 PrimKind 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 FloatKind (SRegs _ singles _) = [ x + 32 | x <- listBS singles] + possibleMRegs DoubleKind (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 + -- Alas, we don't do anything clever with our OrdLists +--OLD: +-- flatten = flattenOrdList + + 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 :: PrimKind -> Size +kindToSize PtrKind = W +kindToSize CodePtrKind = W +kindToSize DataPtrKind = W +kindToSize RetKind = W +kindToSize InfoPtrKind = W +kindToSize CostCentreKind = W +kindToSize CharKind = UB +kindToSize IntKind = W +kindToSize WordKind = W +kindToSize AddrKind = W +kindToSize FloatKind = F +kindToSize DoubleKind = DF +kindToSize ArrayKind = W +kindToSize ByteArrayKind = W +kindToSize StablePtrKind = W +kindToSize MallocPtrKind = W + +\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} + +#ifdef __GLASGOW_HASKELL__ + +{-# SPECIALIZE + is13Bits :: Int -> Bool + #-} +{-# SPECIALIZE + is13Bits :: Integer -> Bool + #-} + +#endif + +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.hi b/ghc/compiler/nativeGen/SparcDesc.hi new file mode 100644 index 0000000..ae4c32d --- /dev/null +++ b/ghc/compiler/nativeGen/SparcDesc.hi @@ -0,0 +1,24 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SparcDesc where +import AbsCSyn(MagicId) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import MachDesc(RegLoc, Target) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import Stix(CodeSegment, StixReg, StixTree) +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> Target + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/SparcDesc.lhs b/ghc/compiler/nativeGen/SparcDesc.lhs new file mode 100644 index 0000000..91f2d9e --- /dev/null +++ b/ghc/compiler/nativeGen/SparcDesc.lhs @@ -0,0 +1,199 @@ +% +% (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 + + PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult + + ) where + +import AbsCSyn +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..), + RegLiveness(..), RegUsage(..), FutureLive(..) + ) +import CLabelInfo ( CLabel ) +import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) ) +import HeapOffs ( hpRelToInt ) +import MachDesc +import Maybes ( Maybe(..) ) +import OrdList +import Outputable +import PrimKind ( PrimKind(..) ) +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import SparcCode +import SparcGen ( sparcCodeGen ) +import Stix +import StixMacro +import StixPrim +import SplitUniq +import Unique +import 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 PtrKind (sStLitLbl SLIT("StorageMgrInfo")) + HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4")) + TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)]) + where + r2 = VanillaReg PtrKind ILIT(2) + 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 PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1) + where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm + +intLikeSize target = + size PtrKind * (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 + +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 + target = mkTarget switches fhs' vhs' sparcReg' id size vsaves' vrests' + hprel as as' csz isz mhs' dhs' ps mc hc + sparcCodeGen decentOS id + in target + +\end{code} + + + diff --git a/ghc/compiler/nativeGen/SparcGen.hi b/ghc/compiler/nativeGen/SparcGen.hi new file mode 100644 index 0000000..f4bc7f0 --- /dev/null +++ b/ghc/compiler/nativeGen/SparcGen.hi @@ -0,0 +1,18 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SparcGen where +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +sparcCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/SparcGen.lhs b/ghc/compiler/nativeGen/SparcGen.lhs new file mode 100644 index 0000000..f5bc3a0 --- /dev/null +++ b/ghc/compiler/nativeGen/SparcGen.lhs @@ -0,0 +1,1304 @@ +% +% (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 AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos, + Reg(..), RegLiveness(..), RegUsage(..), + FutureLive(..), MachineRegisters(..), MachineCode(..) + ) +import CLabelInfo ( CLabel, isAsmTemp ) +import SparcCode {- everything -} +import MachDesc +import Maybes ( maybeToBool, Maybe(..) ) +import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) +import Outputable +import PrimKind ( PrimKind(..), isFloatingKind ) +import SparcDesc +import Stix +import SplitUniq +import Unique +import 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]] -> SUniqSM Unpretty +sparcCodeGen sty trees = + mapSUs genSparcCode trees `thenSUs` \ dynamicCodes -> + let + staticCodes = scheduleSparcCode dynamicCodes + pretty = printLabeledCodes sty staticCodes + in + returnSUs 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 PrimKind (CodeBlock SparcInstr) + | Any PrimKind (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 -> PrimKind +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 -> SUniqSM (CodeBlock SparcInstr) +returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs) + +returnInstrs :: [SparcInstr] -> SUniqSM (CodeBlock SparcInstr) +returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs) + +returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> SUniqSM (CodeBlock SparcInstr) +returnSeq code instrs = returnSUs (\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] -> SUniqSM (SparcCode) + +genSparcCode trees = + mapSUs getCode trees `thenSUs` \ blocks -> + returnSUs (foldr (.) id blocks asmVoid) + +\end{code} + +Code extractor for an entire stix tree---stix statement level. + +\begin{code} + +getCode + :: StixTree -- a stix statement + -> SUniqSM (CodeBlock SparcInstr) + +getCode (StSegment seg) = returnInstr (SEGMENT seg) + +getCode (StAssign pk dst src) + | isFloatingKind pk = assignFltCode pk dst src + | otherwise = assignIntCode pk dst src + +getCode (StLabel lab) = returnInstr (LABEL lab) + +getCode (StFunBegin lab) = returnInstr (LABEL lab) + +getCode (StFunEnd lab) = returnSUs id + +getCode (StJump arg) = genJump arg + +getCode (StFallThrough lbl) = returnSUs id + +getCode (StCondJump lbl arg) = genCondJump lbl arg + +getCode (StData kind args) = + mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) -> + returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) + (foldr1 (.) codes xs)) + where + getData :: StixTree -> SUniqSM (CodeBlock SparcInstr, Imm) + getData (StInt i) = returnSUs (id, ImmInteger i) +#if __GLASGOW_HASKELL__ >= 23 +-- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : _showRational 30 d)) + -- yurgh (WDP 94/12) + getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d))) +#else + getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : show d)) +#endif + getData (StLitLbl s) = returnSUs (id, ImmLab s) + getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s))) + getData (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl) + getData (StCLbl l) = returnSUs (id, ImmCLbl l) + +getCode (StCall fn VoidKind args) = genCCall fn VoidKind args + +getCode (StComment s) = returnInstr (COMMENT s) + +\end{code} + +Generate code to get a subtree into a register. + +\begin{code} + +getReg :: StixTree -> SUniqSM Register + +getReg (StReg (StixMagicId stgreg)) = + case stgRegMap stgreg of + Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id) + -- cannae be Nothing + +getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id) + +getReg (StDouble d) = + getUniqLabelNCG `thenSUs` \ lbl -> + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, +#if __GLASGOW_HASKELL__ >= 23 +-- DATA DF [strImmLit ('0' : 'r' : (_showRational 30 d))], + DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))], +#else + DATA DF [strImmLit ('0' : 'r' : (show d))], +#endif + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) tmp, + LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + in + returnSUs (Any DoubleKind code) + +getReg (StString s) = + getUniqLabelNCG `thenSUs` \ 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 + returnSUs (Any PtrKind code) + +getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = + getUniqLabelNCG `thenSUs` \ 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 + returnSUs (Any PtrKind code) + where + xs = _UNPK_ (_TAIL_ s) + +getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) + +getReg (StCall fn kind args) = + genCCall fn kind args `thenSUs` \ call -> + returnSUs (Fixed reg kind call) + where + reg = if isFloatingKind 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") IntKind + IntQuotOp -> call SLIT(".div") IntKind + IntDivOp -> call SLIT("stg_div") IntKind + IntRemOp -> call SLIT(".rem") IntKind + 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 FloatKind FADD args + FloatSubOp -> trivialFCode FloatKind FSUB args + FloatMulOp -> trivialFCode FloatKind FMUL args + FloatDivOp -> trivialFCode FloatKind FDIV args + FloatNegOp -> trivialUFCode FloatKind (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") DoubleKind + FloatLogOp -> promoteAndCall SLIT("log") DoubleKind + FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleKind + + FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind + FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind + FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind + + FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind + FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind + FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind + + FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind + FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind + FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind + + FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind + + DoubleAddOp -> trivialFCode DoubleKind FADD args + DoubleSubOp -> trivialFCode DoubleKind FSUB args + DoubleMulOp -> trivialFCode DoubleKind FMUL args + DoubleDivOp -> trivialFCode DoubleKind FDIV args + DoubleNegOp -> trivialUFCode DoubleKind (FNEG DF) args + + 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") DoubleKind + DoubleLogOp -> call SLIT("log") DoubleKind + DoubleSqrtOp -> call SLIT("sqrt") DoubleKind + + DoubleSinOp -> call SLIT("sin") DoubleKind + DoubleCosOp -> call SLIT("cos") DoubleKind + DoubleTanOp -> call SLIT("tan") DoubleKind + + DoubleAsinOp -> call SLIT("asin") DoubleKind + DoubleAcosOp -> call SLIT("acos") DoubleKind + DoubleAtanOp -> call SLIT("atan") DoubleKind + + DoubleSinhOp -> call SLIT("sinh") DoubleKind + DoubleCoshOp -> call SLIT("cosh") DoubleKind + DoubleTanhOp -> call SLIT("tanh") DoubleKind + + DoublePowerOp -> call SLIT("pow") DoubleKind + + OrdOp -> coerceIntCode IntKind args + ChrOp -> chrCode args + + Float2IntOp -> coerceFP2Int args + Int2FloatOp -> coerceInt2FP FloatKind args + Double2IntOp -> coerceFP2Int args + Int2DoubleOp -> coerceInt2FP DoubleKind args + + Double2FloatOp -> trivialUFCode FloatKind (FxTOy DF F) args + Float2DoubleOp -> trivialUFCode DoubleKind (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 `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = kindToSize pk + code__2 dst = code . mkSeqInstr (LD size src dst) + in + returnSUs (Any pk code__2) + +getReg (StInt i) + | is13Bits i = + let + src = ImmInt (fromInteger i) + code dst = mkSeqInstr (OR False g0 (RIImm src) dst) + in + returnSUs (Any IntKind code) + +getReg leaf + | maybeToBool imm = + let + code dst = mkSeqInstrs [ + SETHI (HI imm__2) dst, + OR False dst (RIImm (LO imm__2)) dst] + in + returnSUs (Any PtrKind 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 -> SUniqSM Amode + +getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) + +getAmode (StPrim IntSubOp [x, StInt i]) + | is13Bits (-i) = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnSUs (Amode (AddrRegImm reg off) code) + + +getAmode (StPrim IntAddOp [x, StInt i]) + | is13Bits i = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnSUs (Amode (AddrRegImm reg off) code) + +getAmode (StPrim IntAddOp [x, y]) = + getNewRegNCG PtrKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + 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 + returnSUs (Amode (AddrRegReg reg1 reg2) code__2) + +getAmode leaf + | maybeToBool imm = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let + code = mkSeqInstr (SETHI (HI imm__2) tmp) + in + returnSUs (Amode (AddrRegImm tmp (LO imm__2)) code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg other `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt 0 + in + returnSUs (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 + -> SUniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code + +-- We have to use up all of our argument registers first. + +getCallArg (dst:dsts, offset) arg = + getReg arg `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + reg = if isFloatingKind pk then tmp else dst + code = registerCode register reg + src = registerName register reg + pk = registerKind register + in + returnSUs (case pk of + DoubleKind -> + 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]) + FloatKind -> ((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 `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerKind register + sz = kindToSize pk + words = if pk == DoubleKind then 2 else 1 + in + returnSUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) + +\end{code} + +Set up a condition code for a conditional branch. + +\begin{code} + +getCondition :: StixTree -> SUniqSM 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] -> SUniqSM Condition + +condIntCode cond [x, StInt y] + | is13Bits y = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Condition False cond code__2) + +condIntCode cond [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + 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 + returnSUs (Condition False cond code__2) + +condFltCode cond [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG (registerKind register1) + `thenSUs` \ tmp1 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ tmp2 -> + getNewRegNCG DoubleKind `thenSUs` \ 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 == FloatKind 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 + returnSUs (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] -> SUniqSM Register + +condIntReg EQ [x, StInt 0] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstrs [ + SUB False True g0 (RIReg src) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + in + returnSUs (Any IntKind code__2) + +condIntReg EQ [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Any IntKind code__2) + +condIntReg NE [x, StInt 0] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstrs [ + SUB False True g0 (RIReg src) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + in + returnSUs (Any IntKind code__2) + +condIntReg NE [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Any IntKind code__2) + +condIntReg cond args = + getUniqLabelNCG `thenSUs` \ lbl1 -> + getUniqLabelNCG `thenSUs` \ lbl2 -> + condIntCode cond args `thenSUs` \ 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 + returnSUs (Any IntKind code__2) + +condFltReg :: Cond -> [StixTree] -> SUniqSM Register + +condFltReg cond args = + getUniqLabelNCG `thenSUs` \ lbl1 -> + getUniqLabelNCG `thenSUs` \ lbl2 -> + condFltCode cond args `thenSUs` \ 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 + returnSUs (Any IntKind 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 :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr) + +assignIntCode pk (StInd _ dst) src = + getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ 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 + returnSUs code__2 + +assignIntCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ 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 + returnSUs code__2 + +assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr) + +assignFltCode pk (StInd _ dst) src = + getNewRegNCG pk `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ 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 + returnSUs code__2 + +assignFltCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ register2 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ 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 + returnSUs 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 + -> SUniqSM (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 `thenSUs` \ register -> + getNewRegNCG PtrKind `thenSUs` \ 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 + -> SUniqSM (CodeBlock SparcInstr) + +genCondJump lbl bool = + getCondition bool `thenSUs` \ 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 + -> PrimKind -- type of the result + -> [StixTree] -- arguments (of mixed type) + -> SUniqSM (CodeBlock SparcInstr) + +genCCall fn kind args = + mapAccumLNCG getCallArg (argRegs,stackArgLoc) args + `thenSUs` \ ((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 [] = returnSUs (b, []) + mapAccumLNCG f b (x:xs) = + f b x `thenSUs` \ (b__2, x__2) -> + mapAccumLNCG f b__2 xs `thenSUs` \ (b__3, xs__2) -> + returnSUs (b__3, x__2:xs__2) + +\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] + -> SUniqSM Register + +trivialCode instr [x, StInt y] + | is13Bits y = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (fromInteger y) + code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) + in + returnSUs (Any IntKind code__2) + +trivialCode instr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Any IntKind code__2) + +trivialFCode + :: PrimKind + -> (Size -> Reg -> Reg -> Reg -> SparcInstr) + -> [StixTree] + -> SUniqSM Register + +trivialFCode pk instr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG (registerKind register1) + `thenSUs` \ tmp1 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ tmp2 -> + getNewRegNCG DoubleKind `thenSUs` \ 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 == FloatKind then + asmParThen [code1 (promote src1), code2 asmVoid] . + mkSeqInstr (instr DF tmp src2 dst) + else + asmParThen [code1 asmVoid, code2 (promote src2)] . + mkSeqInstr (instr DF src1 tmp dst) + in + returnSUs (Any (if pk1 == pk2 then pk1 else DoubleKind) code__2) + +\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] + -> SUniqSM Register + +trivialUCode instr [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) + in + returnSUs (Any IntKind code__2) + +trivialUFCode + :: PrimKind + -> (Reg -> Reg -> SparcInstr) + -> [StixTree] + -> SUniqSM Register + +trivialUFCode pk instr [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG pk `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr src dst) + in + returnSUs (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] -> SUniqSM Register +absIntCode [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + getUniqLabelNCG `thenSUs` \ 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 + returnSUs (Any IntKind code__2) + +\end{code} + +Simple integer coercions that don't require any code to be generated. +Here we just change the type on the register passed on up + +\begin{code} + +coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register +coerceIntCode pk [x] = + getReg x `thenSUs` \ register -> + case register of + Fixed reg _ code -> returnSUs (Fixed reg pk code) + Any _ code -> returnSUs (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] -> SUniqSM Register +chrCode [StInd pk mem] = + getAmode mem `thenSUs` \ 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 + returnSUs (Any pk code__2) + +chrCode [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst) + in + returnSUs (Any IntKind code__2) + +\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 :: PrimKind -> [StixTree] -> SUniqSM Register +coerceInt2FP pk [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ 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 + returnSUs (Any pk code__2) + +coerceFP2Int :: [StixTree] -> SUniqSM Register +coerceFP2Int [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + getNewRegNCG FloatKind `thenSUs` \ 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 + returnSUs (Any IntKind 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 :: PrimKind -> 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 + CharKind -> StPrim IntAddOp [base, off] + _ -> StPrim IntAddOp [base, off__2] + where + off__2 = StPrim SllOp [off, StInt (shift pk)] + shift :: PrimKind -> Integer + shift DoubleKind = 3 + shift _ = 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 :: PrimKind -> SUniqSM Reg +getNewRegNCG pk = + getSUnique `thenSUs` \ u -> + returnSUs (mkReg u pk) + +\end{code} diff --git a/ghc/compiler/nativeGen/Stix.hi b/ghc/compiler/nativeGen/Stix.hi new file mode 100644 index 0000000..12f2211 --- /dev/null +++ b/ghc/compiler/nativeGen/Stix.hi @@ -0,0 +1,63 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Stix where +import AbsCSyn(MagicId) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SplitUniq(SUniqSM(..), SplitUniqSupply) +import UniType(UniType) +import Unique(Unique) +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data CLabel +data CodeSegment = DataSegment | TextSegment +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StixReg = StixMagicId MagicId | StixTemp Unique PrimKind +data StixTree = StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString +type StixTreeList = [StixTree] -> [StixTree] +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +getUniqLabelNCG :: SplitUniqSupply -> CLabel + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +sStLitLbl :: _PackedString -> StixTree + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +stgActivityReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgBaseReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgHp :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgHpLim :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgLivenessReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgNode :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgRetReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgSpA :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgSpB :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgStdUpdRetVecReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgStkOReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgStkStubReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgSuA :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgSuB :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgTagReg :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq CodeSegment + {-# GHC_PRAGMA _M_ Stix {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CodeSegment -> CodeSegment -> Bool), (CodeSegment -> CodeSegment -> Bool)] [_CONSTM_ Eq (==) (CodeSegment), _CONSTM_ Eq (/=) (CodeSegment)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs new file mode 100644 index 0000000..321e58d --- /dev/null +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -0,0 +1,175 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" + +module Stix ( + CodeSegment(..), StixReg(..), StixTree(..), StixTreeList(..), + sStLitLbl, + + stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, + stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, + stgActivityReg, stgStdUpdRetVecReg, stgStkStubReg, + getUniqLabelNCG, + + -- And for self-sufficiency, by golly... + MagicId, CLabel, PrimKind, PrimOp, Unique, + SplitUniqSupply, SUniqSM(..) + ) where + +import AbsCSyn ( MagicId(..), kindFromMagicId, node, infoptr ) +import AbsPrel ( showPrimOp, PrimOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import CLabelInfo ( CLabel, mkAsmTempLabel ) +import Outputable +import PrimKind ( PrimKind(..) ) +import SplitUniq +import Unique +import Unpretty +import Util +\end{code} + +Here is the tag at the nodes of our @StixTree@. Notice its +relationship with @PrimOp@ in prelude/PrimOps. + +\begin{code} + +data StixTree = + + -- Segment (text or data) + + StSegment CodeSegment + + -- We can tag the leaves with constants/immediates. + + | StInt Integer -- ** add Kind at some point +#if __GLASGOW_HASKELL__ <= 22 + | StDouble Double +#else + | StDouble Rational +#endif + | StString FAST_STRING + | StLitLbl Unpretty -- literal labels (will be _-prefixed on some machines) + | StLitLit FAST_STRING -- innards from CLitLit + | StCLbl CLabel -- labels that we might index into + + -- Abstract registers of various kinds + + | StReg StixReg + + -- A typed offset from a base location + + | StIndex PrimKind StixTree StixTree -- kind, base, offset + + -- An indirection from an address to its contents. + + | StInd PrimKind StixTree + + -- Assignment is typed to determine size and register placement + + | StAssign PrimKind StixTree StixTree -- dst, src + + -- A simple assembly label that we might jump to. + + | StLabel CLabel + + -- A function header and footer + + | StFunBegin CLabel + | StFunEnd CLabel + + -- An unconditional jump. This instruction is terminal. + -- Dynamic targets are allowed + + | StJump StixTree + + -- A fall-through, from slow to fast + + | StFallThrough CLabel + + -- A conditional jump. This instruction can be non-terminal :-) + -- Only static, local, forward labels are allowed + + | StCondJump CLabel StixTree + + -- Raw data (as in an info table). + + | StData PrimKind [StixTree] + + -- Primitive Operations + + | StPrim PrimOp [StixTree] + + -- Calls to C functions + + | StCall FAST_STRING PrimKind [StixTree] + + -- Comments, of course + + | StComment FAST_STRING -- For assembly comments + + deriving () + +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. + +\begin{code} + +data StixReg = StixMagicId MagicId -- Regs which are part of the abstract machine model + + | StixTemp Unique PrimKind -- "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). + +\begin{code} + +data CodeSegment = DataSegment | TextSegment deriving (Eq) + +type StixTreeList = [StixTree] -> [StixTree] + +\end{code} + +-- 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) + +getUniqLabelNCG :: SUniqSM CLabel +getUniqLabelNCG = + getSUnique `thenSUs` \ u -> + returnSUs (mkAsmTempLabel u) + +\end{code} diff --git a/ghc/compiler/nativeGen/StixInfo.hi b/ghc/compiler/nativeGen/StixInfo.hi new file mode 100644 index 0000000..3856c3d --- /dev/null +++ b/ghc/compiler/nativeGen/StixInfo.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StixInfo where +import AbsCSyn(AbstractC) +import MachDesc(Target) +import SplitUniq(SplitUniqSupply) +import Stix(StixTree) +genCodeInfoTable :: Target -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs new file mode 100644 index 0000000..9f1747f --- /dev/null +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -0,0 +1,142 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\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 SplitUniq +import Unique +import Unpretty +import Util + +\end{code} + +Generating code for info tables (arrays of data). + +\begin{code} +static___rtbl = sStLitLbl SLIT("Static___rtbl") -- out here to avoid CAF (sigh) +const___rtbl = sStLitLbl SLIT("Const___rtbl") +charlike___rtbl = sStLitLbl SLIT("CharLike___rtbl") +intlike___rtbl = sStLitLbl SLIT("IntLike___rtbl") +gen_N___rtbl = sStLitLbl SLIT("Gen_N___rtbl") +gen_S___rtbl = sStLitLbl SLIT("Gen_S___rtbl") +gen_U___rtbl = sStLitLbl SLIT("Gen_U___rtbl") +tuple___rtbl = sStLitLbl SLIT("Tuple___rtbl") +data___rtbl = sStLitLbl SLIT("Data___rtbl") +dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl") + +genCodeInfoTable + :: Target + -> AbstractC + -> SUniqSM StixTreeList + +genCodeInfoTable target (CClosureInfoAndCode cl_info _ _ upd cl_descr) = + returnSUs (\xs -> info : lbl : xs) + + where + info = StData PtrKind table + lbl = StLabel info_lbl + + table = case sm_rep of + StaticRep _ _ -> [ + StInt (toInteger ptrs), + StInt (toInteger size), + upd_code, + static___rtbl, + tag] + + SpecialisedRep ConstantRep _ _ _ -> [ + StCLbl closure_lbl, + upd_code, + const___rtbl, + tag] + + SpecialisedRep CharLikeRep _ _ _ -> [ + upd_code, + charlike___rtbl, + tag] + + SpecialisedRep IntLikeRep _ _ _ -> [ + upd_code, + intlike___rtbl, + tag] + + SpecialisedRep _ _ _ updatable -> + let rtbl = uppBesides ( + if is_selector then + [uppPStr SLIT("Select__"), + uppInt select_word, + uppPStr SLIT("_rtbl")] + else + [uppPStr (case updatable of + SMNormalForm -> SLIT("Spec_N_") + SMSingleEntry -> SLIT("Spec_S_") + SMUpdatable -> SLIT("Spec_U_") + ), + uppInt size, + uppChar '_', + uppInt ptrs, + uppPStr SLIT("_rtbl")]) + in + case updatable of + SMNormalForm -> [upd_code, StLitLbl rtbl, tag] + _ -> [StLitLbl rtbl, tag] + + GenericRep _ _ updatable -> + let rtbl = case updatable of + SMNormalForm -> gen_N___rtbl + SMSingleEntry -> gen_S___rtbl + SMUpdatable -> gen_U___rtbl + in [ + StInt (toInteger ptrs), + StInt (toInteger size), + upd_code, + rtbl, + tag] + + BigTupleRep _ -> [ + tuple___rtbl, + tag] + DataRep _ -> [ + data___rtbl, + tag] + DynamicRep -> [ + dyn___rtbl, + tag] + + PhantomRep -> [ + upd_code, + info_unused, -- no rep table + tag] + + info_lbl = infoTableLabelFromCI cl_info + closure_lbl = closureLabelFromCI cl_info + + sm_rep = closureSMRep cl_info + maybe_selector = maybeSelectorInfo cl_info + is_selector = maybeToBool maybe_selector + (Just (_, select_word)) = maybe_selector + + tag = StInt (toInteger (closureSemiTag cl_info)) + + size = if isSpecRep sm_rep + then closureNonHdrSize cl_info + else hpRel target (closureSizeWithoutFixedHdr cl_info) + ptrs = closurePtrsSize cl_info + + upd_code = amodeToStix target upd + + info_unused = StInt (-1) + +\end{code} diff --git a/ghc/compiler/nativeGen/StixInteger.hi b/ghc/compiler/nativeGen/StixInteger.hi new file mode 100644 index 0000000..9e83145 --- /dev/null +++ b/ghc/compiler/nativeGen/StixInteger.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StixInteger where +import AbsCSyn(CAddrMode) +import MachDesc(Target) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import SplitUniq(SplitUniqSupply) +import Stix(StixTree) +decodeFloatingKind :: PrimKind -> Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 4 _U_ 121102 _N_ _N_ _N_ _N_ #-} +encodeFloatingKind :: PrimKind -> Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 4 _U_ 121122 _N_ _S_ "LLSL" _N_ _N_ #-} +gmpCompare :: Target -> CAddrMode -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 3 _U_ 22102 _N_ _N_ _N_ _N_ #-} +gmpInt2Integer :: Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LLS" _N_ _N_ #-} +gmpInteger2Int :: Target -> CAddrMode -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 3 _U_ 22102 _N_ _N_ _N_ _N_ #-} +gmpString2Integer :: Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "U(ALLLAAAAALAAAALASAAAA)LS" _N_ _N_ #-} +gmpTake1Return1 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-} +gmpTake2Return1 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-} +gmpTake2Return2 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs new file mode 100644 index 0000000..1051d26 --- /dev/null +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -0,0 +1,376 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" + +module StixInteger ( + gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, + gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer, + encodeFloatingKind, decodeFloatingKind + ) where + +IMPORT_Trace -- ToDo: rm debugging + +import AbsCSyn +import CgCompInfo ( mIN_MP_INT_SIZE ) +import MachDesc +import Pretty +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) ) +import Stix +import SplitUniq +import Unique +import Util + +\end{code} + +\begin{code} + +gmpTake1Return1 + :: Target + -> [CAddrMode] -- result (3 parts) + -> FAST_STRING -- function name + -> [CAddrMode] -- argument (3 parts) + -> SUniqSM StixTreeList + +argument1 = mpStruct 1 -- out here to avoid CAF (sigh) +argument2 = mpStruct 2 +result2 = mpStruct 2 +result3 = mpStruct 3 +result4 = mpStruct 4 +init2 = StCall SLIT("mpz_init") VoidKind [result2] +init3 = StCall SLIT("mpz_init") VoidKind [result3] +init4 = StCall SLIT("mpz_init") VoidKind [result4] + +gmpTake1Return1 target res rtn arg = + let [ar,sr,dr] = map (amodeToStix target) res + [liveness, aa,sa,da] = map (amodeToStix target) arg + space = mpSpace target 2 1 [sa] + oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space]) + safeHp = saveLoc target Hp + save = StAssign PtrKind safeHp oldHp + (a1,a2,a3) = toStruct target argument1 (aa,sa,da) + mpz_op = StCall rtn VoidKind [result2, argument1] + restore = StAssign PtrKind stgHp safeHp + (r1,r2,r3) = fromStruct target result2 (ar,sr,dr) + in + heapCheck target liveness space (StInt 0) + `thenSUs` \ heap_chk -> + + returnSUs (heap_chk . + (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs)) + +gmpTake2Return1 + :: Target + -> [CAddrMode] -- result (3 parts) + -> FAST_STRING -- function name + -> [CAddrMode] -- arguments (3 parts each) + -> SUniqSM StixTreeList + +gmpTake2Return1 target res rtn args = + let [ar,sr,dr] = map (amodeToStix target) res + [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args + space = mpSpace target 3 1 [sa1, sa2] + oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space]) + safeHp = saveLoc target Hp + save = StAssign PtrKind safeHp oldHp + (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2) + mpz_op = StCall rtn VoidKind [result3, argument1, argument2] + restore = StAssign PtrKind stgHp safeHp + (r1,r2,r3) = fromStruct target result3 (ar,sr,dr) + in + heapCheck target liveness space (StInt 0) + `thenSUs` \ heap_chk -> + + returnSUs (heap_chk . + (\xs -> a1 : a2 : a3 : a4 : a5 : a6 + : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs)) + +gmpTake2Return2 + :: Target + -> [CAddrMode] -- results (3 parts each) + -> FAST_STRING -- function name + -> [CAddrMode] -- arguments (3 parts each) + -> SUniqSM StixTreeList + +gmpTake2Return2 target res rtn args = + let [ar1,sr1,dr1, ar2,sr2,dr2] = map (amodeToStix target) res + [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args + space = StPrim IntMulOp [mpSpace target 2 1 [sa1, sa2], StInt 2] + oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space]) + safeHp = saveLoc target Hp + save = StAssign PtrKind safeHp oldHp + (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2) + mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2] + restore = StAssign PtrKind stgHp safeHp + (r1,r2,r3) = fromStruct target result3 (ar1,sr1,dr1) + (r4,r5,r6) = fromStruct target result4 (ar2,sr2,dr2) + + in + heapCheck target liveness space (StInt 0) + `thenSUs` \ heap_chk -> + + returnSUs (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 some +space just beyond the heap pointer. This is safe, because the enclosing +routine has already guaranteed that this space will be available. +(See ``primOpHeapRequired.'') + +\begin{code} + +gmpCompare + :: Target + -> CAddrMode -- result (boolean) + -> [CAddrMode] -- arguments (3 parts each) + -> SUniqSM StixTreeList + +gmpCompare target res args = + let result = amodeToStix target res + [hp, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args + argument1 = hp + argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize)) + (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2) + mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2] + r1 = StAssign IntKind result mpz_cmp + in + returnSUs (\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] -- argument (3 parts) + -> SUniqSM StixTreeList + +gmpInteger2Int target res args = + let result = amodeToStix target res + [hp, aa,sa,da] = map (amodeToStix target) args + (a1,a2,a3) = toStruct target hp (aa,sa,da) + mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp] + r1 = StAssign IntKind result mpz_get_si + in + returnSUs (\xs -> a1 : a2 : a3 : r1 : xs) + +arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") + +gmpInt2Integer + :: Target + -> [CAddrMode] -- result (3 parts) + -> [CAddrMode] -- allocated heap, int to convert + -> SUniqSM StixTreeList + +gmpInt2Integer target res args@[_, n] = + getUniqLabelNCG `thenSUs` \ zlbl -> + getUniqLabelNCG `thenSUs` \ nlbl -> + getUniqLabelNCG `thenSUs` \ jlbl -> + let [ar,sr,dr] = map (amodeToStix target) res + [hp, i] = map (amodeToStix target) args + h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info + size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE + h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1))) + (StInt (toInteger size)) + cts = StInd IntKind (StIndex IntKind hp (dataHS target)) + test1 = StPrim IntEqOp [i, StInt 0] + test2 = StPrim IntLtOp [i, StInt 0] + cjmp1 = StCondJump zlbl test1 + cjmp2 = StCondJump nlbl test2 + -- positive + p1 = StAssign IntKind cts i + p2 = StAssign IntKind sr (StInt 1) + p3 = StJump (StCLbl jlbl) + -- negative + n0 = StLabel nlbl + n1 = StAssign IntKind cts (StPrim IntNegOp [i]) + n2 = StAssign IntKind sr (StInt (-1)) + n3 = StJump (StCLbl jlbl) + -- zero + z0 = StLabel zlbl + z1 = StAssign IntKind sr (StInt 0) + -- everybody + a0 = StLabel jlbl + a1 = StAssign IntKind ar (StInt 1) + a2 = StAssign PtrKind dr hp + in + returnSUs (\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] -- result (3 parts) + -> [CAddrMode] -- liveness, string + -> SUniqSM StixTreeList + +gmpString2Integer target res [liveness, str] = + getUniqLabelNCG `thenSUs` \ ulbl -> + let [ar,sr,dr] = map (amodeToStix target) res + 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 + oldHp = StIndex PtrKind stgHp (StInt (toInteger (-space))) + safeHp = saveLoc target Hp + save = StAssign PtrKind safeHp oldHp + result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize))) + set_str = StCall SLIT("mpz_init_set_str") IntKind + [result, amodeToStix target str, StInt 10] + test = StPrim IntEqOp [set_str, StInt 0] + cjmp = StCondJump ulbl test + abort = StCall SLIT("abort") VoidKind [] + join = StLabel ulbl + restore = StAssign PtrKind stgHp safeHp + (a1,a2,a3) = fromStruct target result (ar,sr,dr) + in + macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] + `thenSUs` \ heap_chk -> + + returnSUs (heap_chk . + (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs)) + +mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) + +encodeFloatingKind + :: PrimKind + -> Target + -> [CAddrMode] -- result + -> [CAddrMode] -- heap pointer for result, integer argument (3 parts), exponent + -> SUniqSM StixTreeList + +encodeFloatingKind pk target [res] args = + let result = amodeToStix target res + [hp, aa,sa,da, expon] = map (amodeToStix target) args + pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind + else pk + (a1,a2,a3) = toStruct target hp (aa,sa,da) + fn = case pk' of + FloatKind -> SLIT("__encodeFloat") + DoubleKind -> SLIT("__encodeDouble") + _ -> panic "encodeFloatingKind" + encode = StCall fn pk' [hp, expon] + r1 = StAssign pk' result encode + in + returnSUs (\xs -> a1 : a2 : a3 : r1 : xs) + +decodeFloatingKind + :: PrimKind + -> Target + -> [CAddrMode] -- exponent result, integer result (3 parts) + -> [CAddrMode] -- heap pointer for exponent, floating argument + -> SUniqSM StixTreeList + +decodeFloatingKind pk target res args = + let [exponr,ar,sr,dr] = map (amodeToStix target) res + [hp, arg] = map (amodeToStix target) args + pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind + else pk + setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1)) + fn = case pk' of + FloatKind -> SLIT("__decodeFloat") + DoubleKind -> SLIT("__decodeDouble") + _ -> panic "decodeFloatingKind" + decode = StCall fn VoidKind [mantissa, hp, arg] + (a1,a2,a3) = fromStruct target mantissa (ar,sr,dr) + a4 = StAssign IntKind exponr (StInd IntKind hp) + in + returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs) + +mantissa = mpStruct 1 -- out here to avoid CAF (sigh) +mpData_mantissa = mpData mantissa +\end{code} + +Support for the Gnu GMP multi-precision package. + +\begin{code} + +mpIntSize = 3 :: Int + +mpAlloc, mpSize, mpData :: StixTree -> StixTree +mpAlloc base = StInd IntKind base +mpSize base = StInd IntKind (StIndex IntKind base (StInt 1)) +mpData base = StInd PtrKind (StIndex IntKind base (StInt 2)) + +mpSpace + :: Target + -> Int -- gmp structures needed + -> Int -- number of results + -> [StixTree] -- sizes to add for estimating result size + -> StixTree -- total space + +mpSpace target 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 [dataHS target, 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. + +\begin{code} + +mpStruct :: Int -> StixTree +mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize)))) + +toStruct + :: Target + -> StixTree + -> (StixTree, StixTree, StixTree) + -> (StixTree, StixTree, StixTree) + +toStruct target str (alloc,size,arr) = + let + f1 = StAssign IntKind (mpAlloc str) alloc + f2 = StAssign IntKind (mpSize str) size + f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr (dataHS target)) + in + (f1, f2, f3) + +fromStruct + :: Target + -> StixTree + -> (StixTree, StixTree, StixTree) + -> (StixTree, StixTree, StixTree) + +fromStruct target str (alloc,size,arr) = + let + e1 = StAssign IntKind alloc (mpAlloc str) + e2 = StAssign IntKind size (mpSize str) + e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str) + (StPrim IntNegOp [dataHS target])) + in + (e1, e2, e3) + + +\end{code} + diff --git a/ghc/compiler/nativeGen/StixMacro.hi b/ghc/compiler/nativeGen/StixMacro.hi new file mode 100644 index 0000000..aa0f0ce --- /dev/null +++ b/ghc/compiler/nativeGen/StixMacro.hi @@ -0,0 +1,32 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StixMacro where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import MachDesc(RegLoc, Target) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep) +import SplitUniq(SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +import Unique(Unique) +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-} +data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-} +data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +doHeapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 5 _U_ 022012 _N_ _S_ "ALLAU(ALA)" {_A_ 3 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +genMacroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LEL" _N_ _N_ #-} +smStablePtrTable :: StixTree + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs new file mode 100644 index 0000000..d49158b --- /dev/null +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -0,0 +1,381 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" + +module StixMacro ( + genMacroCode, doHeapCheck, smStablePtrTable, + + Target, StixTree, SplitUniqSupply, CAddrMode, CExprMacro, + CStmtMacro + ) where + +import AbsCSyn +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import MachDesc {- lots -} +import CgCompInfo ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE ) +import Stix +import SplitUniq +import Unique +import Util + +\end{code} + +The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on +the A stack, and perform a tail call to @UpdatePAP@ if the arguments are +not there. The @_LOAD_NODE@ version also loads R1 with an appropriate +closure address. + +\begin{code} +mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) +mkIntCLit_3 = mkIntCLit 3 + +genMacroCode + :: Target + -> CStmtMacro -- statement macro + -> [CAddrMode] -- args + -> SUniqSM StixTreeList + +genMacroCode target ARGS_CHK_A_LOAD_NODE args = + getUniqLabelNCG `thenSUs` \ ulbl -> + let [words, lbl] = map (amodeToStix target) args + temp = StIndex PtrKind stgSpA words + test = StPrim AddrGeOp [stgSuA, temp] + cjmp = StCondJump ulbl test + assign = StAssign PtrKind stgNode lbl + join = StLabel ulbl + in + returnSUs (\xs -> cjmp : assign : updatePAP : join : xs) + +genMacroCode target ARGS_CHK_A [words] = + getUniqLabelNCG `thenSUs` \ ulbl -> + let temp = StIndex PtrKind stgSpA (amodeToStix target words) + test = StPrim AddrGeOp [stgSuA, temp] + cjmp = StCondJump ulbl test + join = StLabel ulbl + in + returnSUs (\xs -> cjmp : updatePAP : join : xs) + +\end{code} + +Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for +sufficient arguments on the B stack, and perform a tail call to +@UpdatePAP@ if the arguments are not there. The @_LOAD_NODE@ version +also loads R1 with an appropriate closure address. Note that the +directions are swapped relative to the A stack. + +\begin{code} + +genMacroCode target ARGS_CHK_B_LOAD_NODE args = + getUniqLabelNCG `thenSUs` \ ulbl -> + let [words, lbl] = map (amodeToStix target) args + temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words]) + test = StPrim AddrGeOp [stgSpB, temp] + cjmp = StCondJump ulbl test + assign = StAssign PtrKind stgNode lbl + join = StLabel ulbl + in + returnSUs (\xs -> cjmp : assign : updatePAP : join : xs) + +genMacroCode target ARGS_CHK_B [words] = + getUniqLabelNCG `thenSUs` \ ulbl -> + let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [amodeToStix target words]) + test = StPrim AddrGeOp [stgSpB, temp] + cjmp = StCondJump ulbl test + join = StLabel ulbl + in + returnSUs (\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. + +Since there are @HEAP_CHK@s buried at unfortunate places in the integer +primOps, this is just a wrapper. + +\begin{code} + +genMacroCode target HEAP_CHK args = + let [liveness,words,reenter] = map (amodeToStix target) args + in + doHeapCheck target liveness words reenter + +\end{code} + +The @STK_CHK@ macro checks for enough space on the stack between @SpA@ +and @SpB@. A stack check can be complicated in the parallel world, +but for the sequential case, we just need to ensure that we have +enough space to continue. Not that @_StackOverflow@ doesn't return, +so we don't have to @callWrapper@ it. + +\begin{code} + +genMacroCode target STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] = +{- Need to check to see if we are compiling with stack checks + getUniqLabelNCG `thenSUs` \ ulbl -> + let words = StPrim IntNegOp + [StPrim IntAddOp [amodeToStix target aWords, amodeToStix target bWords]] + temp = StIndex PtrKind stgSpA words + test = StPrim AddrGtOp [temp, stgSpB] + cjmp = StCondJump ulbl test + join = StLabel ulbl + in + returnSUs (\xs -> cjmp : stackOverflow : join : xs) +-} + returnSUs 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. + +\begin{code} + +genMacroCode target UPD_CAF args = + let [cafptr,bhptr] = map (amodeToStix target) args + w0 = StInd PtrKind cafptr + w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1)) + w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2)) + a1 = StAssign PtrKind w0 caf_info + a2 = StAssign PtrKind w1 smCAFlist + a3 = StAssign PtrKind w2 bhptr + a4 = StAssign PtrKind smCAFlist cafptr + in + returnSUs (\xs -> a1 : a2 : a3 : a4 : xs) + +\end{code} + +@UPD_IND@ 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. + +\begin{code} + +genMacroCode target UPD_IND args = + getUniqLabelNCG `thenSUs` \ ulbl -> + let [updptr, heapptr] = map (amodeToStix target) args + test = StPrim AddrGtOp [updptr, smOldLim] + cjmp = StCondJump ulbl test + updRoots = StAssign PtrKind smOldMutables updptr + join = StLabel ulbl + upd0 = StAssign PtrKind (StInd PtrKind updptr) ind_info + upd1 = StAssign PtrKind (StInd PtrKind + (StIndex PtrKind updptr (StInt 1))) smOldMutables + upd2 = StAssign PtrKind (StInd PtrKind + (StIndex PtrKind updptr (StInt 2))) heapptr + in + returnSUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs) + +\end{code} + +@UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling. + +\begin{code} + +genMacroCode target UPD_INPLACE_NOPTRS args = returnSUs 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. + +\begin{code} + +genMacroCode target UPD_INPLACE_PTRS [liveness] = + getUniqLabelNCG `thenSUs` \ ulbl -> + let cjmp = StCondJump ulbl testOldLim + testOldLim = StPrim AddrGtOp [stgNode, smOldLim] + join = StLabel ulbl + updUpd0 = StAssign PtrKind (StInd PtrKind stgNode) ind_info + updUpd1 = StAssign PtrKind (StInd PtrKind + (StIndex PtrKind stgNode (StInt 1))) smOldMutables + updUpd2 = StAssign PtrKind (StInd PtrKind + (StIndex PtrKind stgNode (StInt 2))) hpBack2 + hpBack2 = StIndex PtrKind stgHp (StInt (-2)) + updOldMutables = StAssign PtrKind smOldMutables stgNode + updUpdReg = StAssign PtrKind stgNode hpBack2 + in + genMacroCode target HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0] + `thenSUs` \ heap_chk -> + returnSUs (\xs -> (cjmp : + heap_chk (updUpd0 : updUpd1 : updUpd2 : + updOldMutables : updUpdReg : join : xs))) + +\end{code} + +@UPD_BH_UPDATABLE@ is only used when running concurrent threads (in +the sequential case, the GC takes care of this). However, we do need +to handle @UPD_BH_SINGLE_ENTRY@ in all cases. + +\begin{code} + +genMacroCode target UPD_BH_UPDATABLE args = returnSUs id + +genMacroCode target UPD_BH_SINGLE_ENTRY [arg] = + let + update = StAssign PtrKind (StInd PtrKind (amodeToStix target arg)) bh_info + in + returnSUs (\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} + +genMacroCode target PUSH_STD_UPD_FRAME args = + let [bhptr, aWords, bWords] = map (amodeToStix target) args + frame n = StInd PtrKind + (StIndex PtrKind stgSpB (StPrim IntAddOp + [bWords, StInt (toInteger (sTD_UF_SIZE - n))])) + + a1 = StAssign PtrKind (frame uF_RET) stgRetReg + a2 = StAssign PtrKind (frame uF_SUB) stgSuB + a3 = StAssign PtrKind (frame uF_SUA) stgSuA + a4 = StAssign PtrKind (frame uF_UPDATEE) bhptr + + updSuB = StAssign PtrKind + stgSuB (StIndex PtrKind stgSpB (StPrim IntAddOp + [bWords, StInt (toInteger sTD_UF_SIZE)])) + updSuA = StAssign PtrKind + stgSuA (StIndex PtrKind stgSpA (StPrim IntNegOp [aWords])) + in + returnSUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs) + +\end{code} + +Pop a standard update frame. + +\begin{code} + +genMacroCode target POP_STD_UPD_FRAME args = + let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n)))) + + grabRet = StAssign PtrKind stgRetReg (frame uF_RET) + grabSuB = StAssign PtrKind stgSuB (frame uF_SUB) + grabSuA = StAssign PtrKind stgSuA (frame uF_SUA) + + updSpB = StAssign PtrKind + stgSpB (StIndex PtrKind stgSpB (StInt (toInteger (-sTD_UF_SIZE)))) + in + returnSUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs) + +\end{code} + +@PUSH_CON_UPD_FRAME@ appears to be unused at the moment. + +\begin{code} +{- UNUSED: +genMacroCode target PUSH_CON_UPD_FRAME args = + panic "genMacroCode:PUSH_CON_UPD_FRAME" +-} +\end{code} + +The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation. + +\begin{code} + +genMacroCode target SET_ARITY args = returnSUs id +genMacroCode target CHK_ARITY args = returnSUs id + +\end{code} + +This one only applies if we have a machine register devoted to TagReg. + +\begin{code} + +genMacroCode target SET_TAG [tag] = + let set_tag = StAssign IntKind stgTagReg (amodeToStix target tag) + in + case stgReg target TagReg of + Always _ -> returnSUs id + Save _ -> returnSUs (\xs -> set_tag : xs) + +\end{code} + +Do the business for a @HEAP_CHK@, having converted the args to Trees +of StixOp. + +\begin{code} + +doHeapCheck + :: Target + -> StixTree -- liveness + -> StixTree -- words needed + -> StixTree -- always reenter node? (boolean) + -> SUniqSM StixTreeList + +doHeapCheck target liveness words reenter = + getUniqLabelNCG `thenSUs` \ ulbl -> + let newHp = StIndex PtrKind stgHp words + assign = StAssign PtrKind stgHp newHp + test = StPrim AddrLeOp [stgHp, stgHpLim] + cjmp = StCondJump ulbl test + arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness] + -- ToDo: Overflow? (JSM) + gc = StCall SLIT("PerformGC_wrapper") VoidKind [arg] + join = StLabel ulbl + in + returnSUs (\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 + +bh_info = sStLitLbl SLIT("BH_SINGLE_info") +caf_info = sStLitLbl SLIT("Caf_info") +ind_info = sStLitLbl SLIT("Ind_info") + +-- Some common call trees + +updatePAP, stackOverflow :: StixTree + +updatePAP = StJump (sStLitLbl SLIT("UpdatePAP")) +stackOverflow = StCall SLIT("StackOverflow") VoidKind [] + +\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 PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_CAFLIST)) +smOldMutables = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDMUTABLES)) +smOldLim = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDLIM)) + +smStablePtrTable = StInd PtrKind + (StIndex PtrKind storageMgrInfo (StInt SM_STABLEPOINTERTABLE)) + +\end{code} diff --git a/ghc/compiler/nativeGen/StixPrim.hi b/ghc/compiler/nativeGen/StixPrim.hi new file mode 100644 index 0000000..2f54eb0 --- /dev/null +++ b/ghc/compiler/nativeGen/StixPrim.hi @@ -0,0 +1,33 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StixPrim where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative) +import BasicLit(BasicLit) +import CLabelInfo(CLabel) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import MachDesc(RegLoc, Target) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PprStyle) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SMRep(SMRep) +import SplitUniq(SplitUniqSupply) +import Stix(CodeSegment, StixReg, StixTree) +import UniType(UniType) +import Unique(Unique) +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-} +amodeCode :: Target -> CAddrMode -> StixTree + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +amodeCode' :: Target -> CAddrMode -> StixTree + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +genPrimCode :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree] + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LSSL" _N_ _N_ #-} + diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs new file mode 100644 index 0000000..977d9ef --- /dev/null +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -0,0 +1,599 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" + +module StixPrim ( + genPrimCode, amodeCode, amodeCode', + + Target, CAddrMode, StixTree, PrimOp, SplitUniqSupply + ) where + +IMPORT_Trace -- ToDo: rm debugging + +import AbsCSyn +import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), TyCon, + getPrimOpResultInfo, isCompareOp, showPrimOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( cmpTyCon ) -- pragmas only +import CgCompInfo ( spARelToInt, spBRelToInt ) +import MachDesc +import Pretty +import PrimKind ( isFloatingKind ) +import CostCentre +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import Stix +import StixMacro ( smStablePtrTable ) +import StixInteger {- everything -} +import SplitUniq +import Unique +import Unpretty +import Util + +\end{code} + +The main honcho here is genPrimCode, 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 + -> PrimOp -- op + -> [CAddrMode] -- args + -> SUniqSM 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. + +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} + +genPrimCode target lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs + | is_asm = error "ERROR: Native code generator can't handle casm" + | otherwise = + case lhs of + [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs) + [lhs] -> + let lhs' = amodeToStix target lhs + pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind + call = StAssign pk lhs' (StCall fn pk args) + in + returnSUs (\xs -> call : xs) + where + args = map amodeCodeForCCall rhs + amodeCodeForCCall x = + let base = amodeToStix' target x + in + case getAmodeKind x of + ArrayKind -> StIndex PtrKind base (mutHS target) + ByteArrayKind -> StIndex IntKind base (dataHS target) + MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!" + _ -> base + +\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@. + +\begin{code} + +genPrimCode target [] ErrorIOPrimOp [rhs] = + let changeTop = StAssign PtrKind topClosure (amodeToStix target rhs) + in + returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs) + +\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. + +\begin{code} + +genPrimCode target res IntegerAddOp args = + gmpTake2Return1 target res SLIT("mpz_add") args +genPrimCode target res IntegerSubOp args = + gmpTake2Return1 target res SLIT("mpz_sub") args +genPrimCode target res IntegerMulOp args = + gmpTake2Return1 target res SLIT("mpz_mul") args + +genPrimCode target res IntegerNegOp arg = + gmpTake1Return1 target res SLIT("mpz_neg") arg + +genPrimCode target res IntegerQuotRemOp arg = + gmpTake2Return2 target res SLIT("mpz_divmod") arg +genPrimCode target res IntegerDivModOp arg = + gmpTake2Return2 target res SLIT("mpz_targetivmod") arg + +\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. + +\begin{code} + +genPrimCode target [res] IntegerCmpOp args = gmpCompare target res args + +genPrimCode target [res] Integer2IntOp arg = gmpInteger2Int target res arg + +genPrimCode target res Int2IntegerOp args = gmpInt2Integer target res args + +genPrimCode target res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp" + +genPrimCode target res Addr2IntegerOp args = gmpString2Integer target res args + +genPrimCode target res FloatEncodeOp args = + encodeFloatingKind FloatKind target res args + +genPrimCode target res DoubleEncodeOp args = + encodeFloatingKind DoubleKind target res args + +genPrimCode target res FloatDecodeOp args = + decodeFloatingKind FloatKind target res args + +genPrimCode target res DoubleDecodeOp args = + decodeFloatingKind DoubleKind target res args + +genPrimCode target res Int2AddrOp arg = + simpleCoercion target AddrKind res arg + +genPrimCode target res Addr2IntOp arg = + simpleCoercion target IntKind res arg + +genPrimCode target res Int2WordOp arg = + simpleCoercion target IntKind{-WordKind?-} res arg + +genPrimCode target res Word2IntOp arg = + simpleCoercion target IntKind res arg + +\end{code} + +@newArray#@ ops allocate heap space. + +\begin{code} + +genPrimCode target [res] NewArrayOp args = + let [liveness, n, initial] = map (amodeToStix target) args + result = amodeToStix target res + space = StPrim IntAddOp [n, mutHS target] + loc = StIndex PtrKind stgHp + (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) + assign = StAssign PtrKind result loc + initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial] + in + heapCheck target liveness space (StInt 0) + `thenSUs` \ heap_chk -> + + returnSUs (heap_chk . (\xs -> assign : initialise : xs)) + +genPrimCode target [res] (NewByteArrayOp pk) args = + let [liveness, count] = map (amodeToStix target) args + result = amodeToStix target res + n = StPrim IntMulOp [count, StInt (toInteger (sizeof target pk))] + slop = StPrim IntAddOp [n, StInt (toInteger (sizeof target IntKind - 1))] + words = StPrim IntDivOp [slop, StInt (toInteger (sizeof target IntKind))] + space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS target]] + loc = StIndex PtrKind stgHp + (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]]) + assign = StAssign PtrKind result loc + init1 = StAssign PtrKind (StInd PtrKind loc) arrayOfData_info + init2 = StAssign IntKind + (StInd IntKind + (StIndex IntKind loc + (StInt (toInteger (fixedHeaderSize target))))) + (StPrim IntAddOp [words, + StInt (toInteger (varHeaderSize target + (DataRep 0)))]) + in + heapCheck target liveness space (StInt 0) + `thenSUs` \ heap_chk -> + + returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs)) + +genPrimCode target [res] SameMutableArrayOp args = + let compare = StPrim AddrEqOp (map (amodeToStix target) args) + assign = StAssign IntKind (amodeToStix target res) compare + in + returnSUs (\xs -> assign : xs) + +genPrimCode target res SameMutableByteArrayOp args = + genPrimCode target 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). + +\begin{code} + +genPrimCode target [lhs] UnsafeFreezeArrayOp [rhs] = + let lhs' = amodeToStix target lhs + rhs' = amodeToStix target rhs + header = StInd PtrKind lhs' + assign = StAssign PtrKind lhs' rhs' + freeze = StAssign PtrKind header imMutArrayOfPtrs_info + in + returnSUs (\xs -> assign : freeze : xs) + +genPrimCode target lhs UnsafeFreezeByteArrayOp rhs = + simpleCoercion target PtrKind lhs rhs + +\end{code} + +Most other array primitives translate to simple indexing. + +\begin{code} + +genPrimCode target lhs IndexArrayOp args = + genPrimCode target lhs ReadArrayOp args + +genPrimCode target [lhs] ReadArrayOp [obj, ix] = + let lhs' = amodeToStix target lhs + obj' = amodeToStix target obj + ix' = amodeToStix target ix + base = StIndex IntKind obj' (mutHS target) + assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix')) + in + returnSUs (\xs -> assign : xs) + +genPrimCode target [lhs] WriteArrayOp [obj, ix, v] = + let obj' = amodeToStix target obj + ix' = amodeToStix target ix + v' = amodeToStix target v + base = StIndex IntKind obj' (mutHS target) + assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v' + in + returnSUs (\xs -> assign : xs) + +genPrimCode target lhs (IndexByteArrayOp pk) args = + genPrimCode target lhs (ReadByteArrayOp pk) args + +genPrimCode target [lhs] (ReadByteArrayOp pk) [obj, ix] = + let lhs' = amodeToStix target lhs + obj' = amodeToStix target obj + ix' = amodeToStix target ix + base = StIndex IntKind obj' (dataHS target) + assign = StAssign pk lhs' (StInd pk (StIndex CharKind base ix')) + in + returnSUs (\xs -> assign : xs) + +genPrimCode target [] (WriteByteArrayOp pk) [obj, ix, v] = + let obj' = amodeToStix target obj + ix' = amodeToStix target ix + v' = amodeToStix target v + base = StIndex IntKind obj' (dataHS target) + assign = StAssign pk (StInd pk (StIndex CharKind base ix')) v' + in + returnSUs (\xs -> assign : xs) + +genPrimCode target [lhs] (IndexOffAddrOp pk) [obj, ix] = + let lhs' = amodeToStix target lhs + obj' = amodeToStix target obj + ix' = amodeToStix target ix + assign = StAssign pk lhs' (StInd pk (StIndex CharKind obj' ix')) + in + returnSUs (\xs -> assign : xs) + +\end{code} + +Stable pointer operations. + +First the easy one. + +\begin{code} + +genPrimCode target [lhs] DeRefStablePtrOp [sp] = + let lhs' = amodeToStix target lhs + pk = getAmodeKind lhs + sp' = amodeToStix target sp + call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable] + assign = StAssign pk lhs' call + in + returnSUs (\xs -> assign : xs) + +\end{code} + +Now the hard one. For comparison, here's the code from StgMacros: + +\begin{verbatim} +#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \ +do { \ + EXTDATA(MK_INFO_LBL(StablePointerTable)); \ + EXTDATA(UnusedSP); \ + StgStablePtr newSP; \ + \ + if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \ + I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \ + \ + /* any strictly increasing expression will do here */ \ + I_ NewNoPtrs = OldNoPtrs * 2 + 100; \ + \ + I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \ + P_ SPTable; \ + \ + HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \ + CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \ + \ + SPTable = Hp + 1 - (_FHS + NewSize); \ + SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \ + SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \ + StorageMgrInfo.StablePointerTable = SPTable; \ + } \ + \ + newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \ + SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \ + stablePtr = newSP; \ +} while (0) +\end{verbatim} + +ToDo ADR: finish this. (Boy, this is hard work!) + +Notes for ADR: + trMumbles are now just StMumbles. + StInt 1 is how to write ``1'' + temporaries are allocated at the end of the heap (see notes in StixInteger) + Good luck! + + --JSM + +\begin{pseudocode} +genPrimCode sty md [lhs] MakeStablePtrOp args = + let + -- some useful abbreviations (I'm sure these must exist already) + add = trPrim . IntAddOp + sub = trPrim . IntSubOp + one = trInt [1] + dec x = trAssign IntKind [x, sub [x, one]] + inc x = trAssign IntKind [x, add [x, one]] + + -- tedious hardwiring in of closure layout offsets (from SMClosures) + dynHS = 2 + fixedHeaderSize md sty + varHeaderSize md sty DynamicRep + spt_SIZE c = trIndex PtrKind [c, trInt [fhs + gc_reserved] ] + spt_NoPTRS c = trIndex PtrKind [c, trInt [fhs + gc_reserved + 1] ] + spt_SPTR c i = trIndex PtrKind [c, add [trInt [dynHS], i]] + spt_TOP c = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]] + spt_FREE c i = trIndex PtrKind [c, add [trInt [dynHS], spt_NoPTRS c]] + + -- tedious hardwiring in of stack manipulation macros (from SMClosures) + spt_FULL c lbl = + trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]] + spt_EMPTY c lbl = + trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]] + spt_PUSH c f = [ + trAssign PtrKind [spt_FREE c (spt_TOP c), f], + inc (spt_TOP c), + spt_POP c x = [ + dec (spt_TOP c), + trAssign PtrKind [x, spt_FREE c (spt_TOP c)] + ] + + -- now to get down to business + lhs' = amodeCode sty md lhs + [liveness, unstable] = map (amodeCode sty md) args + + spt = smStablePtrTable + + newSPT = -- a temporary (don't know how to allocate it) + newSP = -- another temporary + + allocNewTable = -- some sort fo heap allocation needed + copyOldTable = trCall "enlargeSPTable" PtrKind [newSPT, spt] + + enlarge = + allocNewTable ++ [ + copyOldTable, + trAssign PtrKind [spt, newSPT] + allocate = [ + spt_POP spt newSP, + trAssign PtrKind [spt_SPTR spt newSP, unstable], + trAssign StablePtrKind [lhs', newSP] + ] + + in + getUniqLabelCTS `thenCTS` \ oklbl -> + returnCodes sty md + (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate))) +\end{pseudocode} + + +Now the more mundane operations. + +\begin{code} + +genPrimCode target lhs op rhs = + let lhs' = map (amodeToStix target) lhs + rhs' = map (amodeToStix' target) rhs + in + returnSUs (\ xs -> simplePrim target lhs' op rhs' : xs) + +simpleCoercion + :: Target + -> PrimKind + -> [CAddrMode] + -> [CAddrMode] + -> SUniqSM StixTreeList + +simpleCoercion target pk [lhs] [rhs] = + returnSUs (\xs -> StAssign pk (amodeToStix target lhs) (amodeToStix target 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. + +\begin{code} + +simplePrim + :: Target + -> [StixTree] + -> PrimOp + -> [StixTree] + -> StixTree + +\end{code} + +Now look for something more conventional. + +\begin{code} + +simplePrim target [lhs] op rest = StAssign pk lhs (StPrim op rest) + where pk = if isCompareOp op then IntKind + else case getPrimOpResultInfo op of + ReturnsPrim pk -> pk + _ -> simplePrim_error op + +simplePrim target _ 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} + +%--------------------------------------------------------------------- + +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 +amodes that might possibly need the extra cast. + +\begin{code} + +amodeCode, amodeCode' + :: Target + -> CAddrMode + -> StixTree + +amodeCode' target am@(CVal rr CharKind) + | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am] + | otherwise = amodeToStix target am + +amodeCode' target am = amodeToStix target am + +amodeCode target am@(CVal rr CharKind) | mixedTypeLocn am = + StInd IntKind (amodeCode target (CAddr rr)) + +amodeCode target (CVal rr pk) = StInd pk (amodeCode target (CAddr rr)) + +amodeCode target (CAddr r@(SpARel spA off)) = + StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r))) + +amodeCode target (CAddr r@(SpBRel spB off)) = + StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r))) + +amodeCode target (CAddr (HpRel hp off)) = + StIndex IntKind stgHp (StInt (toInteger (-(hpRel target (hp `subOff` off))))) + +amodeCode target (CAddr (NodeRel off)) = + StIndex IntKind stgNode (StInt (toInteger (hpRel target off))) + +amodeCode target (CReg magic) = StReg (StixMagicId magic) +amodeCode target (CTemp uniq pk) = StReg (StixTemp uniq pk) + +amodeCode target (CLbl lbl _) = StCLbl lbl + +amodeCode target (CUnVecLbl dir _) = StCLbl dir + +amodeCode target (CTableEntry base off pk) = + StInd pk (StIndex pk (amodeCode target base) (amodeCode target off)) + +-- For CharLike and IntLike, we attempt some trivial constant-folding here. + +amodeCode target (CCharLike (CLit (MachChar c))) = + StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off)) + where off = charLikeClosureSize target * ord c + +amodeCode target (CCharLike x) = + StPrim IntAddOp [charLike, off] + where off = StPrim IntMulOp [amodeCode target x, + StInt (toInteger (charLikeClosureSize target))] + +amodeCode target (CIntLike (CLit (MachInt i _))) = + StPrim IntAddOp [intLikePtr, StInt off] + where off = toInteger (intLikeClosureSize target) * i + +amodeCode target (CIntLike x) = + StPrim IntAddOp [intLikePtr, off] + where off = StPrim IntMulOp [amodeCode target x, + StInt (toInteger (intLikeClosureSize target))] + +-- A CString is just a (CLit . MachStr) +amodeCode target (CString s) = StString s + +amodeCode target (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" + +-- A CLitLit is just a (CLit . MachLitLit) +amodeCode target (CLitLit s _) = StLitLit s + +-- COffsets are in words, not bytes! +amodeCode target (COffset off) = StInt (toInteger (hpRel target off)) + +amodeCode target (CMacroExpr _ macro [arg]) = + case macro of + INFO_PTR -> StInd PtrKind (amodeToStix target arg) + ENTRY_CODE -> amodeToStix target arg + INFO_TAG -> tag + EVAL_TAG -> StPrim IntGeOp [tag, StInt 0] + where + tag = StInd IntKind (StIndex IntKind (amodeToStix target arg) (StInt (-2))) + -- That ``-2'' really bothers me. (JSM) + +amodeCode target (CCostCentre cc print_as_string) + = if noCostCentreAttached cc + then StComment SLIT("") -- sigh + else panic "amodeCode:CCostCentre" +\end{code} + +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 + +intLikePtr = StInd PtrKind (sStLitLbl SLIT("INTLIKE_closures")) + +-- The CHARLIKE base + +charLike :: StixTree + +charLike = sStLitLbl SLIT("CHARLIKE_closures") + +-- Trees for the ErrorIOPrimOp + +topClosure, flushStdout, flushStderr, errorIO :: StixTree + +topClosure = StInd PtrKind (sStLitLbl SLIT("TopClosure")) +flushStdout = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stdout")] +flushStderr = StCall SLIT("fflush") VoidKind [StLitLit SLIT("stderr")] +errorIO = StJump (StInd PtrKind (sStLitLbl SLIT("ErrorIO_innards"))) + +\end{code} + diff --git a/ghc/compiler/nativeGen/root.lit b/ghc/compiler/nativeGen/root.lit new file mode 100644 index 0000000..d383ab3 --- /dev/null +++ b/ghc/compiler/nativeGen/root.lit @@ -0,0 +1,60 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate,a4wide]{article} +\begin{document} +\title{Native Code Generation} +\author{The AQUA team} +\date{February 1994} +\maketitle +\tableofcontents +\end{onlystandalone} + +\begin{onlypartofdoc} +\section[Native_Code_Gen]{Native Code Generation} +\downsection +\end{onlypartofdoc} + +The following sections appear in fairly random order. + +\section{Asm} +\downsection +\input{AsmCodeGen.lhs} +\input{AsmCodeClass.lhs} +\input{AsmMatch.lhs} +\input{AsmMonad.lhs} +\input{AsmRegAlloc.lhs} +\input{AsmUtils.lhs} +\upsection + +\section{AbsC} +\downsection +\input{AbsCStixGen.lhs} +\input{AbsCInline.lhs} +\upsection + +\section{Stix} +\downsection +\input{Stix.lhs} +\input{StixInfo.lhs} +\input{StixMacro.lhs} +\input{StixMisc.lhs} +\input{StixPrim.lhs} +\upsection + +\section{Sparc} +\downsection +\input{SparcGen.lhs} +\input{SparcCode.lhs} +\upsection + +\section{Misc} +\downsection +\input{MachDesc.lhs} +\upsection + +\begin{onlypartofdoc} +\upsection +\end{onlypartofdoc} +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/prelude/AbsPrel.hi b/ghc/compiler/prelude/AbsPrel.hi new file mode 100644 index 0000000..ca8ed00 --- /dev/null +++ b/ghc/compiler/prelude/AbsPrel.hi @@ -0,0 +1,365 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsPrel where +import BasicLit(BasicLit) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(NamedThing, Outputable) +import PlainCore(PlainCoreExpr(..)) +import PrelFuns(gLASGOW_MISC, gLASGOW_ST, pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_IO, pRELUDE_LIST, pRELUDE_PRIMIO, pRELUDE_PS, pRELUDE_RATIO, pRELUDE_TEXT) +import PrelVals(aBSENT_ERROR_ID, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCStringAppendId, unpackCStringId, voidPrimId) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import PrimKind(PrimKind) +import PrimOps(HeapRequirement(..), PrimOp(..), PrimOpResultInfo(..), fragilePrimOp, getPrimOpResultInfo, isCompareOp, pprPrimOp, primOpCanTriggerGC, primOpHeapReq, primOpIsCheap, primOpNameInfo, primOpNeedsWrapper, primOpOkForSpeculation, showPrimOp, tagOf_PrimOp, typeOfPrimOp) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TysPrim(addrPrimTy, addrPrimTyCon, charPrimTy, charPrimTyCon, doublePrimTy, doublePrimTyCon, floatPrimTy, floatPrimTyCon, intPrimTy, intPrimTyCon, mkStatePrimTy, realWorldStatePrimTy, realWorldTy, realWorldTyCon, voidPrimTy, wordPrimTy, wordPrimTyCon) +import TysWiredIn(addrDataCon, addrTy, boolTy, boolTyCon, charDataCon, charTy, charTyCon, cmpTagTy, consDataCon, doubleDataCon, doubleTy, doubleTyCon, eqPrimDataCon, falseDataCon, floatDataCon, floatTy, floatTyCon, getStatePairingConInfo, gtPrimDataCon, intDataCon, intTy, intTyCon, integerTy, integerTyCon, liftDataCon, liftTyCon, listTyCon, ltPrimDataCon, mkLiftTy, mkListTy, mkPrimIoTy, mkTupleTy, nilDataCon, ratioDataCon, rationalTy, rationalTyCon, realWorldStateTy, stateDataCon, stringTy, trueDataCon, unitTy, wordDataCon, wordTy) +import UniType(TauType(..), UniType) +import Unique(Unique) +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data HeapOffset +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +type PlainCoreExpr = CoreExpr Id Id +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired +data PrimOp + = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp +data PrimOpResultInfo = ReturnsPrim PrimKind | ReturnsAlg TyCon +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +type TauType = UniType +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +gLASGOW_MISC :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gLASGOW_ST :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_BUILTIN :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_CORE :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_IO :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_LIST :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_PRIMIO :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_PS :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_RATIO :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_TEXT :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +aBSENT_ERROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +buildId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eRROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +foldlId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +foldrId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerMinusOneId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerPlusOneId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerZeroId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-} +mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +fragilePrimOp :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isCompareOp :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +addrPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doublePrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doublePrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +boolTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +boolTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +builtinNameInfo :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name) + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cmpTagTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +consDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqPrimDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +falseDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +getStatePairingConInfo :: UniType -> (Id, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +gtPrimDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +liftDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +liftTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +listTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ltPrimDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkFunTy :: UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: UniType) (u1 :: UniType) -> _!_ _ORIG_ UniType UniFun [] [u0, u1] _N_ #-} +pAT_ERROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +packStringForCId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldPrimId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpackCStringAppendId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpackCStringId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +voidPrimId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +primOpCanTriggerGC :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +primOpHeapReq :: PrimOp -> HeapRequirement + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +primOpIsCheap :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +primOpNameInfo :: PrimOp -> (_PackedString, Name) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +primOpNeedsWrapper :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +primOpOkForSpeculation :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +showPrimOp :: PprStyle -> PrimOp -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +tagOf_PrimOp :: PrimOp -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfPrimOp :: PrimOp -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkStatePrimTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +realWorldStatePrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysPrim mkStatePrimTy [ _ORIG_ TysPrim realWorldTy ] _N_ #-} +realWorldTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +voidPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkLiftTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkListTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkPrimIoTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkTupleTy :: Int -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +nilDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ratioDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +rationalTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +rationalTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +readUnfoldingPrimOp :: _PackedString -> PrimOp + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldStateTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stringTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysWiredIn mkListTy [ _ORIG_ TysWiredIn charTy ] _N_ #-} +trueDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unitTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord GlobalSwitch + {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_ + ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/prelude/AbsPrel.lhs b/ghc/compiler/prelude/AbsPrel.lhs new file mode 100644 index 0000000..dffc163 --- /dev/null +++ b/ghc/compiler/prelude/AbsPrel.lhs @@ -0,0 +1,611 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[AbsPrel]{The @AbsPrel@ interface to the compiler's prelude knowledge} + +\begin{code} +#include "HsVersions.h" + +module AbsPrel ( + +-- unlike most export lists, this one is actually interesting :-) + + -- re-export some PrimOp stuff: + PrimOp(..), typeOfPrimOp, primOpNameInfo, + HeapRequirement(..), primOpHeapReq, primOpCanTriggerGC, + primOpNeedsWrapper, primOpOkForSpeculation, primOpIsCheap, + fragilePrimOp, + PrimOpResultInfo(..), getPrimOpResultInfo, + pprPrimOp, showPrimOp, isCompareOp, + readUnfoldingPrimOp, -- actually, defined herein + + pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO, + pRELUDE_LIST, pRELUDE_TEXT, --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX, + pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS, + gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC, + + -- lookup functions for built-in names, for the renamer: + builtinNameInfo, + + -- *odd* values that need to be reached out and grabbed: + eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID, + unpackCStringId, packStringForCId, unpackCStringAppendId, + integerZeroId, integerPlusOneId, integerMinusOneId, + +#ifdef DPH + -- ProcessorClass + toPodId, + + -- Pid Class + fromDomainId, toDomainId, +#endif {- Data Parallel Haskell -} + + ----------------------------------------------------- + -- the rest of the export list is organised by *type* + ----------------------------------------------------- + + -- "type": functions ("arrow" type constructor) + mkFunTy, + + -- type: Bool + boolTyCon, boolTy, falseDataCon, trueDataCon, + + -- types: Char#, Char, String (= [Char]) + charPrimTy, charTy, stringTy, + charPrimTyCon, charTyCon, charDataCon, + + -- type: CMP_TAG (used in deriving) + cmpTagTy, ltPrimDataCon, eqPrimDataCon, gtPrimDataCon, + + -- types: Double#, Double + doublePrimTy, doubleTy, + doublePrimTyCon, doubleTyCon, doubleDataCon, + + -- types: Float#, Float + floatPrimTy, floatTy, + floatPrimTyCon, floatTyCon, floatDataCon, + + -- types: Glasgow *primitive* arrays, sequencing and I/O + mkPrimIoTy, -- to typecheck "mainIO", "mainPrimIO" & for _ccall_s + realWorldStatePrimTy, realWorldStateTy{-boxed-}, + realWorldTy, realWorldTyCon, realWorldPrimId, + stateDataCon, getStatePairingConInfo, + + -- types: Void# (only used within the compiler) + voidPrimTy, voidPrimId, + + -- types: Addr#, Int#, Word#, Int + intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon, + wordPrimTyCon, wordPrimTy, wordTy, wordDataCon, + addrPrimTyCon, addrPrimTy, addrTy, addrDataCon, + + -- types: Integer, Rational (= Ratio Integer) + integerTy, rationalTy, + integerTyCon, rationalTyCon, ratioDataCon, + + -- type: Lift + liftTyCon, liftDataCon, mkLiftTy, + + -- type: List + listTyCon, mkListTy, nilDataCon, consDataCon, + -- NOT USED: buildDataCon, + + -- type: tuples + mkTupleTy, unitTy, + + -- packed Strings +-- packedStringTyCon, packedStringTy, psDataCon, cpsDataCon, + + -- for compilation of List Comprehensions and foldr + foldlId, foldrId, mkFoldl, mkFoldr, mkBuild, buildId, + +#ifdef DPH + mkProcessorTy, + mkPodTy, mkPodNTy, podTyCon, -- user model + mkPodizedPodNTy, -- podized model + mkInterfacePodNTy, interfacePodTyCon, mKINTERPOD_ID, -- interface model + + -- Misc used during podization + primIfromPodNSelectorId, +#endif {- Data Parallel Haskell -} + + -- and, finally, we must put in some (abstract) data types, + -- to make the interface self-sufficient + GlobalSwitch, Id, Maybe, Name, PprStyle, PrimKind, HeapOffset, + TyCon, UniType, TauType(..), Unique, CoreExpr, PlainCoreExpr(..) + + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA mkStatePrimTy) + +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +#ifdef DPH +import TyPod +import TyProcs +#endif {- Data Parallel Haskell -} + +import PrelFuns -- help functions, types and things +import PrimKind + +import TysPrim -- TYPES +import TysWiredIn +import PrelVals -- VALUES +import PrimOps -- PRIMITIVE OPS + +import AbsUniType ( getTyConDataCons, TyCon + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import CmdLineOpts ( GlobalSwitch(..) ) +import FiniteMap +import Id ( Id ) +--OLD:import NameEnv +import Maybes +import Unique -- *Key stuff +import Util +\end{code} + +This little devil is too small to merit its own ``TyFun'' module: + +\begin{code} +mkFunTy = UniFun +\end{code} + +%************************************************************************ +%* * +\subsection[builtinNameInfo]{Lookup built-in names} +%* * +%************************************************************************ + +We have two ``builtin name funs,'' one to look up @TyCons@ and +@Classes@, the other to look up values. + +\begin{code} +builtinNameInfo :: (GlobalSwitch -> Bool) -- access to global cmd-line flags + -> (FAST_STRING -> Maybe Name, -- name lookup fn for values + FAST_STRING -> Maybe Name) -- name lookup fn for tycons/classes + +builtinNameInfo switch_is_on + = (init_val_lookup_fn, init_tc_lookup_fn) + where + -- + -- values (including data constructors) + -- + init_val_lookup_fn + = if switch_is_on HideBuiltinNames then + (\ x -> Nothing) + else if switch_is_on HideMostBuiltinNames then + lookupFM (listToFM min_val_assoc_list) + -- OLD: mkStringLookupFn min_val_assoc_list False{-not pre-sorted-} + else + lookupFM (listToFM (concat list_of_val_assoc_lists)) + -- mkStringLookupFn (concat list_of_val_assoc_lists) False{-not pre-sorted-} + + min_val_assoc_list -- this is an ad-hoc list; what "happens" + = totally_wired_in_Ids -- to be needed (when compiling bits of + ++ unboxed_ops -- Prelude). + ++ (concat (map pcDataConNameInfo min_nonprim_tycon_list)) + + -- We let a lot of "non-standard" values be visible, so that we + -- can make sense of them in interface pragmas. It's cool, though + -- -- they all have "non-standard" names, so they won't get past + -- the parser in user code. + list_of_val_assoc_lists + = [ -- each list is empty or all there + + totally_wired_in_Ids, + + concat (map pcDataConNameInfo data_tycons), + + unboxed_ops, + + if switch_is_on ForConcurrent then parallel_vals else [] + ] + + -- + -- type constructors and classes + -- + init_tc_lookup_fn + = if switch_is_on HideBuiltinNames then + (\ x -> Nothing) + else if switch_is_on HideMostBuiltinNames then + lookupFM (listToFM min_tc_assoc_list) + --OLD: mkStringLookupFn min_tc_assoc_list False{-not pre-sorted-} + else + lookupFM (listToFM ( + -- OLD: mkStringLookupFn + map pcTyConNameInfo (data_tycons ++ synonym_tycons) + ++ std_tycon_list -- TyCons not quite so wired in + ++ std_class_list + ++ prim_tys)) + -- The prim_tys,etc., are OK, because they all + -- have "non-standard" names (and we really + -- want them for interface pragmas). + --OLD: False{-not pre-sorted-} + + min_tc_assoc_list -- again, pretty ad-hoc + = prim_tys ++ (map pcTyConNameInfo min_nonprim_tycon_list) +--HA! ++ std_class_list -- no harm in this + +min_nonprim_tycon_list -- used w/ HideMostBuiltinNames + = [ boolTyCon, + cmpTagTyCon, + charTyCon, + intTyCon, + floatTyCon, + doubleTyCon, + integerTyCon, + ratioTyCon, + return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11) + returnIntAndGMPTyCon ] + +-- sigh: I (WDP) think these should be local defns +-- but you cannot imagine how bad it is for speed (w/ GHC) +prim_tys = map pcTyConNameInfo prim_tycons + +-- values + +totally_wired_in_Ids + = [(SLIT(":"), WiredInVal consDataCon), + (SLIT("error"), WiredInVal eRROR_ID), + (SLIT("patError#"), WiredInVal pAT_ERROR_ID), -- occurs in i/faces + (SLIT("parError#"), WiredInVal pAR_ERROR_ID), -- ditto + (SLIT("_trace"), WiredInVal tRACE_ID), + + -- now the build / foldr Id, which needs to be built in + (SLIT("_build"), WiredInVal buildId), + (SLIT("foldl"), WiredInVal foldlId), + (SLIT("foldr"), WiredInVal foldrId), + (SLIT("_runST"), WiredInVal runSTId), + (SLIT("realWorld#"), WiredInVal realWorldPrimId) + ] + +parallel_vals + =[(SLIT("_seq_"), WiredInVal seqId), + (SLIT("_par_"), WiredInVal parId), + (SLIT("_fork_"), WiredInVal forkId) +#ifdef GRAN + , + (SLIT("_parLocal_"), WiredInVal parLocalId), + (SLIT("_parGlobal_"), WiredInVal parGlobalId) + -- Add later: + -- (SLIT("_parAt_"), WiredInVal parAtId) + -- (SLIT("_parAtForNow_"), WiredInVal parAtForNowId) + -- (SLIT("_copyable_"), WiredInVal copyableId) + -- (SLIT("_noFollow_"), WiredInVal noFollowId) +#endif {-GRAN-} + ] + +unboxed_ops + = (map primOpNameInfo lots_of_primops) + ++ + -- plus some of the same ones but w/ different names + [case (primOpNameInfo IntAddOp) of (_,n) -> (SLIT("+#"), n), + case (primOpNameInfo IntSubOp) of (_,n) -> (SLIT("-#"), n), + case (primOpNameInfo IntMulOp) of (_,n) -> (SLIT("*#"), n), + case (primOpNameInfo IntGtOp) of (_,n) -> (SLIT(">#"), n), + case (primOpNameInfo IntGeOp) of (_,n) -> (SLIT(">=#"), n), + case (primOpNameInfo IntEqOp) of (_,n) -> (SLIT("==#"), n), + case (primOpNameInfo IntNeOp) of (_,n) -> (SLIT("/=#"), n), + case (primOpNameInfo IntLtOp) of (_,n) -> (SLIT("<#"), n), + case (primOpNameInfo IntLeOp) of (_,n) -> (SLIT("<=#"), n), + case (primOpNameInfo DoubleAddOp) of (_,n) -> (SLIT("+##"), n), + case (primOpNameInfo DoubleSubOp) of (_,n) -> (SLIT("-##"), n), + case (primOpNameInfo DoubleMulOp) of (_,n) -> (SLIT("*##"), n), + case (primOpNameInfo DoubleDivOp) of (_,n) -> (SLIT("/##"), n), + case (primOpNameInfo DoublePowerOp) of (_,n) -> (SLIT("**##"), n), + case (primOpNameInfo DoubleGtOp) of (_,n) -> (SLIT(">##"), n), + case (primOpNameInfo DoubleGeOp) of (_,n) -> (SLIT(">=##"), n), + case (primOpNameInfo DoubleEqOp) of (_,n) -> (SLIT("==##"), n), + case (primOpNameInfo DoubleNeOp) of (_,n) -> (SLIT("/=##"), n), + case (primOpNameInfo DoubleLtOp) of (_,n) -> (SLIT("<##"), n), + case (primOpNameInfo DoubleLeOp) of (_,n) -> (SLIT("<=##"), n)] + +prim_tycons + = [addrPrimTyCon, + arrayPrimTyCon, + byteArrayPrimTyCon, + charPrimTyCon, + doublePrimTyCon, + floatPrimTyCon, + intPrimTyCon, + mallocPtrPrimTyCon, + mutableArrayPrimTyCon, + mutableByteArrayPrimTyCon, + synchVarPrimTyCon, + realWorldTyCon, + stablePtrPrimTyCon, + statePrimTyCon, + wordPrimTyCon + ] + +std_tycon_list + = let + swizzle_over (mod, nm, key, arity, is_data) + = let + fname = mkPreludeCoreName mod nm + in + (nm, PreludeTyCon key fname arity is_data) + in + map swizzle_over + [--(pRELUDE_IO, SLIT("Request"), requestTyConKey, 0, True), +--OLD: (pRELUDE_IO, SLIT("Response"), responseTyConKey, 0, True), + (pRELUDE_IO, SLIT("Dialogue"), dialogueTyConKey, 0, False), + (SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey, 1, False) + ] + +-- Several of these are non-std, but they have non-std +-- names, so they won't get past the parser in user code +-- (but will be visible for interface-pragma purposes). + +data_tycons + = [addrTyCon, + boolTyCon, +-- byteArrayTyCon, + charTyCon, + cmpTagTyCon, + doubleTyCon, + floatTyCon, + intTyCon, + integerTyCon, + liftTyCon, + mallocPtrTyCon, +-- mutableArrayTyCon, +-- mutableByteArrayTyCon, + ratioTyCon, + return2GMPsTyCon, + returnIntAndGMPTyCon, + stablePtrTyCon, + stateAndAddrPrimTyCon, + stateAndArrayPrimTyCon, + stateAndByteArrayPrimTyCon, + stateAndCharPrimTyCon, + stateAndDoublePrimTyCon, + stateAndFloatPrimTyCon, + stateAndIntPrimTyCon, + stateAndMallocPtrPrimTyCon, + stateAndMutableArrayPrimTyCon, + stateAndMutableByteArrayPrimTyCon, + stateAndSynchVarPrimTyCon, + stateAndPtrPrimTyCon, + stateAndStablePtrPrimTyCon, + stateAndWordPrimTyCon, + stateTyCon, + wordTyCon +#ifdef DPH + ,podTyCon +#endif {- Data Parallel Haskell -} + ] + +synonym_tycons + = [primIoTyCon, + rationalTyCon, + stTyCon, + stringTyCon] + +std_class_list + = let + swizzle_over (str, key) + = (str, PreludeClass key (mkPreludeCoreName pRELUDE_CORE str)) + in + map swizzle_over + [(SLIT("Eq"), eqClassKey), + (SLIT("Ord"), ordClassKey), + (SLIT("Num"), numClassKey), + (SLIT("Real"), realClassKey), + (SLIT("Integral"), integralClassKey), + (SLIT("Fractional"), fractionalClassKey), + (SLIT("Floating"), floatingClassKey), + (SLIT("RealFrac"), realFracClassKey), + (SLIT("RealFloat"), realFloatClassKey), + (SLIT("Ix"), ixClassKey), + (SLIT("Enum"), enumClassKey), + (SLIT("Text"), textClassKey), + (SLIT("_CCallable"), cCallableClassKey), + (SLIT("_CReturnable"), cReturnableClassKey), + (SLIT("Binary"), binaryClassKey) +#ifdef DPH + , (SLIT("Pid"), pidClassKey) + , (SLIT("Processor"),processorClassKey) +#endif {- Data Parallel Haskell -} + ] + +lots_of_primops + = [ CharGtOp, + CharGeOp, + CharEqOp, + CharNeOp, + CharLtOp, + CharLeOp, + IntGtOp, + IntGeOp, + IntEqOp, + IntNeOp, + IntLtOp, + IntLeOp, + WordGtOp, + WordGeOp, + WordEqOp, + WordNeOp, + WordLtOp, + WordLeOp, + AddrGtOp, + AddrGeOp, + AddrEqOp, + AddrNeOp, + AddrLtOp, + AddrLeOp, + FloatGtOp, + FloatGeOp, + FloatEqOp, + FloatNeOp, + FloatLtOp, + FloatLeOp, + DoubleGtOp, + DoubleGeOp, + DoubleEqOp, + DoubleNeOp, + DoubleLtOp, + DoubleLeOp, + OrdOp, + ChrOp, + IntAddOp, + IntSubOp, + IntMulOp, + IntQuotOp, + IntDivOp, + IntRemOp, + IntNegOp, + AndOp, + OrOp, + NotOp, + SllOp, + SraOp, + SrlOp, + ISllOp, + ISraOp, + ISrlOp, + Int2WordOp, + Word2IntOp, + Int2AddrOp, + Addr2IntOp, + FloatAddOp, + FloatSubOp, + FloatMulOp, + FloatDivOp, + FloatNegOp, + Float2IntOp, + Int2FloatOp, + FloatExpOp, + FloatLogOp, + FloatSqrtOp, + FloatSinOp, + FloatCosOp, + FloatTanOp, + FloatAsinOp, + FloatAcosOp, + FloatAtanOp, + FloatSinhOp, + FloatCoshOp, + FloatTanhOp, + FloatPowerOp, + DoubleAddOp, + DoubleSubOp, + DoubleMulOp, + DoubleDivOp, + DoubleNegOp, + Double2IntOp, + Int2DoubleOp, + Double2FloatOp, + Float2DoubleOp, + DoubleExpOp, + DoubleLogOp, + DoubleSqrtOp, + DoubleSinOp, + DoubleCosOp, + DoubleTanOp, + DoubleAsinOp, + DoubleAcosOp, + DoubleAtanOp, + DoubleSinhOp, + DoubleCoshOp, + DoubleTanhOp, + DoublePowerOp, + IntegerAddOp, + IntegerSubOp, + IntegerMulOp, + IntegerQuotRemOp, + IntegerDivModOp, + IntegerNegOp, + IntegerCmpOp, + Integer2IntOp, + Int2IntegerOp, + Word2IntegerOp, + Addr2IntegerOp, + FloatEncodeOp, + FloatDecodeOp, + DoubleEncodeOp, + DoubleDecodeOp, + NewArrayOp, + NewByteArrayOp CharKind, + NewByteArrayOp IntKind, + NewByteArrayOp AddrKind, + NewByteArrayOp FloatKind, + NewByteArrayOp DoubleKind, + SameMutableArrayOp, + SameMutableByteArrayOp, + ReadArrayOp, + WriteArrayOp, + IndexArrayOp, + ReadByteArrayOp CharKind, + ReadByteArrayOp IntKind, + ReadByteArrayOp AddrKind, + ReadByteArrayOp FloatKind, + ReadByteArrayOp DoubleKind, + WriteByteArrayOp CharKind, + WriteByteArrayOp IntKind, + WriteByteArrayOp AddrKind, + WriteByteArrayOp FloatKind, + WriteByteArrayOp DoubleKind, + IndexByteArrayOp CharKind, + IndexByteArrayOp IntKind, + IndexByteArrayOp AddrKind, + IndexByteArrayOp FloatKind, + IndexByteArrayOp DoubleKind, + IndexOffAddrOp CharKind, + IndexOffAddrOp IntKind, + IndexOffAddrOp AddrKind, + IndexOffAddrOp FloatKind, + IndexOffAddrOp DoubleKind, + UnsafeFreezeArrayOp, + UnsafeFreezeByteArrayOp, + NewSynchVarOp, + ReadArrayOp, + TakeMVarOp, + PutMVarOp, + ReadIVarOp, + WriteIVarOp, + MakeStablePtrOp, + DeRefStablePtrOp, + ReallyUnsafePtrEqualityOp, + ErrorIOPrimOp, +#ifdef GRAN + ParGlobalOp, + ParLocalOp, +#endif {-GRAN-} + SeqOp, + ParOp, + ForkOp, + DelayOp, + WaitOp + ] +\end{code} + +\begin{code} +readUnfoldingPrimOp :: FAST_STRING -> PrimOp + +readUnfoldingPrimOp + = let + -- "reverse" lookup table + tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) lots_of_primops + in + \ str -> case [ op | (s, op) <- tbl, s == str ] of + (op:_) -> op +#ifdef DEBUG + [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl)) +#endif +\end{code} + +Make table entries for various things: +\begin{code} +pcTyConNameInfo :: TyCon -> (FAST_STRING, Name) +pcTyConNameInfo tycon + = (getOccurrenceName tycon, WiredInTyCon tycon) + +pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)] +pcDataConNameInfo tycon + = -- slurp out its data constructors... + [(getOccurrenceName con, WiredInVal con) | con <- getTyConDataCons tycon] +\end{code} diff --git a/ghc/compiler/prelude/Jmakefile b/ghc/compiler/prelude/Jmakefile new file mode 100644 index 0000000..9bc2736 --- /dev/null +++ b/ghc/compiler/prelude/Jmakefile @@ -0,0 +1,19 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) +HaskellSuffixRules() + +LitSuffixRule(.lit,/*none*/) /* no language really */ +LitSuffixRule(.lhs,.hs) /* Haskell */ +LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */ +LitSuffixRule(.lprl,.prl) /* Perl */ +LitSuffixRule(.lsh,.sh) /* Bourne shell */ +LitSuffixRule(.lc,.c) /* C */ +LitSuffixRule(.lh,.h) +LitSuffixRule(.llex,.lex) /* Lex */ +LitSuffixRule(.lflex,.flex) /* Flex */ + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTarget(prelude,lit) diff --git a/ghc/compiler/prelude/Makefile-fig b/ghc/compiler/prelude/Makefile-fig new file mode 100644 index 0000000..bcb4e60 --- /dev/null +++ b/ghc/compiler/prelude/Makefile-fig @@ -0,0 +1,18 @@ +# +# TransFig makefile +# + +all: prelude-structure.tex + +# translation into ps + +prelude-structure.tex: prelude-structure.ps Makefile-fig + fig2ps2tex prelude-structure.ps >prelude-structure.tex +clean:: + rm -f prelude-structure.tex + +prelude-structure.ps: prelude-structure.fig Makefile-fig + fig2dev -L ps prelude-structure.fig > prelude-structure.ps +clean:: + rm -f prelude-structure.ps + diff --git a/ghc/compiler/prelude/PrelFuns.hi b/ghc/compiler/prelude/PrelFuns.hi new file mode 100644 index 0000000..bdb8b08 --- /dev/null +++ b/ghc/compiler/prelude/PrelFuns.hi @@ -0,0 +1,230 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PrelFuns where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, arityMaybe, mkArityInfo, mkUnfolding, noIdInfo, noInfo_UF, nullSpecEnv) +import InstEnv(InstTemplate, InstTy) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda) +import Name(Name(..)) +import NameTypes(FullName, Provenance, ShortName, mkPreludeCoreName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind(..)) +import PrimOps(PrimOp(..)) +import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance(..)) +import SrcLoc(SrcLoc) +import TyCon(Arity(..), TyCon, cmpTyCon) +import TyVar(TyVar, TyVarTemplate, alpha_tv, alpha_tyvar, beta_tv, beta_tyvar, delta_tv, delta_tyvar, epsilon_tv, epsilon_tyvar, gamma_tv, gamma_tyvar) +import TyVarEnv(TyVarEnv(..)) +import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType(..), alpha, alpha_ty, beta, beta_ty, delta, delta_ty, epsilon, epsilon_ty, gamma, gamma_ty) +import UniqFM(UniqFM) +import Unique(Unique) +class OptIdInfo a where + noInfo :: a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-} + getInfo :: IdInfo -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-} + addInfo :: IdInfo -> a -> IdInfo + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-} + ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-} +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-} +data CoreCaseDefault a b {-# GHC_PRAGMA CoNoDefault | CoBindDefault a (CoreExpr a b) #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-} +data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-} +data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-} +data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-} +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-} +data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-} +data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-} +data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-} +data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-} +data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-} +data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +type PlainCoreAtom = CoreAtom Id +type PlainCoreExpr = CoreExpr Id Id +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind +data PrimOp + = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +type Arity = Int +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +arityMaybe :: ArityInfo -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ArityInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo UnknownArity -> _!_ _ORIG_ Maybes Hamna [Int] []; _ORIG_ IdInfo ArityExactly (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; _NO_DEFLT_ } _N_ #-} +mkArityInfo :: Int -> ArityInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ IdInfo ArityExactly [] [u0] _N_ #-} +mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +noIdInfo :: IdInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _ORIG_ IdInfo IdInfo [] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo noInfo (DemandInfo), _ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo noInfo (StrictnessInfo), _ORIG_ IdInfo noInfo_UF, _CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo noInfo (FBTypeInfo), _ORIG_ SrcLoc mkUnknownSrcLoc] _N_ #-} +noInfo_UF :: UnfoldingDetails + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ SimplEnv NoUnfoldingDetails [] [] _N_ #-} +nullSpecEnv :: SpecEnv + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkPreludeCoreName :: _PackedString -> _PackedString -> FullName + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +alpha_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +alpha_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +beta_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +beta_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +delta_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +delta_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +epsilon_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +epsilon_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gamma_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gamma_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +alpha :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar alpha_tv] _N_ #-} +alpha_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar alpha_tyvar] _N_ #-} +beta :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar beta_tv] _N_ #-} +beta_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar beta_tyvar] _N_ #-} +delta :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar delta_tv] _N_ #-} +delta_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar delta_tyvar] _N_ #-} +epsilon :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar epsilon_tv] _N_ #-} +epsilon_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar epsilon_tyvar] _N_ #-} +gLASGOW_MISC :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gLASGOW_ST :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gamma :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar gamma_tv] _N_ #-} +gamma_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar gamma_tyvar] _N_ #-} +pRELUDE :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_BUILTIN :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_CORE :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_IO :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_LIST :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_PRIMIO :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_PS :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_RATIO :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_TEXT :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pcDataCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id + {-# GHC_PRAGMA _A_ 8 _U_ 22222222 _N_ _N_ _N_ _N_ #-} +pcDataTyCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [Id] -> TyCon + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +pcGenerateDataSpecs :: UniType -> SpecEnv + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +pcMiscPrelId :: Unique -> _PackedString -> _PackedString -> UniType -> IdInfo -> Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +pcPrimTyCon :: Unique -> _PackedString -> Int -> ([PrimKind] -> PrimKind) -> TyCon + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/prelude/PrelFuns.lhs b/ghc/compiler/prelude/PrelFuns.lhs new file mode 100644 index 0000000..5caab83 --- /dev/null +++ b/ghc/compiler/prelude/PrelFuns.lhs @@ -0,0 +1,239 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[PrelFuns]{Help functions for prelude-related stuff} + +\begin{code} +#include "HsVersions.h" + +module PrelFuns ( + pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO, + pRELUDE_LIST, pRELUDE_TEXT, --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX, + pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS, + gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC, + + alpha_tv, alpha, beta_tv, beta, + gamma_tv, gamma, delta_tv, delta, epsilon_tv, epsilon, + alpha_tyvar, alpha_ty, beta_tyvar, beta_ty, + gamma_tyvar, gamma_ty, delta_tyvar, delta_ty, + epsilon_tyvar, epsilon_ty, + + pcDataTyCon, pcPrimTyCon, + pcDataCon, pcMiscPrelId, + pcGenerateSpecs, pcGenerateDataSpecs, + + -- mkBuild, mkListFilter, + + -- re-export a few helpful things + mkPreludeCoreName, nullSpecEnv, + + IdInfo, ArityInfo, DemandInfo, SpecEnv, StrictnessInfo, + UpdateInfo, ArgUsageInfo, ArgUsage, DeforestInfo, FBTypeInfo, + FBType, FBConsum, FBProd, + OptIdInfo(..), -- class + noIdInfo, + mkArityInfo, arityMaybe, + noInfo_UF, mkUnfolding, UnfoldingGuidance(..), UnfoldingDetails, + + -- and to make the interface self-sufficient... + Outputable(..), NamedThing(..), + ExportFlag, SrcLoc, Unique, + Pretty(..), PprStyle, PrettyRep, + -- urgh: because their instances go out w/ Outputable(..) + BasicLit, CoreBinding, CoreCaseAlternatives, CoreArg, + CoreCaseDefault, CoreExpr, CoreAtom, TyVarEnv(..), + IdEnv(..), UniqFM, +#ifdef DPH + CoreParQuals, + CoreParCommunicate, +#endif {- Data Parallel Haskell -} + + PrimOp(..), -- NB: non-abstract + PrimKind(..), -- NB: non-abstract + Name(..), -- NB: non-abstract + UniType(..), -- Mega-NB: non-abstract + + Class, ClassOp, Id, FullName, ShortName, TyCon, TyVarTemplate, + TyVar, Arity(..), TauType(..), ThetaType(..), SigmaType(..), + CostCentre, GlobalSwitch, Maybe, BinderInfo, PlainCoreExpr(..), + PlainCoreAtom(..), InstTemplate, Demand, Bag + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +import AbsUniType ( mkDataTyCon, mkPrimTyCon, + specialiseTy, splitType, applyTyCon, + alpha_tv, alpha, beta_tv, beta, gamma_tv, + gamma, alpha_tyvar, alpha_ty, beta_tyvar, + beta_ty, gamma_tyvar, gamma_ty, delta_tv, + delta, epsilon_tv, epsilon, delta_tyvar, + delta_ty, epsilon_tyvar, epsilon_ty, TyVar, + TyVarTemplate, Class, ClassOp, TyCon, + Arity(..), ThetaType(..), TauType(..), + SigmaType(..), UniType, InstTemplate + IF_ATTACK_PRAGMAS(COMMA pprUniType) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar) + ) +import Id ( mkPreludeId, mkSpecId, mkDataCon, getIdUniType, + mkTemplateLocals, DataCon(..) + ) +import IdInfo -- lots +import Maybes ( Maybe(..) ) +import Name ( Name(..) ) +import NameTypes ( mkShortName, mkPreludeCoreName, ShortName, FullName ) +import Outputable +import PlainCore +import Pretty +import PrimKind ( PrimKind(..) ) +import PrimOps ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import SrcLoc ( mkBuiltinSrcLoc, SrcLoc ) +import TysPrim ( charPrimTy, intPrimTy, doublePrimTy ) +import UniType ( UniType(..) -- **** CAN SEE THE CONSTRUCTORS **** + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Util +\end{code} + +\begin{code} +pRELUDE = SLIT("Prelude") +pRELUDE_BUILTIN = SLIT("PreludeBuiltin") +pRELUDE_CORE = SLIT("PreludeCore") +pRELUDE_RATIO = SLIT("PreludeRatio") +pRELUDE_LIST = SLIT("PreludeList") +--OLD:pRELUDE_ARRAY = SLIT("PreludeArray") +pRELUDE_TEXT = SLIT("PreludeText") +--OLD:pRELUDE_COMPLEX = SLIT("PreludeComplex") +pRELUDE_PRIMIO = SLIT("PreludePrimIO") +pRELUDE_IO = SLIT("PreludeIO") +pRELUDE_PS = SLIT("PreludePS") +gLASGOW_ST = SLIT("PreludeGlaST") +--gLASGOW_IO = SLIT("PreludeGlaIO") +gLASGOW_MISC = SLIT("PreludeGlaMisc") +\end{code} + +\begin{code} +-- things for TyCons ----------------------------------------------------- + +pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> [Id] -> TyCon +pcDataTyCon key mod name tyvars cons + = mkDataTyCon key full_name arity tyvars cons [{-no derivings-}] True + where + arity = length tyvars + full_name = mkPreludeCoreName mod name + +pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimKind] -> PrimKind) -> TyCon +pcPrimTyCon key name arity kind_fn + = mkPrimTyCon key full_name arity kind_fn + where + full_name = mkPreludeCoreName pRELUDE_BUILTIN name +\end{code} + +\begin{code} +-- things for Ids ----------------------------------------------------- + +pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id +pcDataCon key mod name tyvars context arg_tys tycon specenv + = mkDataCon key (mkPreludeCoreName mod name) tyvars context arg_tys tycon specenv + +pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> UniType -> IdInfo -> Id + +pcMiscPrelId key mod name ty info + = mkPreludeId key (mkPreludeCoreName mod name) ty info +\end{code} + +@mkBuild@ is suger for building a build ! +@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@ +@ty@ is the type of the list. +@tv@ is always a new type variable. +@c,n@ are Id's for the abstract cons and nil +\begin{verbatim} + c :: a -> b -> b + n :: b + v :: (\/ b . (a -> b -> b) -> b -> b) -> [a] +-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] +\end{verbatim} +@e@ is the object right inside the @build@ + +\begin{code} +--LATER: mkBuild :: UniType +--LATER: -> TyVar +--LATER: -> Id +--LATER: -> Id +--LATER: -> PlainCoreExpr +--LATER: -> PlainCoreExpr +--LATER: mkBuild ty tv c n expr +--LATER: = CoApp (CoTyApp (CoVar buildId) ty) +--LATER: (CoTyLam tv (mkCoLam [c,n] expr)) +--LATER: -- CoCon buildDataCon [ty] [CoTyLam tv (mkCoLam [c,n] expr)] +\end{code} + +\begin{code} +--LATER: mkListFilter tys args ty ity c n exp +--LATER: = foldr CoTyLam +--LATER: (CoLam args (mkBuild ty ity c n exp)) +--LATER: tys +\end{code} + + +%************************************************************************ +%* * +\subsection[PrelFuns-specialisations]{Specialisations for builtin values} +%* * +%************************************************************************ + +The specialisations which exist for the builtin values must be recorded in +their IdInfos. + +HACK: We currently use the same unique for the specialised Ids. + +The list @specing_types@ determines the types for which specialised +versions are created. Note: This should correspond with the +@SpecingTypes@ in hscpp.prl. + +ToDo: Automatic generation of required specialised versions. + +\begin{code} +pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv +pcGenerateSpecs key id info ty + = pc_gen_specs True key id info ty + +pcGenerateDataSpecs :: UniType -> SpecEnv +pcGenerateDataSpecs ty + = pc_gen_specs False err err err ty + where + err = panic "PrelFuns:GenerateDataSpecs" + + +pc_gen_specs is_id key id info ty + = mkSpecEnv spec_infos + where + spec_infos = [ let spec_ty = specialiseTy ty ty_maybes 0 + spec_id = if is_id + then mkSpecId key {- HACK WARNING: same unique! -} + id ty_maybes spec_ty info + else panic "SpecData:SpecInfo:SpecId" + in + SpecInfo ty_maybes (length ctxts) spec_id + | ty_maybes <- tail (cross_product (length tyvars) specing_types) ] + + -- N.B. tail removes fully polymorphic specialisation + + (tyvars, ctxts, _) = splitType ty + + cross_product 0 tys = panic "PrelFuns:cross_product" + cross_product 1 tys = map (:[]) tys + cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys] + + +-- Note: The Just types should correspond to SpecingTypes in hscpp.prl + +specing_types = [Nothing, + Just charPrimTy, + Just doublePrimTy, + Just intPrimTy ] +\end{code} diff --git a/ghc/compiler/prelude/PrelVals.hi b/ghc/compiler/prelude/PrelVals.hi new file mode 100644 index 0000000..9f146df --- /dev/null +++ b/ghc/compiler/prelude/PrelVals.hi @@ -0,0 +1,61 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PrelVals where +import CoreSyn(CoreExpr) +import Id(Id) +import PreludePS(_PackedString) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +aBSENT_ERROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +buildId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eRROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +errorTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +foldlId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +foldrId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +forkId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerMinusOneId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerPlusOneId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerZeroId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-} +mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-} +pAR_ERROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pAT_ERROR_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pRELUDE_FB :: _PackedString + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +packStringForCId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +parId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +pc_bottoming_Id :: Unique -> _PackedString -> _PackedString -> UniType -> Id + {-# GHC_PRAGMA _A_ 0 _U_ 2222 _N_ _N_ _N_ _N_ #-} +realWorldPrimId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +runSTId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +seqId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +tRACE_ID :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpackCStringAppendId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unpackCStringId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +voidPrimId :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs new file mode 100644 index 0000000..47a4dbe --- /dev/null +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -0,0 +1,652 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[PrelVals]{Prelude values the compiler ``knows about''} + +\begin{code} +#include "HsVersions.h" + +module PrelVals where + +import PrelFuns -- help functions, types and things +import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) +import TysPrim +import TysWiredIn +#ifdef DPH +import TyPod ( mkPodNTy ,mkPodTy ) +import TyProcs ( mkProcessorTy ) +#endif {- Data Parallel Haskell -} + +#ifndef DPH +import AbsUniType +import Id ( mkTemplateLocals, mkTupleCon, getIdUniType, + mkSpecId + ) +#else +import AbsUniType ( mkSigmaTy, mkDictTy, mkTyVarTy , SigmaType(..), + applyTyCon, splitType, specialiseTy + ) +import Id ( mkTemplateLocals, mkTupleCon, getIdUniType, + mkSpecId, mkProcessorCon + ) +#endif {- Data Parallel Haskell -} +import IdInfo + +import Maybes ( Maybe(..) ) +import PlainCore -- to make unfolding templates +import Unique -- *Key things +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-error-related]{@error@ and friends; @trace@} +%* * +%************************************************************************ + +GHC randomly injects these into the code. + +@patError#@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absent#@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absent#@ (rather a totally random crash). + +@parError#@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. + +\begin{code} +pc_bottoming_Id key mod name ty + = pcMiscPrelId key mod name ty bottoming_info + where + bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo + -- these "bottom" out, no matter what their arguments + +eRROR_ID + = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy + +pAT_ERROR_ID + = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy + +aBSENT_ERROR_ID + = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#") + (mkSigmaTy [alpha_tv] [] alpha) + +pAR_ERROR_ID + = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#") + (mkSigmaTy [alpha_tv] [] alpha) noIdInfo + +errorTy :: UniType +errorTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha) +\end{code} + +We want \tr{_trace} (NB: name not in user namespace) to be wired in +because we don't want the strictness analyser to get ahold of it, +decide that the second argument is strict, evaluate that first (!!), +and make a jolly old mess. Having \tr{_trace} wired in also helps when +attempting to re-export it---because it's in \tr{PreludeBuiltin}, it +won't get an \tr{import} declaration in the interface file, so the +importing-subsequently module needs to know it's magic. +\begin{code} +tRACE_ID + = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy + (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) + where + traceTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) (UniFun alpha alpha)) +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-Integer-support]{To support @Integer@ and @String@ literals} +%* * +%************************************************************************ + +\begin{code} +{- OLD: +int2IntegerId + = pcMiscPrelId int2IntegerIdKey pRELUDE_BUILTIN SLIT("_int2Integer") + (UniFun intTy integerTy) + noIdInfo +-} + +-------------------------------------------------------------------- + +unpackCStringId + = pcMiscPrelId unpackCStringIdKey pRELUDE_PS SLIT("unpackPS#") + (UniFun addrPrimTy{-a char *-} stringTy) noIdInfo + +-------------------------------------------------------------------- +unpackCStringAppendId + = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#") + (addrPrimTy{-a "char *" pointer-} + `UniFun` (stringTy + `UniFun` stringTy)) noIdInfo + +-------------------------------------------------------------------- + +packStringForCId + = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC") + (UniFun stringTy byteArrayPrimTy) noIdInfo +\end{code} + +OK, this is Will's idea: we should have magic values for Integers 0, ++1, and -1 (go ahead, fire me): +\begin{code} +integerZeroId + = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("_integer_0") integerTy noIdInfo +integerPlusOneId + = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("_integer_1") integerTy noIdInfo +integerMinusOneId + = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("_integer_m1") integerTy noIdInfo +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-parallel]{@seq@ and @par@: for parallel operation (only)} +%* * +%************************************************************************ + +In the definitions that follow, we use the @TyVar@-based +alpha/beta/gamma types---not the usual @TyVarTemplate@ ones. + +This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match +up with those in the types of the {\em lambda-bound} template-locals +we create (using types @alpha_ty@, etc.). + +\begin{code} +-------------------------------------------------------------------- +-- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to +-- dangerousEval +{- + OLDER: + _seq_ = /\ a b -> \ x y -> case x of { _ -> y } + + OLD: + _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' } + + NEW (95/05): + _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; } + +-} + +seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") + (mkSigmaTy [alpha_tv, beta_tv] [] + (alpha `UniFun` (beta `UniFun` beta))) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template)) + where + [x, y, z] + = mkTemplateLocals [ + {-x-} alpha_ty, + {-y-} beta_ty, + {-z-} intPrimTy + ] + + seq_template + = CoTyLam alpha_tyvar + (CoTyLam beta_tyvar + (mkCoLam [x, y] ( + CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) ( + CoPrimAlts + [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)] + (CoBindDefault z (CoVar y)))))) + +-------------------------------------------------------------------- +-- parId :: "_par_", also used w/ GRIP, etc. +{- + OLDER: + + par = /\ a b -> \ x y -> case (par# (case x of { _ -> () })) of { _ -> y } + + OLD: + + _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' } + + NEW (95/05): + + _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; } + +-} +parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_") + (mkSigmaTy [alpha_tv, beta_tv] [] + (alpha `UniFun` (beta `UniFun` beta))) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template)) + where + [x, y, z] + = mkTemplateLocals [ + {-x-} alpha_ty, + {-y-} beta_ty, + {-z-} intPrimTy + ] + + par_template + = CoTyLam alpha_tyvar + (CoTyLam beta_tyvar + (mkCoLam [x, y] ( + CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) ( + CoPrimAlts + [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)] + (CoBindDefault z (CoVar y)))))) + +-- forkId :: "_fork_", for *required* concurrent threads +{- + _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; } +-} +forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_") + (mkSigmaTy [alpha_tv, beta_tv] [] + (alpha `UniFun` (beta `UniFun` beta))) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template)) + where + [x, y, z] + = mkTemplateLocals [ + {-x-} alpha_ty, + {-y-} beta_ty, + {-z-} intPrimTy + ] + + fork_template + = CoTyLam alpha_tyvar + (CoTyLam beta_tyvar + (mkCoLam [x, y] ( + CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) ( + CoPrimAlts + [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)] + (CoBindDefault z (CoVar y)))))) + +\end{code} + +\begin{code} +#ifdef GRAN + +parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_") + (mkSigmaTy [alpha_tv, beta_tv] [] + (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta)))) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template)) + where + [w, x, y, z] + = mkTemplateLocals [ + {-w-} intPrimTy, + {-x-} alpha_ty, + {-y-} beta_ty, + {-z-} beta_ty + ] + + parLocal_template + = CoTyLam alpha_tyvar + (CoTyLam beta_tyvar + (mkCoLam [w, x, y] ( + CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) ( + CoAlgAlts + [(liftDataCon, [z], CoVar z)] + (CoNoDefault))))) + +parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_") + (mkSigmaTy [alpha_tv, beta_tv] [] + (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta)))) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template)) + where + [w, x, y, z] + = mkTemplateLocals [ + {-w-} intPrimTy, + {-x-} alpha_ty, + {-y-} beta_ty, + {-z-} beta_ty + ] + + parGlobal_template + = CoTyLam alpha_tyvar + (CoTyLam beta_tyvar + (mkCoLam [w, x, y] ( + CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) ( + CoAlgAlts + [(liftDataCon, [z], CoVar z)] + (CoNoDefault))))) + +#endif {-GRAN-} +\end{code} + +\begin{code} +#ifdef DPH +vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap" + (mkSigmaTy [alpha_tv, beta_tv , gamma_tv] + [(pidClass,alpha)] + ((beta `UniFun` gamma) `UniFun` + ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun` + (mkPodTy (mkProcessorTy [alpha] gamma))))) + (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template) + [(2,"","")] + where +{- +vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >> + +Simplified : +vectorMap :: for all a.83, b.82, c.86. + -> (b.82 -> c.86) + -> <> + -> <> +vectorMap = + /\ t83 t82 o86 -> \ dict.127 -> + let + vecMap.128 = + \ fn.129 vec.130 -> + << let si.133 = fn.129 ds.132 in + let + si.134 = + (fromDomain t82) + dict.127 ((toDomain t82) dict.127 ds.131) + in MkProcessor1! Integer o86 si.134 si.133 | + (| ds.131 ; ds.132 |) <<- vec.130 >> + in vecMap.128 + + NOTE : no need to bother with overloading in class Pid; because the result + PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we + use the simplification below. + +Simplified: +vectorMap :: + for all d.83, e.82, f.86. + -> (d.83 -> f.86) -> <> -> <> +vectorMap = + /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 -> + << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) | + (| ds.131 ; ds.132 |) <<- vec.130 >> +-} + + vector_map_template + = let + [dict,fn,vec,ds131,ds132] + = mkTemplateLocals + [mkDictTy pidClass alpha_ty, + beta_ty `UniFun` gamma_ty, + mkPodTy (mkProcessorTy [alpha_ty] beta_ty), + integerTy, + beta_ty] + in + CoTyLam alpha_tyvar + (CoTyLam beta_tyvar + (CoTyLam gamma_tyvar + (mkCoLam [dict,fn,vec] + (CoZfExpr + (CoCon (mkProcessorCon 1) + [integerTy,mkTyVarTy gamma_tyvar] + [CoVar ds131, + (CoApp (CoVar fn) (CoVar ds132))]) + (CoDrawnGen [ds131] ds132 (CoVar vec)) )))) + +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifdef DPH +-- A function used during podization that produces an index POD for a given +-- POD as argument. + +primIfromPodNSelectorId :: Int -> Int -> Id +primIfromPodNSelectorId i n + = pcMiscPrelId + podSelectorIdKey + pRELUDE_BUILTIN + ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector") + (UniFun + (mkPodNTy n alpha) + (mkPodNTy n alpha)) + noIdInfo +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls} +%* * +%************************************************************************ + +map :: (a -> b) -> [a] -> [b] + -- this is up in the here-because-of-unfolding list + +--??showChar :: Char -> ShowS +showSpace :: ShowS -- non-std: == "showChar ' '" +showString :: String -> ShowS +showParen :: Bool -> ShowS -> ShowS + +(++) :: [a] -> [a] -> [a] +readParen :: Bool -> ReadS a -> ReadS a +lex :: ReadS String + +\begin{code} +{- OLD: +readS_ty :: UniType -> UniType +readS_ty ty + = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy])) + +showS_ty :: UniType +showS_ty = UniFun stringTy stringTy +-} +\end{code} + +\begin{code} +{- OLD: +showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace") + showS_ty + noIdInfo + +showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen") + (boolTy `UniFun` (showS_ty `UniFun` showS_ty)) + noIdInfo + +readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen") + (mkSigmaTy [alpha_tv] [] ( + boolTy `UniFun` ( + (readS_ty alpha) `UniFun` (readS_ty alpha)))) + noIdInfo + +lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex") + (readS_ty (mkListTy charTy)) + noIdInfo +-} +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@} +%* * +%************************************************************************ + +I don't think this is available to the user; it's used in the +simplifier (WDP 94/06). +\begin{code} +voidPrimId + = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#") + voidPrimTy noIdInfo +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function} +%* * +%************************************************************************ + +@_runST@ has a non-Haskell-able type: +\begin{verbatim} +-- _runST :: forall a. (forall s. _ST s a) -> a +-- which is to say :: +-- forall a. (forall s. (_State s -> (a, _State s))) -> a + +_runST a m = case m _RealWorld (S# _RealWorld realWorld#) of + (r :: a, wild :: _State _RealWorld) -> r +\end{verbatim} +We unfold always, just for simplicity: +\begin{code} +runSTId + = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info + where + s_tv = beta_tv + s = beta + + st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a) + + run_ST_ty + = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha) + -- NB: rank-2 polymorphism! (forall inside the st_ty...) + + id_info + = noIdInfo + `addInfo` mkArityInfo 1 + `addInfo` mkStrictnessInfo [WwStrict] Nothing + -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template) + -- see example below +{- OUT: + [m, t, r, wild] + = mkTemplateLocals [ + {-m-} st_ty alpha_ty, + {-t-} realWorldStateTy, + {-r-} alpha_ty, + {-_-} realWorldStateTy + ] + + run_ST_template + = CoTyLam alpha_tyvar + (mkCoLam [m] ( + CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) ( + CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) ( + CoAlgAlts + [(mkTupleCon 2, [r, wild], CoVar r)] + CoNoDefault)))) +-} +\end{code} + +SLPJ 95/04: Why @_runST@ must not have an unfolding; consider: +\begin{verbatim} +f x = + _runST ( \ s -> let + (a, s') = newArray# 100 [] s + (_, s'') = fill_in_array_or_something a x s' + in + freezeArray# a s'' ) +\end{verbatim} +If we inline @_runST@, we'll get: +\begin{verbatim} +f x = let + (a, s') = newArray# 100 [] realWorld#{-NB-} + (_, s'') = fill_in_array_or_something a x s' + in + freezeArray# a s'' +\end{verbatim} +And now the @newArray#@ binding can be floated to become a CAF, which +is totally and utterly wrong: +\begin{verbatim} +f = let + (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! + in + \ x -> + let (_, s'') = fill_in_array_or_something a x s' in + freezeArray# a s'' +\end{verbatim} +All calls to @f@ will share a {\em single} array! End SLPJ 95/04. + +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@BasicLit@). +\begin{code} +realWorldPrimId + = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#") + realWorldStatePrimTy + noIdInfo +\end{code} + +%************************************************************************ +%* * +\subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''} +%* * +%************************************************************************ + +\begin{code} +buildId + = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy + (((noIdInfo + `addInfo_UF` mkMagicUnfolding SLIT("build")) + `addInfo` mkStrictnessInfo [WwStrict] Nothing) + `addInfo` mkArgUsageInfo [ArgUsage 2]) + -- cheating, but since _build never actually exists ... + where + -- The type of this strange object is: + -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] + + buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha)) + where + buildUniTy = mkSigmaTy [beta_tv] [] + ((alpha `UniFun` (beta `UniFun` beta)) + `UniFun` (beta `UniFun` beta)) +\end{code} + +@mkBuild@ is sugar for building a build! + +@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@ +@ty@ is the type of the list. +@tv@ is always a new type variable. +@c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument. + c :: a -> b -> b + n :: b + v :: (\/ b . (a -> b -> b) -> b -> b) -> [a] +-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] +@e@ is the object right inside the @build@ + +\begin{code} +mkBuild :: UniType + -> TyVar + -> Id + -> Id + -> Id + -> PlainCoreExpr -- template + -> PlainCoreExpr -- template + +mkBuild ty tv c n g expr + = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr))) + (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g)) +\end{code} + +mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y .. + +\begin{code} +foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") + foldrTy idInfo + where + foldrTy = + mkSigmaTy [alpha_tv, beta_tv] [] + ((alpha `UniFun` (beta `UniFun` beta)) + `UniFun` (beta + `UniFun` ((mkListTy alpha) + `UniFun` beta))) + + idInfo = ((((noIdInfo + `addInfo_UF` mkMagicUnfolding SLIT("foldr")) + `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) + `addInfo` mkArityInfo 3) + `addInfo` mkUpdateInfo [2,2,1]) + +mkFoldr a b f z xs = foldl CoApp + (mkCoTyApps (CoVar foldrId) [a, b]) + [CoVarAtom f,CoVarAtom z,CoVarAtom xs] + +foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") + foldlTy idInfo + where + foldlTy = + mkSigmaTy [alpha_tv, beta_tv] [] + ((alpha `UniFun` (beta `UniFun` alpha)) + `UniFun` (alpha + `UniFun` ((mkListTy beta) + `UniFun` alpha))) + + idInfo = ((((noIdInfo + `addInfo_UF` mkMagicUnfolding SLIT("foldl")) + `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) + `addInfo` mkArityInfo 3) + `addInfo` mkUpdateInfo [2,2,1]) + +mkFoldl a b f z xs = foldl CoApp + (mkCoTyApps (CoVar foldlId) [a, b]) + [CoVarAtom f,CoVarAtom z,CoVarAtom xs] + +pRELUDE_FB = SLIT("PreludeFoldrBuild") +\end{code} diff --git a/ghc/compiler/prelude/PrimKind.hi b/ghc/compiler/prelude/PrimKind.hi new file mode 100644 index 0000000..bcaa943 --- /dev/null +++ b/ghc/compiler/prelude/PrimKind.hi @@ -0,0 +1,50 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PrimKind where +import Class(Class) +import Id(DataCon(..), Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(FullName) +import Outputable(Outputable) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +type DataCon = Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +getKindInfo :: PrimKind -> ([Char], UniType, TyCon) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +getKindSize :: PrimKind -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +guessPrimKind :: [Char] -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isFloatingKind :: PrimKind -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 20 \ (u0 :: PrimKind) -> case u0 of { _ALG_ _ORIG_ PrimKind DoubleKind -> _!_ True [] []; _ORIG_ PrimKind FloatKind -> _!_ True [] []; (u1 :: PrimKind) -> _!_ False [] [] } _N_ #-} +isFollowableKind :: PrimKind -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +retKindSize :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +showPrimKind :: PrimKind -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-} +instance Eq PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ord PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Outputable PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_ + ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/prelude/PrimKind.lhs b/ghc/compiler/prelude/PrimKind.lhs new file mode 100644 index 0000000..872fcc5 --- /dev/null +++ b/ghc/compiler/prelude/PrimKind.lhs @@ -0,0 +1,279 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1995 +% +\section[PrimKind]{Primitive machine-level kinds of things.} + +At various places in the back end, we want to be to tag things with a +``primitive kind''---i.e., the machine-manipulable implementation +types. + +\begin{code} +#include "HsVersions.h" + +module PrimKind ( + PrimKind(..), + separateByPtrFollowness, isFollowableKind, isFloatingKind, + getKindSize, retKindSize, + getKindInfo, -- ToDo: DIE DIE DIE DIE DIE + showPrimKind, + guessPrimKind, + + -- and to make the interface self-sufficient... + Id, DataCon(..), TyCon, UniType + ) where + +IMPORT_Trace + +#ifdef DPH +import TyPod +#endif {- Data Parallel Haskell -} + +import AbsUniType -- we use more than I want to type in... +import Id ( Id, DataCon(..) ) +import Outputable -- class for printing, forcing +import TysPrim +import Pretty -- pretty-printing code +import Util + +#ifndef DPH +#include "../../includes/GhcConstants.h" +#else +#include "../dphsystem/imports/DphConstants.h" +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PrimKind-datatype]{The @PrimKind@ datatype} +%* * +%************************************************************************ + +\begin{code} +data PrimKind + = -- These pointer-kinds are all really the same, but we keep + -- them separate for documentation purposes. + PtrKind -- Pointer to a closure; a ``word''. + | CodePtrKind -- Pointer to code + | DataPtrKind -- Pointer to data + | RetKind -- Pointer to code or data (return vector or code pointer) + | InfoPtrKind -- Pointer to info table (DPH only?) + | CostCentreKind -- Pointer to a cost centre + + | CharKind -- Machine characters + | IntKind -- integers (at least 32 bits) + | WordKind -- ditto (but *unsigned*) + | AddrKind -- addresses ("C pointers") + | FloatKind -- floats + | DoubleKind -- doubles + + | MallocPtrKind -- This has to be a special kind because ccall + -- generates special code when passing/returning + -- one of these. [ADR] + + | StablePtrKind -- We could replace this with IntKind but maybe + -- there's some documentation gain from having + -- it special? [ADR] + + | ArrayKind -- Primitive array of Haskell pointers + | ByteArrayKind -- Primitive array of bytes (no Haskell pointers) + + | VoidKind -- Occupies no space at all! + -- (Primitive states are mapped onto this) +#ifdef DPH + | PodNKind Int PrimKind +#endif {- Data Parallel Haskell -} + deriving (Eq, Ord) + -- Kinds are used in PrimTyCons, which need both Eq and Ord + -- Text is needed for derived-Text on PrimitiveOps +\end{code} + +%************************************************************************ +%* * +\subsection[PrimKind-predicates]{Follow-ness, sizes, and such---on @PrimitiveKinds@} +%* * +%************************************************************************ + +Whether or not the thing is a pointer that the garbage-collector +should follow. + +Or, to put it another (less confusing) way, whether the object in +question is a heap object. + +\begin{code} +isFollowableKind :: PrimKind -> Bool +isFollowableKind PtrKind = True +isFollowableKind ArrayKind = True +isFollowableKind ByteArrayKind = True +isFollowableKind MallocPtrKind = True + +isFollowableKind StablePtrKind = False +-- StablePtrs aren't followable because they are just indices into a +-- table for which explicit allocation/ deallocation is required. + +isFollowableKind other = False + +separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a]) +separateByPtrFollowness kind_fun things + = sep_things kind_fun things [] [] + -- accumulating params for follow-able and don't-follow things... + where + sep_things kfun [] bs us = (reverse bs, reverse us) + sep_things kfun (t:ts) bs us + = if (isFollowableKind . kfun) t then + sep_things kfun ts (t:bs) us + else + sep_things kfun ts bs (t:us) +\end{code} + +@isFloatingKind@ is used to distinguish @Double@ and @Float@ which +cause inadvertent numeric conversions if you aren't jolly careful. +See codeGen/CgCon:cgTopRhsCon. + +\begin{code} +isFloatingKind :: PrimKind -> Bool +isFloatingKind DoubleKind = True +isFloatingKind FloatKind = True +isFloatingKind other = False +\end{code} + +\begin{code} +getKindSize :: PrimKind -> Int +getKindSize DoubleKind = DOUBLE_SIZE -- "words", of course +--getKindSize FloatKind = 1 +--getKindSize CharKind = 1 -- ToDo: count in bytes? +--getKindSize ArrayKind = 1 -- Listed specifically for *documentation* +--getKindSize ByteArrayKind = 1 + +#ifdef DPH +getKindSize (PodNKind _ _) = panic "getKindSize: PodNKind" +#endif {- Data Parallel Haskell -} + +getKindSize VoidKind = 0 +getKindSize other = 1 + + +retKindSize :: Int +retKindSize = getKindSize RetKind +\end{code} + +%************************************************************************ +%* * +\subsection[PrimKind-type-fns]{@PrimitiveKinds@ and @UniTypes@} +%* * +%************************************************************************ + +@PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need +to reconstruct various type information. (It's slightly more +convenient/efficient to make type info from kinds, than kinds [etc.] +from type info.) + +\begin{code} +getKindInfo :: + PrimKind -> (String, -- tag string + UniType, TyCon) -- prim type and tycon + +getKindInfo CharKind = ("Char", charPrimTy, charPrimTyCon) +getKindInfo IntKind = ("Int", intPrimTy, intPrimTyCon) +getKindInfo WordKind = ("Word", wordPrimTy, wordPrimTyCon) +getKindInfo AddrKind = ("Addr", addrPrimTy, addrPrimTyCon) +getKindInfo FloatKind = ("Float", floatPrimTy, floatPrimTyCon) +getKindInfo DoubleKind = ("Double", doublePrimTy, doublePrimTyCon) +#ifdef DPH +getKindInfo k@(PodNKind d kind) + = case kind of + PtrKind ->(no_no, no_no, no_no, no_no, no_no, no_no) + CharKind ->("Char.Pod"++show d, mkPodizedPodNTy d charPrimTy, + no_no, mkPodizedPodNTy d charTy, no_no, no_no) + + IntKind ->("Int.Pod"++show d, mkPodizedPodNTy d intPrimTy, + no_no, mkPodizedPodNTy d intTy, no_no , no_no) + + FloatKind ->("Float.Pod"++show d, mkPodizedPodNTy d floatPrimTy, + no_no ,mkPodizedPodNTy d floatTy, no_no, no_no) + + DoubleKind->("Double.Pod"++show d, mkPodizedPodNTy d doublePrimTy, + no_no, mkPodizedPodNTy d doubleTy, no_no, no_no) + AddrKind ->("Addr.Pod"++show d, mkPodizedPodNTy d addrPrimTy, + no_no, no_no, no_no, no_no) + _ -> pprPanic "Found PodNKind" (ppr PprDebug k) + where + no_no = panic "getKindInfo: PodNKind" + +getKindInfo other = pprPanic "getKindInfo" (ppr PprDebug other) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PrimKind-instances]{Boring instance decls for @PrimKind@} +%* * +%************************************************************************ + +\begin{code} +instance Outputable PrimKind where +#ifdef DPH + ppr sty (PodNKind d k) = ppBesides [ppr sty k , ppStr ".POD" , ppr sty d] +#endif {- Data Parallel Haskell -} + ppr sty kind = ppStr (showPrimKind kind) + +showPrimKind :: PrimKind -> String +guessPrimKind :: String -> PrimKind -- a horrible "inverse" function + +showPrimKind PtrKind = "P_" -- short for StgPtr + +showPrimKind CodePtrKind = "P_" -- DEATH to StgFunPtr! (94/02/22 WDP) + -- but aren't code pointers and function pointers different sizes + -- on some machines (eg 80x86)? ADR + -- Are you trying to ruin my life, or what? (WDP) + +showPrimKind DataPtrKind = "D_" +showPrimKind RetKind = "StgRetAddr" +showPrimKind InfoPtrKind = "StgInfoPtr" +showPrimKind CostCentreKind = "CostCentre" +showPrimKind CharKind = "StgChar" +showPrimKind IntKind = "I_" -- short for StgInt +showPrimKind WordKind = "W_" -- short for StgWord +showPrimKind AddrKind = "StgAddr" +showPrimKind FloatKind = "StgFloat" +showPrimKind DoubleKind = "StgDouble" +showPrimKind ArrayKind = "StgArray" -- see comment below +showPrimKind ByteArrayKind = "StgByteArray" +showPrimKind StablePtrKind = "StgStablePtr" +showPrimKind MallocPtrKind = "StgPtr" -- see comment below +showPrimKind VoidKind = "!!VOID_KIND!!" + +guessPrimKind "D_" = DataPtrKind +guessPrimKind "StgRetAddr" = RetKind +guessPrimKind "StgInfoPtr" = InfoPtrKind +guessPrimKind "StgChar" = CharKind +guessPrimKind "I_" = IntKind +guessPrimKind "W_" = WordKind +guessPrimKind "StgAddr" = AddrKind +guessPrimKind "StgFloat" = FloatKind +guessPrimKind "StgDouble" = DoubleKind +guessPrimKind "StgArray" = ArrayKind +guessPrimKind "StgByteArray" = ByteArrayKind +guessPrimKind "StgStablePtr" = StablePtrKind +\end{code} + +All local C variables of @ArrayKind@ are declared in C as type +@StgArray@. The coercion to a more precise C type is done just before +indexing (by the relevant C primitive-op macro). + +Nota Bene. There are three types associated with Malloc Pointers: +\begin{itemize} +\item +@StgMallocClosure@ is the type of the thing the C world gives us. +(This typename is hardwired into @ppr_casm_results@ in +@PprAbsC.lhs@.) + +\item +@StgMallocPtr@ is the type of the thing we give the C world. + +\item +@StgPtr@ is the type of the (pointer to the) heap object which we +pass around inside the STG machine. +\end{itemize} + +It is really easy to confuse the two. (I'm not sure this choice of +type names helps.) [ADR] diff --git a/ghc/compiler/prelude/PrimOps.hi b/ghc/compiler/prelude/PrimOps.hi new file mode 100644 index 0000000..cc35ae3 --- /dev/null +++ b/ghc/compiler/prelude/PrimOps.hi @@ -0,0 +1,65 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PrimOps where +import Class(Class) +import HeapOffs(HeapOffset) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(Outputable) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import PrimKind(PrimKind) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data HeapOffset +data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp +data PrimOpInfo = Dyadic _PackedString UniType | Monadic _PackedString UniType | Compare _PackedString UniType | Coerce _PackedString UniType UniType | PrimResult _PackedString [TyVarTemplate] [UniType] TyCon PrimKind [UniType] | AlgResult _PackedString [TyVarTemplate] [UniType] TyCon [UniType] +data PrimOpResultInfo = ReturnsPrim PrimKind | ReturnsAlg TyCon +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +fragilePrimOp :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isCompareOp :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +primOpCanTriggerGC :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +primOpHeapReq :: PrimOp -> HeapRequirement + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +primOpId :: PrimOp -> Id + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +primOpIsCheap :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +primOpNameInfo :: PrimOp -> (_PackedString, Name) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +primOpNeedsWrapper :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +primOpOkForSpeculation :: PrimOp -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +showPrimOp :: PprStyle -> PrimOp -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +tagOf_PrimOp :: PrimOp -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfPrimOp :: PrimOp -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} + diff --git a/ghc/compiler/prelude/PrimOps.lhs b/ghc/compiler/prelude/PrimOps.lhs new file mode 100644 index 0000000..99e4cdb --- /dev/null +++ b/ghc/compiler/prelude/PrimOps.lhs @@ -0,0 +1,1663 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[PrimOps]{Primitive operations (machine-level)} + +\begin{code} +#include "HsVersions.h" + +module PrimOps ( + PrimOp(..), + tagOf_PrimOp, -- ToDo: rm + primOpNameInfo, primOpId, + typeOfPrimOp, isCompareOp, + primOpCanTriggerGC, primOpNeedsWrapper, + primOpOkForSpeculation, primOpIsCheap, + fragilePrimOp, + + PrimOpResultInfo(..), + getPrimOpResultInfo, + + HeapRequirement(..), primOpHeapReq, + + -- export for the Native Code Generator +-- primOpInfo, not exported + PrimOpInfo(..), + + pprPrimOp, showPrimOp, + + -- and to make the interface self-sufficient.... + PrimKind, HeapOffset, Id, Name, TyCon, UniType, TyVarTemplate + ) where + +import PrelFuns -- help stuff for prelude +import PrimKind -- most of it +import TysPrim +import TysWiredIn + +import AbsUniType -- lots of things +import CLabelInfo ( identToC ) +import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) +import BasicLit ( BasicLit(..) ) +import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) +import Id -- lots +import IdInfo -- plenty of this, too +import Maybes ( Maybe(..) ) +import NameTypes ( mkPreludeCoreName, FullName, ShortName ) +import Outputable +import PlainCore -- all of it +import Pretty +import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) +import Unique +import Util +#ifdef DPH +import TyPod +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PrimOps-datatype]{Datatype for @PrimOp@ (an enumeration)} +%* * +%************************************************************************ + +These are in \tr{state-interface.verb} order. + +\begin{code} +data PrimOp + -- dig the FORTRAN/C influence on the names... + + -- comparisons: + + = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp + | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp + | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp + | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp + | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp + | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp + + -- Char#-related ops: + | OrdOp | ChrOp + + -- Int#-related ops: + -- IntAbsOp unused?? ADR + | IntAddOp | IntSubOp | IntMulOp | IntQuotOp + | IntDivOp | IntRemOp | IntNegOp | IntAbsOp + + -- Word#-related ops: + | AndOp | OrOp | NotOp + | SllOp | SraOp | SrlOp -- shift {left,right} {arithmetic,logical} + | ISllOp | ISraOp | ISrlOp -- equivs on Int#s + | Int2WordOp | Word2IntOp -- casts + + -- Addr#-related ops: + | Int2AddrOp | Addr2IntOp -- casts + + -- Float#-related ops: + | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp + | Float2IntOp | Int2FloatOp + + | FloatExpOp | FloatLogOp | FloatSqrtOp + | FloatSinOp | FloatCosOp | FloatTanOp + | FloatAsinOp | FloatAcosOp | FloatAtanOp + | FloatSinhOp | FloatCoshOp | FloatTanhOp + -- not all machines have these available conveniently: + -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp + | FloatPowerOp -- ** op + + -- Double#-related ops: + | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp + | Double2IntOp | Int2DoubleOp + | Double2FloatOp | Float2DoubleOp + + | DoubleExpOp | DoubleLogOp | DoubleSqrtOp + | DoubleSinOp | DoubleCosOp | DoubleTanOp + | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp + | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp + -- not all machines have these available conveniently: + -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp + | DoublePowerOp -- ** op + + -- Integer (and related...) ops: + -- slightly weird -- to match GMP package. + | IntegerAddOp | IntegerSubOp | IntegerMulOp + | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp + + | IntegerCmpOp + + | Integer2IntOp | Int2IntegerOp + | Word2IntegerOp + | Addr2IntegerOp -- "Addr" is *always* a literal string + -- ?? gcd, etc? + + | FloatEncodeOp | FloatDecodeOp + | DoubleEncodeOp | DoubleDecodeOp + + -- primitive ops for primitive arrays + + | NewArrayOp + | NewByteArrayOp PrimKind + + | SameMutableArrayOp + | SameMutableByteArrayOp + + | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs + + | ReadByteArrayOp PrimKind + | WriteByteArrayOp PrimKind + | IndexByteArrayOp PrimKind + | IndexOffAddrOp PrimKind + -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind. + -- This is just a cheesy encoding of a bunch of ops. + -- Note that MallocPtrKind is not included -- the only way of + -- creating a MallocPtr is with a ccall or casm. + + | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp + + | NewSynchVarOp -- for MVars and IVars + | TakeMVarOp | PutMVarOp + | ReadIVarOp | WriteIVarOp + + | MakeStablePtrOp | DeRefStablePtrOp +\end{code} + +A special ``trap-door'' to use in making calls direct to C functions: +\begin{code} + | CCallOp FAST_STRING -- An "unboxed" ccall# to this named function + Bool -- True <=> really a "casm" + Bool -- True <=> might invoke Haskell GC + [UniType] -- Unboxed argument; the state-token + -- argument will have been put *first* + UniType -- Return type; one of the "StateAnd#" types + + -- (... to be continued ... ) +\end{code} + +The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@. +(See @primOpInfo@ for details.) + +Note: that first arg and part of the result should be the system state +token (which we carry around to fool over-zealous optimisers) but +which isn't actually passed. + +For example, we represent +\begin{pseudocode} +((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld) +\end{pseudocode} +by +\begin{pseudocode} +CoCase + ( CoPrim + (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False) + -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse + [] + [w#, sp# i#] + ) + (CoAlgAlts [ ( FloatPrimAndIoWorld, + [f#, w#], + CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#] + ) ] + CoNoDefault + ) +\end{pseudocode} + +Nota Bene: there are some people who find the empty list of types in +the @CoPrim@ somewhat puzzling and would represent the above by +\begin{pseudocode} +CoCase + ( CoPrim + (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False) + -- :: /\ alpha1, alpha2 alpha3, alpha4. + -- alpha1 -> alpha2 -> alpha3 -> alpha4 + [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld] + [w#, sp# i#] + ) + (CoAlgAlts [ ( FloatPrimAndIoWorld, + [f#, w#], + CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#] + ) ] + CoNoDefault + ) +\end{pseudocode} + +But, this is a completely different way of using @CCallOp@. The most +major changes required if we switch to this are in @primOpInfo@, and +the desugarer. The major difficulty is in moving the HeapRequirement +stuff somewhere appropriate. (The advantage is that we could simplify +@CCallOp@ and record just the number of arguments with corresponding +simplifications in reading pragma unfoldings, the simplifier, +instantiation (etc) of core expressions, ... . Maybe we should think +about using it this way?? ADR) + +\begin{code} + -- (... continued from above ... ) + + -- one to support "errorIO" (and, thereby, "error") + | ErrorIOPrimOp + + -- Operation to test two closure addresses for equality (yes really!) + -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT! + | ReallyUnsafePtrEqualityOp + + -- three for parallel stuff + | SeqOp + | ParOp + | ForkOp + + -- two for concurrency + | DelayOp + | WaitOp + +#ifdef GRAN + | ParGlobalOp -- named global par + | ParLocalOp -- named local par + | ParAtOp -- specifies destination of local par + | ParAtForNowOp -- specifies initial destination of global par + | CopyableOp -- marks copyable code + | NoFollowOp -- marks non-followup expression +#endif {-GRAN-} + +#ifdef DPH +-- Shadow all the the above primitive OPs for N dimensioned objects. + | PodNPrimOp Int PrimOp + +-- Primitive conversion functions. + + | Int2PodNOp Int | Char2PodNOp Int | Float2PodNOp Int + | Double2PodNOp Int | String2PodNOp Int + +#endif {-Data Parallel Haskell -} +\end{code} + +Deriving Ix is what we really want! ToDo +(Chk around before deleting...) +\begin{code} +tagOf_PrimOp CharGtOp = (ILIT(1) :: FAST_INT) +tagOf_PrimOp CharGeOp = ILIT( 2) +tagOf_PrimOp CharEqOp = ILIT( 3) +tagOf_PrimOp CharNeOp = ILIT( 4) +tagOf_PrimOp CharLtOp = ILIT( 5) +tagOf_PrimOp CharLeOp = ILIT( 6) +tagOf_PrimOp IntGtOp = ILIT( 7) +tagOf_PrimOp IntGeOp = ILIT( 8) +tagOf_PrimOp IntEqOp = ILIT( 9) +tagOf_PrimOp IntNeOp = ILIT( 10) +tagOf_PrimOp IntLtOp = ILIT( 11) +tagOf_PrimOp IntLeOp = ILIT( 12) +tagOf_PrimOp WordGtOp = ILIT( 13) +tagOf_PrimOp WordGeOp = ILIT( 14) +tagOf_PrimOp WordEqOp = ILIT( 15) +tagOf_PrimOp WordNeOp = ILIT( 16) +tagOf_PrimOp WordLtOp = ILIT( 17) +tagOf_PrimOp WordLeOp = ILIT( 18) +tagOf_PrimOp AddrGtOp = ILIT( 19) +tagOf_PrimOp AddrGeOp = ILIT( 20) +tagOf_PrimOp AddrEqOp = ILIT( 21) +tagOf_PrimOp AddrNeOp = ILIT( 22) +tagOf_PrimOp AddrLtOp = ILIT( 23) +tagOf_PrimOp AddrLeOp = ILIT( 24) +tagOf_PrimOp FloatGtOp = ILIT( 25) +tagOf_PrimOp FloatGeOp = ILIT( 26) +tagOf_PrimOp FloatEqOp = ILIT( 27) +tagOf_PrimOp FloatNeOp = ILIT( 28) +tagOf_PrimOp FloatLtOp = ILIT( 29) +tagOf_PrimOp FloatLeOp = ILIT( 30) +tagOf_PrimOp DoubleGtOp = ILIT( 31) +tagOf_PrimOp DoubleGeOp = ILIT( 32) +tagOf_PrimOp DoubleEqOp = ILIT( 33) +tagOf_PrimOp DoubleNeOp = ILIT( 34) +tagOf_PrimOp DoubleLtOp = ILIT( 35) +tagOf_PrimOp DoubleLeOp = ILIT( 36) +tagOf_PrimOp OrdOp = ILIT( 37) +tagOf_PrimOp ChrOp = ILIT( 38) +tagOf_PrimOp IntAddOp = ILIT( 39) +tagOf_PrimOp IntSubOp = ILIT( 40) +tagOf_PrimOp IntMulOp = ILIT( 41) +tagOf_PrimOp IntQuotOp = ILIT( 42) +tagOf_PrimOp IntDivOp = ILIT( 43) +tagOf_PrimOp IntRemOp = ILIT( 44) +tagOf_PrimOp IntNegOp = ILIT( 45) +tagOf_PrimOp IntAbsOp = ILIT( 46) +tagOf_PrimOp AndOp = ILIT( 47) +tagOf_PrimOp OrOp = ILIT( 48) +tagOf_PrimOp NotOp = ILIT( 49) +tagOf_PrimOp SllOp = ILIT( 50) +tagOf_PrimOp SraOp = ILIT( 51) +tagOf_PrimOp SrlOp = ILIT( 52) +tagOf_PrimOp ISllOp = ILIT( 53) +tagOf_PrimOp ISraOp = ILIT( 54) +tagOf_PrimOp ISrlOp = ILIT( 55) +tagOf_PrimOp Int2WordOp = ILIT( 56) +tagOf_PrimOp Word2IntOp = ILIT( 57) +tagOf_PrimOp Int2AddrOp = ILIT( 58) +tagOf_PrimOp Addr2IntOp = ILIT( 59) +tagOf_PrimOp FloatAddOp = ILIT( 60) +tagOf_PrimOp FloatSubOp = ILIT( 61) +tagOf_PrimOp FloatMulOp = ILIT( 62) +tagOf_PrimOp FloatDivOp = ILIT( 63) +tagOf_PrimOp FloatNegOp = ILIT( 64) +tagOf_PrimOp Float2IntOp = ILIT( 65) +tagOf_PrimOp Int2FloatOp = ILIT( 66) +tagOf_PrimOp FloatExpOp = ILIT( 67) +tagOf_PrimOp FloatLogOp = ILIT( 68) +tagOf_PrimOp FloatSqrtOp = ILIT( 69) +tagOf_PrimOp FloatSinOp = ILIT( 70) +tagOf_PrimOp FloatCosOp = ILIT( 71) +tagOf_PrimOp FloatTanOp = ILIT( 72) +tagOf_PrimOp FloatAsinOp = ILIT( 73) +tagOf_PrimOp FloatAcosOp = ILIT( 74) +tagOf_PrimOp FloatAtanOp = ILIT( 75) +tagOf_PrimOp FloatSinhOp = ILIT( 76) +tagOf_PrimOp FloatCoshOp = ILIT( 77) +tagOf_PrimOp FloatTanhOp = ILIT( 78) +tagOf_PrimOp FloatPowerOp = ILIT( 79) +tagOf_PrimOp DoubleAddOp = ILIT( 80) +tagOf_PrimOp DoubleSubOp = ILIT( 81) +tagOf_PrimOp DoubleMulOp = ILIT( 82) +tagOf_PrimOp DoubleDivOp = ILIT( 83) +tagOf_PrimOp DoubleNegOp = ILIT( 84) +tagOf_PrimOp Double2IntOp = ILIT( 85) +tagOf_PrimOp Int2DoubleOp = ILIT( 86) +tagOf_PrimOp Double2FloatOp = ILIT( 87) +tagOf_PrimOp Float2DoubleOp = ILIT( 88) +tagOf_PrimOp DoubleExpOp = ILIT( 89) +tagOf_PrimOp DoubleLogOp = ILIT( 90) +tagOf_PrimOp DoubleSqrtOp = ILIT( 91) +tagOf_PrimOp DoubleSinOp = ILIT( 92) +tagOf_PrimOp DoubleCosOp = ILIT( 93) +tagOf_PrimOp DoubleTanOp = ILIT( 94) +tagOf_PrimOp DoubleAsinOp = ILIT( 95) +tagOf_PrimOp DoubleAcosOp = ILIT( 96) +tagOf_PrimOp DoubleAtanOp = ILIT( 97) +tagOf_PrimOp DoubleSinhOp = ILIT( 98) +tagOf_PrimOp DoubleCoshOp = ILIT( 99) +tagOf_PrimOp DoubleTanhOp = ILIT(100) +tagOf_PrimOp DoublePowerOp = ILIT(101) +tagOf_PrimOp IntegerAddOp = ILIT(102) +tagOf_PrimOp IntegerSubOp = ILIT(103) +tagOf_PrimOp IntegerMulOp = ILIT(104) +tagOf_PrimOp IntegerQuotRemOp = ILIT(105) +tagOf_PrimOp IntegerDivModOp = ILIT(106) +tagOf_PrimOp IntegerNegOp = ILIT(107) +tagOf_PrimOp IntegerCmpOp = ILIT(108) +tagOf_PrimOp Integer2IntOp = ILIT(109) +tagOf_PrimOp Int2IntegerOp = ILIT(110) +tagOf_PrimOp Word2IntegerOp = ILIT(111) +tagOf_PrimOp Addr2IntegerOp = ILIT(112) +tagOf_PrimOp FloatEncodeOp = ILIT(113) +tagOf_PrimOp FloatDecodeOp = ILIT(114) +tagOf_PrimOp DoubleEncodeOp = ILIT(115) +tagOf_PrimOp DoubleDecodeOp = ILIT(116) +tagOf_PrimOp NewArrayOp = ILIT(117) +tagOf_PrimOp (NewByteArrayOp CharKind) = ILIT(118) +tagOf_PrimOp (NewByteArrayOp IntKind) = ILIT(119) +tagOf_PrimOp (NewByteArrayOp AddrKind) = ILIT(120) +tagOf_PrimOp (NewByteArrayOp FloatKind) = ILIT(121) +tagOf_PrimOp (NewByteArrayOp DoubleKind)= ILIT(122) +tagOf_PrimOp SameMutableArrayOp = ILIT(123) +tagOf_PrimOp SameMutableByteArrayOp = ILIT(124) +tagOf_PrimOp ReadArrayOp = ILIT(125) +tagOf_PrimOp WriteArrayOp = ILIT(126) +tagOf_PrimOp IndexArrayOp = ILIT(127) +tagOf_PrimOp (ReadByteArrayOp CharKind) = ILIT(128) +tagOf_PrimOp (ReadByteArrayOp IntKind) = ILIT(129) +tagOf_PrimOp (ReadByteArrayOp AddrKind) = ILIT(130) +tagOf_PrimOp (ReadByteArrayOp FloatKind) = ILIT(131) +tagOf_PrimOp (ReadByteArrayOp DoubleKind) = ILIT(132) +tagOf_PrimOp (WriteByteArrayOp CharKind) = ILIT(133) +tagOf_PrimOp (WriteByteArrayOp IntKind) = ILIT(134) +tagOf_PrimOp (WriteByteArrayOp AddrKind) = ILIT(135) +tagOf_PrimOp (WriteByteArrayOp FloatKind) = ILIT(136) +tagOf_PrimOp (WriteByteArrayOp DoubleKind) = ILIT(137) +tagOf_PrimOp (IndexByteArrayOp CharKind) = ILIT(138) +tagOf_PrimOp (IndexByteArrayOp IntKind) = ILIT(139) +tagOf_PrimOp (IndexByteArrayOp AddrKind) = ILIT(140) +tagOf_PrimOp (IndexByteArrayOp FloatKind) = ILIT(141) +tagOf_PrimOp (IndexByteArrayOp DoubleKind) = ILIT(142) +tagOf_PrimOp (IndexOffAddrOp CharKind) = ILIT(143) +tagOf_PrimOp (IndexOffAddrOp IntKind) = ILIT(144) +tagOf_PrimOp (IndexOffAddrOp AddrKind) = ILIT(145) +tagOf_PrimOp (IndexOffAddrOp FloatKind) = ILIT(146) +tagOf_PrimOp (IndexOffAddrOp DoubleKind) = ILIT(147) +tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(148) +tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(149) +tagOf_PrimOp NewSynchVarOp = ILIT(150) +tagOf_PrimOp TakeMVarOp = ILIT(151) +tagOf_PrimOp PutMVarOp = ILIT(152) +tagOf_PrimOp ReadIVarOp = ILIT(153) +tagOf_PrimOp WriteIVarOp = ILIT(154) +tagOf_PrimOp MakeStablePtrOp = ILIT(155) +tagOf_PrimOp DeRefStablePtrOp = ILIT(156) +tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(157) +tagOf_PrimOp ErrorIOPrimOp = ILIT(158) +tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(159) +tagOf_PrimOp SeqOp = ILIT(160) +tagOf_PrimOp ParOp = ILIT(161) +tagOf_PrimOp ForkOp = ILIT(162) +tagOf_PrimOp DelayOp = ILIT(163) +tagOf_PrimOp WaitOp = ILIT(164) + +#ifdef GRAN +tagOf_PrimOp ParGlobalOp = ILIT(165) +tagOf_PrimOp ParLocalOp = ILIT(166) +tagOf_PrimOp ParAtOp = ILIT(167) +tagOf_PrimOp ParAtForNowOp = ILIT(168) +tagOf_PrimOp CopyableOp = ILIT(169) +tagOf_PrimOp NoFollowOp = ILIT(170) +#endif {-GRAN-} + +#ifdef DPH +tagOf_PrimOp (PodNPrimOp _ _) = panic "ToDo:DPH:tagOf_PrimOp" +tagOf_PrimOp (Int2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp" +tagOf_PrimOp (Char2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp" +tagOf_PrimOp (Float2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp" +tagOf_PrimOp (Double2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp" +tagOf_PrimOp (String2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp" +#endif {-Data Parallel Haskell -} + +-- avoid BUG +tagOf_PrimOp _ = case (panic "tagOf_PrimOp: pattern-match") of { o -> + tagOf_PrimOp o + } + +instance Eq PrimOp where + op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2 +\end{code} + +%************************************************************************ +%* * +\subsection[PrimOps-info]{The essential info about each @PrimOp@} +%* * +%************************************************************************ + +The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may +refer to the primitive operation. The conventional \tr{#}-for- +unboxed ops is added on later. + +The reason for the funny characters in the names is so we do not +interfere with the programmer's Haskell name spaces. + +We use @PrimKinds@ for the ``type'' information, because they're +(slightly) more convenient to use than @TyCons@. +\begin{code} +data PrimOpInfo + = Dyadic FAST_STRING -- string :: T -> T -> T + UniType + | Monadic FAST_STRING -- string :: T -> T + UniType + | Compare FAST_STRING -- string :: T -> T -> Bool + UniType + | Coerce FAST_STRING -- string :: T1 -> T2 + UniType + UniType + + | PrimResult FAST_STRING + [TyVarTemplate] [UniType] TyCon PrimKind [UniType] + -- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]" + -- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm) + -- D# is a primitive type constructor. + -- (the kind is the same info as D#, in another convenient form) + + | AlgResult FAST_STRING + [TyVarTemplate] [UniType] TyCon [UniType] + -- "AlgResult tvs [t1,..,tn] T [s1,..,sm]" + -- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm) + +-- ToDo: Specialised calls to PrimOps are prohibited but may be desirable + +#ifdef DPH + | PodNInfo Int + PrimOpInfo +#endif {- Data Parallel Haskell -} +\end{code} + +Utility bits: +\begin{code} +one_Integer_ty = [intPrimTy, intPrimTy, byteArrayPrimTy] +two_Integer_tys + = [intPrimTy, intPrimTy, byteArrayPrimTy, -- first Integer pieces + intPrimTy, intPrimTy, byteArrayPrimTy] -- second '' pieces +an_Integer_and_Int_tys + = [intPrimTy, intPrimTy, byteArrayPrimTy, -- Integer + intPrimTy] + +integerMonadic name = AlgResult name [] one_Integer_ty integerTyCon [] + +integerDyadic name = AlgResult name [] two_Integer_tys integerTyCon [] + +integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon [] + +integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntKind [] +\end{code} + +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. + +\begin{code} +primOpInfo :: PrimOp -> PrimOpInfo +\end{code} + +There's plenty of this stuff! + +%************************************************************************ +%* * +\subsubsection[PrimOps-comparison]{PrimOpInfo basic comparison ops} +%* * +%************************************************************************ + +\begin{code} +primOpInfo CharGtOp = Compare SLIT("gtChar#") charPrimTy +primOpInfo CharGeOp = Compare SLIT("geChar#") charPrimTy +primOpInfo CharEqOp = Compare SLIT("eqChar#") charPrimTy +primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy +primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy +primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy + +primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy +primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy +primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy +primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy +primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy +primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy + +primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy +primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy +primOpInfo WordEqOp = Compare SLIT("eqWord#") wordPrimTy +primOpInfo WordNeOp = Compare SLIT("neWord#") wordPrimTy +primOpInfo WordLtOp = Compare SLIT("ltWord#") wordPrimTy +primOpInfo WordLeOp = Compare SLIT("leWord#") wordPrimTy + +primOpInfo AddrGtOp = Compare SLIT("gtAddr#") addrPrimTy +primOpInfo AddrGeOp = Compare SLIT("geAddr#") addrPrimTy +primOpInfo AddrEqOp = Compare SLIT("eqAddr#") addrPrimTy +primOpInfo AddrNeOp = Compare SLIT("neAddr#") addrPrimTy +primOpInfo AddrLtOp = Compare SLIT("ltAddr#") addrPrimTy +primOpInfo AddrLeOp = Compare SLIT("leAddr#") addrPrimTy + +primOpInfo FloatGtOp = Compare SLIT("gtFloat#") floatPrimTy +primOpInfo FloatGeOp = Compare SLIT("geFloat#") floatPrimTy +primOpInfo FloatEqOp = Compare SLIT("eqFloat#") floatPrimTy +primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy +primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy +primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy + +primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy +primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy +primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy +primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy +primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy +primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Char]{PrimOpInfo for @Char#@s} +%* * +%************************************************************************ + +\begin{code} +primOpInfo OrdOp = Coerce SLIT("ord#") charPrimTy intPrimTy +primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Int]{PrimOpInfo for @Int#@s} +%* * +%************************************************************************ + +\begin{code} +primOpInfo IntAddOp = Dyadic SLIT("plusInt#") intPrimTy +primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy +primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy +primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy +primOpInfo IntDivOp = Dyadic SLIT("divInt#") intPrimTy +primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy + +primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Word]{PrimOpInfo for @Word#@s} +%* * +%************************************************************************ + +A @Word#@ is an unsigned @Int#@. + +\begin{code} +primOpInfo AndOp = Dyadic SLIT("and#") wordPrimTy +primOpInfo OrOp = Dyadic SLIT("or#") wordPrimTy +primOpInfo NotOp = Monadic SLIT("not#") wordPrimTy + +primOpInfo SllOp + = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind [] +primOpInfo SraOp + = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind [] +primOpInfo SrlOp + = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind [] + +primOpInfo ISllOp + = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind [] +primOpInfo ISraOp + = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind [] +primOpInfo ISrlOp + = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind [] + +primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy +primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Addr]{PrimOpInfo for @Addr#@s} +%* * +%************************************************************************ + +\begin{code} +primOpInfo Int2AddrOp = Coerce SLIT("int2Addr#") intPrimTy addrPrimTy +primOpInfo Addr2IntOp = Coerce SLIT("addr2Int#") addrPrimTy intPrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Float]{PrimOpInfo for @Float#@s} +%* * +%************************************************************************ + +@encodeFloat#@ and @decodeFloat#@ are given w/ Integer-stuff (it's +similar). + +\begin{code} +primOpInfo FloatAddOp = Dyadic SLIT("plusFloat#") floatPrimTy +primOpInfo FloatSubOp = Dyadic SLIT("minusFloat#") floatPrimTy +primOpInfo FloatMulOp = Dyadic SLIT("timesFloat#") floatPrimTy +primOpInfo FloatDivOp = Dyadic SLIT("divideFloat#") floatPrimTy +primOpInfo FloatNegOp = Monadic SLIT("negateFloat#") floatPrimTy + +primOpInfo Float2IntOp = Coerce SLIT("float2Int#") floatPrimTy intPrimTy +primOpInfo Int2FloatOp = Coerce SLIT("int2Float#") intPrimTy floatPrimTy + +primOpInfo FloatExpOp = Monadic SLIT("expFloat#") floatPrimTy +primOpInfo FloatLogOp = Monadic SLIT("logFloat#") floatPrimTy +primOpInfo FloatSqrtOp = Monadic SLIT("sqrtFloat#") floatPrimTy +primOpInfo FloatSinOp = Monadic SLIT("sinFloat#") floatPrimTy +primOpInfo FloatCosOp = Monadic SLIT("cosFloat#") floatPrimTy +primOpInfo FloatTanOp = Monadic SLIT("tanFloat#") floatPrimTy +primOpInfo FloatAsinOp = Monadic SLIT("asinFloat#") floatPrimTy +primOpInfo FloatAcosOp = Monadic SLIT("acosFloat#") floatPrimTy +primOpInfo FloatAtanOp = Monadic SLIT("atanFloat#") floatPrimTy +primOpInfo FloatSinhOp = Monadic SLIT("sinhFloat#") floatPrimTy +primOpInfo FloatCoshOp = Monadic SLIT("coshFloat#") floatPrimTy +primOpInfo FloatTanhOp = Monadic SLIT("tanhFloat#") floatPrimTy +primOpInfo FloatPowerOp = Dyadic SLIT("powerFloat#") floatPrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Double]{PrimOpInfo for @Double#@s} +%* * +%************************************************************************ + +@encodeDouble#@ and @decodeDouble#@ are given w/ Integer-stuff (it's +similar). + +\begin{code} +primOpInfo DoubleAddOp = Dyadic SLIT("plusDouble#") doublePrimTy +primOpInfo DoubleSubOp = Dyadic SLIT("minusDouble#") doublePrimTy +primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy +primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") doublePrimTy +primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy + +primOpInfo Double2IntOp = Coerce SLIT("double2Int#") doublePrimTy intPrimTy +primOpInfo Int2DoubleOp = Coerce SLIT("int2Double#") intPrimTy doublePrimTy + +primOpInfo Double2FloatOp = Coerce SLIT("double2Float#") doublePrimTy floatPrimTy +primOpInfo Float2DoubleOp = Coerce SLIT("float2Double#") floatPrimTy doublePrimTy + +primOpInfo DoubleExpOp = Monadic SLIT("expDouble#") doublePrimTy +primOpInfo DoubleLogOp = Monadic SLIT("logDouble#") doublePrimTy +primOpInfo DoubleSqrtOp = Monadic SLIT("sqrtDouble#") doublePrimTy +primOpInfo DoubleSinOp = Monadic SLIT("sinDouble#") doublePrimTy +primOpInfo DoubleCosOp = Monadic SLIT("cosDouble#") doublePrimTy +primOpInfo DoubleTanOp = Monadic SLIT("tanDouble#") doublePrimTy +primOpInfo DoubleAsinOp = Monadic SLIT("asinDouble#") doublePrimTy +primOpInfo DoubleAcosOp = Monadic SLIT("acosDouble#") doublePrimTy +primOpInfo DoubleAtanOp = Monadic SLIT("atanDouble#") doublePrimTy +primOpInfo DoubleSinhOp = Monadic SLIT("sinhDouble#") doublePrimTy +primOpInfo DoubleCoshOp = Monadic SLIT("coshDouble#") doublePrimTy +primOpInfo DoubleTanhOp = Monadic SLIT("tanhDouble#") doublePrimTy +primOpInfo DoublePowerOp= Dyadic SLIT("powerDouble#") doublePrimTy +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Integer]{PrimOpInfo for @Integer@ (and related!)} +%* * +%************************************************************************ + +\begin{code} +primOpInfo IntegerNegOp = integerMonadic SLIT("negateInteger#") + +primOpInfo IntegerAddOp = integerDyadic SLIT("plusInteger#") +primOpInfo IntegerSubOp = integerDyadic SLIT("minusInteger#") +primOpInfo IntegerMulOp = integerDyadic SLIT("timesInteger#") + +primOpInfo IntegerCmpOp = integerCompare SLIT("cmpInteger#") + +primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#") +primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#") + +primOpInfo Integer2IntOp + = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntKind [] + +primOpInfo Int2IntegerOp + = AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon [] + +primOpInfo Word2IntegerOp + = AlgResult SLIT("word2Integer#") [] [wordPrimTy] integerTyCon [] + +primOpInfo Addr2IntegerOp + = AlgResult SLIT("addr2Integer#") [] [addrPrimTy] integerTyCon [] +\end{code} + +Encoding and decoding of floating-point numbers is sorta +Integer-related. + +\begin{code} +primOpInfo FloatEncodeOp + = PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys + floatPrimTyCon FloatKind [] + +primOpInfo DoubleEncodeOp + = PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys + doublePrimTyCon DoubleKind [] + +primOpInfo FloatDecodeOp + = AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon [] + +primOpInfo DoubleDecodeOp + = AlgResult SLIT("decodeDouble#") [] [doublePrimTy] returnIntAndGMPTyCon [] +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Arrays]{PrimOpInfo for primitive arrays} +%* * +%************************************************************************ + +\begin{code} +primOpInfo NewArrayOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s] + stateAndMutableArrayPrimTyCon [s, elt] + +primOpInfo (NewByteArrayOp kind) + = let + s = alpha; s_tv = alpha_tv + + (str, _, prim_tycon) = getKindInfo kind + + op_str = _PK_ ("new" ++ str ++ "Array#") + in + AlgResult op_str [s_tv] + [intPrimTy, mkStatePrimTy s] + stateAndMutableByteArrayPrimTyCon [s] + +--------------------------------------------------------------------------- + +primOpInfo SameMutableArrayOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv; + mut_arr_ty = mkMutableArrayPrimTy s elt + } in + AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty] + boolTyCon [] + +primOpInfo SameMutableByteArrayOp + = let { + s = alpha; s_tv = alpha_tv; + mut_arr_ty = mkMutableByteArrayPrimTy s + } in + AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty] + boolTyCon [] + +--------------------------------------------------------------------------- +-- Primitive arrays of Haskell pointers: + +primOpInfo ReadArrayOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("readArray#") [s_tv, elt_tv] + [mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s] + stateAndPtrPrimTyCon [s, elt] + + +primOpInfo WriteArrayOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + PrimResult SLIT("writeArray#") [s_tv, elt_tv] + [mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s] + statePrimTyCon VoidKind [s] + +primOpInfo IndexArrayOp + = let { elt = alpha; elt_tv = alpha_tv } in + AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy] + liftTyCon [elt] + +--------------------------------------------------------------------------- +-- Primitive arrays full of unboxed bytes: + +primOpInfo (ReadByteArrayOp kind) + = let + s = alpha; s_tv = alpha_tv + + (str, _, prim_tycon) = getKindInfo kind + + op_str = _PK_ ("read" ++ str ++ "Array#") + relevant_tycon = assoc "primOpInfo" tbl kind + in + AlgResult op_str [s_tv] + [mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s] + relevant_tycon [s] + where + tbl = [ (CharKind, stateAndCharPrimTyCon), + (IntKind, stateAndIntPrimTyCon), + (AddrKind, stateAndAddrPrimTyCon), + (FloatKind, stateAndFloatPrimTyCon), + (DoubleKind, stateAndDoublePrimTyCon) ] + + -- How come there's no Word byte arrays? ADR + +primOpInfo (WriteByteArrayOp kind) + = let + s = alpha; s_tv = alpha_tv + + (str, prim_ty, _) = getKindInfo kind + op_str = _PK_ ("write" ++ str ++ "Array#") + in + -- NB: *Prim*Result -- + PrimResult op_str [s_tv] + [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s] + statePrimTyCon VoidKind [s] + +primOpInfo (IndexByteArrayOp kind) + = let + (str, _, prim_tycon) = getKindInfo kind + op_str = _PK_ ("index" ++ str ++ "Array#") + in + -- NB: *Prim*Result -- + PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind [] + +primOpInfo (IndexOffAddrOp kind) + = let + (str, _, prim_tycon) = getKindInfo kind + op_str = _PK_ ("index" ++ str ++ "OffAddr#") + in + PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind [] + +--------------------------------------------------------------------------- +primOpInfo UnsafeFreezeArrayOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv] + [mkMutableArrayPrimTy s elt, mkStatePrimTy s] + stateAndArrayPrimTyCon [s, elt] + +primOpInfo UnsafeFreezeByteArrayOp + = let { s = alpha; s_tv = alpha_tv } in + AlgResult SLIT("unsafeFreezeByteArray#") [s_tv] + [mkMutableByteArrayPrimTy s, mkStatePrimTy s] + stateAndByteArrayPrimTyCon [s] +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-SynchVars]{PrimOpInfo for synchronizing Variables} +%* * +%************************************************************************ + +\begin{code} +primOpInfo NewSynchVarOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s] + stateAndSynchVarPrimTyCon [s, elt] + +primOpInfo TakeMVarOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("takeMVar#") [s_tv, elt_tv] + [mkSynchVarPrimTy s elt, mkStatePrimTy s] + stateAndPtrPrimTyCon [s, elt] + +primOpInfo PutMVarOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("putMVar#") [s_tv, elt_tv] + [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s] + statePrimTyCon [s] + +primOpInfo ReadIVarOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("readIVar#") [s_tv, elt_tv] + [mkSynchVarPrimTy s elt, mkStatePrimTy s] + stateAndPtrPrimTyCon [s, elt] + +primOpInfo WriteIVarOp + = let { + elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv + } in + AlgResult SLIT("writeIVar#") [s_tv, elt_tv] + [mkSynchVarPrimTy s elt, elt, mkStatePrimTy s] + statePrimTyCon [s] + +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-Wait]{PrimOpInfo for delay/wait operations} +%* * +%************************************************************************ + +\begin{code} + +primOpInfo DelayOp + = let { + s = alpha; s_tv = alpha_tv + } in + PrimResult SLIT("delay#") [s_tv] + [intPrimTy, mkStatePrimTy s] + statePrimTyCon VoidKind [s] + +primOpInfo WaitOp + = let { + s = alpha; s_tv = alpha_tv + } in + PrimResult SLIT("wait#") [s_tv] + [intPrimTy, mkStatePrimTy s] + statePrimTyCon VoidKind [s] + +\end{code} + + +%************************************************************************ +%* * +\subsubsection[PrimOps-stable-pointers]{PrimOpInfo for ``stable pointers''} +%* * +%************************************************************************ + +A {\em stable pointer} is an index into a table of pointers into the +heap. Since the garbage collector is told about stable pointers, it +is safe to pass a stable pointer to external systems such as C +routines. + +Here's what the operations and types are supposed to be (from +state-interface document). + +\begin{verbatim} +makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a +freeStablePointer# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld +deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a +\end{verbatim} + +It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@ +operation since it doesn't (directly) involve IO operations. The +reason is that if some optimisation pass decided to duplicate calls to +@makeStablePtr#@ and we only pass one of the stable pointers over, a +massive space leak can result. Putting it into the PrimIO monad +prevents this. (Another reason for putting them in a monad is to +ensure correct sequencing wrt the side-effecting @freeStablePointer#@ +operation.) + +Note that we can implement @freeStablePointer#@ using @_ccall_@ (and, +besides, it's not likely to be used from Haskell) so it's not a +primop. + +Question: Why @_RealWorld@ - won't any instance of @_ST@ do the job? [ADR] + +\begin{code} +primOpInfo MakeStablePtrOp + = AlgResult SLIT("makeStablePtr#") [alpha_tv] + [alpha, realWorldStatePrimTy] + stateAndStablePtrPrimTyCon [realWorldTy, alpha] + +primOpInfo DeRefStablePtrOp + = AlgResult SLIT("deRefStablePtr#") [alpha_tv] + [mkStablePtrPrimTy alpha, realWorldStatePrimTy] + stateAndPtrPrimTyCon [realWorldTy, alpha] +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-unsafePointerEquality]{PrimOpInfo for Pointer Equality} +%* * +%************************************************************************ + +[Alastair Reid is to blame for this!] + +These days, (Glasgow) Haskell seems to have a bit of everything from +other languages: strict operations, mutable variables, sequencing, +pointers, etc. About the only thing left is LISP's ability to test +for pointer equality. So, let's add it in! + +\begin{verbatim} +reallyUnsafePtrEquality :: a -> a -> Int# +\end{verbatim} + +which tests any two closures (of the same type) to see if they're the +same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid +difficulties of trying to box up the result.) + +NB This is {\em really unsafe\/} because even something as trivial as +a garbage collection might change the answer by removing indirections. +Still, no-one's forcing you to use it. If you're worried about little +things like loss of referential transparency, you might like to wrap +it all up in a monad-like thing as John O'Donnell and John Hughes did +for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop +Proceedings?) + +I'm thinking of using it to speed up a critical equality test in some +graphics stuff in a context where the possibility of saying that +denotationally equal things aren't isn't a problem (as long as it +doesn't happen too often.) ADR + +To Will: Jim said this was already in, but I can't see it so I'm +adding it. Up to you whether you add it. (Note that this could have +been readily implemented using a @veryDangerousCCall@ before they were +removed...) + +\begin{code} +primOpInfo ReallyUnsafePtrEqualityOp + = PrimResult SLIT("reallyUnsafePtrEquality#") [alpha_tv] + [alpha, alpha] intPrimTyCon IntKind [] +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-parallel]{PrimOpInfo for parallelism op(s)} +%* * +%************************************************************************ + +\begin{code} +primOpInfo SeqOp -- seq# :: a -> Int# + = PrimResult SLIT("seq#") [alpha_tv] [alpha] intPrimTyCon IntKind [] + +primOpInfo ParOp -- par# :: a -> Int# + = PrimResult SLIT("par#") [alpha_tv] [alpha] intPrimTyCon IntKind [] + +primOpInfo ForkOp -- fork# :: a -> Int# + = PrimResult SLIT("fork#") [alpha_tv] [alpha] intPrimTyCon IntKind [] + +\end{code} + +\begin{code} +#ifdef GRAN + +primOpInfo ParGlobalOp -- parGlobal# :: Int -> a -> b -> b + = AlgResult SLIT("parGlobal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta] + +primOpInfo ParLocalOp -- parLocal# :: Int -> a -> b -> b + = AlgResult SLIT("parLocal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta] + +primOpInfo ParAtOp -- parAt# :: Int -> a -> b -> c -> c + = AlgResult SLIT("parAt#") [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma] + +primOpInfo ParAtForNowOp -- parAtForNow# :: Int -> a -> b -> c -> c + = AlgResult SLIT("parAtForNow#") [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma] + +primOpInfo CopyableOp -- copyable# :: a -> a + = AlgResult SLIT("copyable#") [alpha_tv] [alpha] liftTyCon [alpha] + +primOpInfo NoFollowOp -- noFollow# :: a -> a + = AlgResult SLIT("noFollow#") [alpha_tv] [alpha] liftTyCon [alpha] + +#endif {-GRAN-} +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-errorIO]{PrimOpInfo for @errorIO#@} +%* * +%************************************************************************ + +\begin{code} +primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# + = PrimResult SLIT("errorIO#") [] + [mkPrimIoTy unitTy] + statePrimTyCon VoidKind [realWorldTy] +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-IO-etc]{PrimOpInfo for C calls, and I/O-ish things} +%* * +%************************************************************************ + +\begin{code} +primOpInfo (CCallOp _ _ _ arg_tys result_ty) + = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied + where + (result_tycon, tys_applied, _) = getUniDataTyCon result_ty +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOps-DPH]{PrimOpInfo for Data Parallel Haskell} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH +-- ToDo:DPH: various things need doing here + +primOpInfo (Int2PodNOp d) = Coerce ("int2Pod" ++ show d) + IntKind + (PodNKind d IntKind) + +primOpInfo (Char2PodNOp d) = Coerce ("char2Pod" ++ show d) + CharKind + (PodNKind d CharKind) + +primOpInfo (Float2PodNOp d) = Coerce ("float2Pod" ++ show d) + FloatKind + (PodNKind d FloatKind) + +primOpInfo (Double2PodNOp d) = Coerce ("double2Pod" ++ show d) + DoubleKind + (PodNKind d DoubleKind) + +{- +primOpInfo (Integer2PodNOp d) = Coerce ("integer2Pod" ++ show d) + IntegerKind + (PodNKind d IntegerKind) +-} + +primOpInfo (String2PodNOp d) = Coerce ("string2Pod" ++ show d) + LitStringKind + (PodNKind d LitStringKind) + +primOpInfo (PodNPrimOp d p) = PodNInfo d (primOpInfo p) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PrimOps-utils]{Utilities for @PrimitiveOps@} +%* * +%************************************************************************ + +The primitive-array-creation @PrimOps@ and {\em most} of those to do +with @Integers@ can trigger GC. Here we describe the heap requirements +of the various @PrimOps@. For most, no heap is required. For a few, +a fixed amount of heap is required, and the needs of the @PrimOp@ can +be combined with the rest of the heap usage in the basic block. For an +unfortunate few, some unknown amount of heap is required (these are the +ops which can trigger GC). + +\begin{code} +data HeapRequirement + = NoHeapRequired + | FixedHeapRequired HeapOffset + | VariableHeapRequired + +primOpHeapReq :: PrimOp -> HeapRequirement + +primOpHeapReq NewArrayOp = VariableHeapRequired +primOpHeapReq (NewByteArrayOp _)= VariableHeapRequired + +primOpHeapReq IntegerAddOp = VariableHeapRequired +primOpHeapReq IntegerSubOp = VariableHeapRequired +primOpHeapReq IntegerMulOp = VariableHeapRequired +primOpHeapReq IntegerQuotRemOp = VariableHeapRequired +primOpHeapReq IntegerDivModOp = VariableHeapRequired +primOpHeapReq IntegerNegOp = VariableHeapRequired +primOpHeapReq Int2IntegerOp = FixedHeapRequired + (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) + (intOff mIN_MP_INT_SIZE)) +primOpHeapReq Word2IntegerOp = FixedHeapRequired + (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) + (intOff mIN_MP_INT_SIZE)) +primOpHeapReq Addr2IntegerOp = VariableHeapRequired +primOpHeapReq FloatDecodeOp = FixedHeapRequired + (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE)) + (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) + (intOff mIN_MP_INT_SIZE))) +primOpHeapReq DoubleDecodeOp = FixedHeapRequired + (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE)) + (addOff (totHdrSize (DataRep mIN_MP_INT_SIZE)) + (intOff mIN_MP_INT_SIZE))) + +-- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_) +-- or if it returns a MallocPtr. + +primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired +primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty) + = if returnsMallocPtr + then VariableHeapRequired + else NoHeapRequired + where + returnsMallocPtr + = case (getUniDataTyCon_maybe return_ty) of + Nothing -> False + Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon + +-- this occasionally has to expand the Stable Pointer table +primOpHeapReq MakeStablePtrOp = VariableHeapRequired + +-- These four only need heap space with the native code generator +-- ToDo!: parameterize, so we know if native code generation is taking place(JSM) + +primOpHeapReq IntegerCmpOp = FixedHeapRequired (intOff (2 * mP_STRUCT_SIZE)) +primOpHeapReq Integer2IntOp = FixedHeapRequired (intOff mP_STRUCT_SIZE) +primOpHeapReq FloatEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE) +primOpHeapReq DoubleEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE) + +-- a NewSynchVarOp creates a three-word mutuple in the heap. +primOpHeapReq NewSynchVarOp = FixedHeapRequired + (addOff (totHdrSize (MuTupleRep 3)) (intOff 3)) + +-- Sparking ops no longer allocate any heap; however, _fork_ may +-- require a context switch to clear space in the required thread +-- pool, and that requires liveness information. + +primOpHeapReq ParOp = NoHeapRequired +primOpHeapReq ForkOp = VariableHeapRequired + +-- A SeqOp requires unknown space to evaluate its argument +primOpHeapReq SeqOp = VariableHeapRequired + +#ifdef GRAN + +-- a ParGlobalOp creates a single 4-tuple in the heap. ToDo: verify this! +primOpHeapReq ParGlobalOp = trace "primOpHeapReq:ParGlobalOp:verify!" ( + FixedHeapRequired + (addOff (totHdrSize (MuTupleRep 4)) (intOff 4)) + ) + +-- a ParLocalOp creates a single 4-tuple in the heap. ToDo: verify this! +primOpHeapReq ParLocalOp = trace "primOpHeapReq:ParLocalOp:verify!" ( + FixedHeapRequired + (addOff (totHdrSize (MuTupleRep 4)) (intOff 4)) + ) + +-- ToDo: parAt, parAtForNow, copyable, noFollow !! (HWL) +#endif {-GRAN-} + +primOpHeapReq other_op = NoHeapRequired +\end{code} + +Primops which can trigger GC have to be called carefully. +In particular, their arguments are guaranteed to be in registers, +and a liveness mask tells which regs are live. + +\begin{code} +primOpCanTriggerGC op = + case op of + TakeMVarOp -> True + ReadIVarOp -> True + DelayOp -> True + WaitOp -> True + _ -> + case primOpHeapReq op of + VariableHeapRequired -> True + _ -> False + +\end{code} + +Sometimes we may choose to execute a PrimOp even though it isn't +certain that its result will be required; ie execute them +``speculatively''. The same thing as ``cheap eagerness.'' Usually +this is OK, because PrimOps are usually cheap, but it isn't OK for +(a)~expensive PrimOps and (b)~PrimOps which can fail. + +See also @primOpIsCheap@ (below). + +There should be no worries about side effects; that's all taken care +of by data dependencies. + +\begin{code} +primOpOkForSpeculation :: PrimOp -> Bool + +-- Int. +primOpOkForSpeculation IntDivOp = False -- Divide by zero +primOpOkForSpeculation IntQuotOp = False -- Divide by zero +primOpOkForSpeculation IntRemOp = False -- Divide by zero + +-- Integer +primOpOkForSpeculation IntegerQuotRemOp = False -- Divide by zero +primOpOkForSpeculation IntegerDivModOp = False -- Divide by zero + +-- Float. ToDo: tan? tanh? +primOpOkForSpeculation FloatDivOp = False -- Divide by zero +primOpOkForSpeculation FloatLogOp = False -- Log of zero +primOpOkForSpeculation FloatAsinOp = False -- Arg out of domain +primOpOkForSpeculation FloatAcosOp = False -- Arg out of domain + +-- Double. ToDo: tan? tanh? +primOpOkForSpeculation DoubleDivOp = False -- Divide by zero +primOpOkForSpeculation DoubleLogOp = False -- Log of zero +primOpOkForSpeculation DoubleAsinOp = False -- Arg out of domain +primOpOkForSpeculation DoubleAcosOp = False -- Arg out of domain + +-- CCall +primOpOkForSpeculation (CCallOp _ _ _ _ _)= False -- Could be expensive! + +-- errorIO# +primOpOkForSpeculation ErrorIOPrimOp = False -- Could be disastrous! + +-- parallel +primOpOkForSpeculation ParOp = False -- Could be expensive! +primOpOkForSpeculation ForkOp = False -- Likewise +primOpOkForSpeculation SeqOp = False -- Likewise + +#ifdef GRAN +primOpOkForSpeculation ParGlobalOp = False -- Could be expensive! +primOpOkForSpeculation ParLocalOp = False -- Could be expensive! +#endif {-GRAN-} + +-- 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} +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} +fragilePrimOp :: PrimOp -> Bool + +fragilePrimOp ParOp = True +fragilePrimOp ForkOp = True +fragilePrimOp SeqOp = True +fragilePrimOp MakeStablePtrOp = True +fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR + +#ifdef GRAN +fragilePrimOp ParGlobalOp = True +fragilePrimOp ParLocalOp = True +fragilePrimOp CopyableOp = trace "fragilePrimOp:CopyableOp" True -- Possibly not. ASP +fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True -- Possibly not. ASP +#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} +primOpNeedsWrapper :: PrimOp -> Bool + +primOpNeedsWrapper (CCallOp _ _ _ _ _) = True + +primOpNeedsWrapper IntDivOp = True + +primOpNeedsWrapper NewArrayOp = True -- ToDo: for nativeGen only!(JSM) +primOpNeedsWrapper (NewByteArrayOp _) = True + +primOpNeedsWrapper IntegerAddOp = True +primOpNeedsWrapper IntegerSubOp = True +primOpNeedsWrapper IntegerMulOp = True +primOpNeedsWrapper IntegerQuotRemOp = True +primOpNeedsWrapper IntegerDivModOp = True +primOpNeedsWrapper IntegerNegOp = True +primOpNeedsWrapper IntegerCmpOp = True +primOpNeedsWrapper Integer2IntOp = True +primOpNeedsWrapper Int2IntegerOp = True +primOpNeedsWrapper Word2IntegerOp = True +primOpNeedsWrapper Addr2IntegerOp = True + +primOpNeedsWrapper FloatExpOp = True +primOpNeedsWrapper FloatLogOp = True +primOpNeedsWrapper FloatSqrtOp = True +primOpNeedsWrapper FloatSinOp = True +primOpNeedsWrapper FloatCosOp = True +primOpNeedsWrapper FloatTanOp = True +primOpNeedsWrapper FloatAsinOp = True +primOpNeedsWrapper FloatAcosOp = True +primOpNeedsWrapper FloatAtanOp = True +primOpNeedsWrapper FloatSinhOp = True +primOpNeedsWrapper FloatCoshOp = True +primOpNeedsWrapper FloatTanhOp = True +primOpNeedsWrapper FloatPowerOp = True +primOpNeedsWrapper FloatEncodeOp = True +primOpNeedsWrapper FloatDecodeOp = True + +primOpNeedsWrapper DoubleExpOp = True +primOpNeedsWrapper DoubleLogOp = True +primOpNeedsWrapper DoubleSqrtOp = True +primOpNeedsWrapper DoubleSinOp = True +primOpNeedsWrapper DoubleCosOp = True +primOpNeedsWrapper DoubleTanOp = True +primOpNeedsWrapper DoubleAsinOp = True +primOpNeedsWrapper DoubleAcosOp = True +primOpNeedsWrapper DoubleAtanOp = True +primOpNeedsWrapper DoubleSinhOp = True +primOpNeedsWrapper DoubleCoshOp = True +primOpNeedsWrapper DoubleTanhOp = True +primOpNeedsWrapper DoublePowerOp = True +primOpNeedsWrapper DoubleEncodeOp = True +primOpNeedsWrapper DoubleDecodeOp = True + +primOpNeedsWrapper MakeStablePtrOp = True +primOpNeedsWrapper DeRefStablePtrOp = True + +primOpNeedsWrapper TakeMVarOp = True +primOpNeedsWrapper PutMVarOp = True +primOpNeedsWrapper ReadIVarOp = True + +primOpNeedsWrapper DelayOp = True +primOpNeedsWrapper WaitOp = True + +primOpNeedsWrapper other_op = False +\end{code} + +\begin{code} +primOpId :: PrimOp -> Id +primOpNameInfo :: PrimOp -> (FAST_STRING, Name) + +-- the *NameInfo ones are trivial: + +primOpNameInfo op = (primOp_str op, WiredInVal (primOpId op)) + +primOp_str op + = case (primOpInfo op) of + Dyadic str _ -> str + Monadic str _ -> str + Compare str _ -> str + Coerce str _ _ -> str + PrimResult str _ _ _ _ _ -> str + AlgResult str _ _ _ _ -> str +#ifdef DPH + PodNInfo d i -> case i of + Dyadic str _ -> (str ++ ".POD" ++ show d ++ "#") + Monadic str _ -> (str ++ ".POD" ++ show d ++ "#") + Compare str _ -> (str ++ ".POD" ++ show d ++ "#") + Coerce str _ _ -> (str ++ ".POD" ++ show d ++ "#") + PrimResult str _ _ _ _ _ -> (str ++ ".POD" ++ show d) + AlgResult str _ _ _ _ -> (str ++ ".POD" ++ show d) +#endif {- Data Parallel Haskell -} +\end{code} + +@typeOfPrimOp@ duplicates some work of @primOpId@, but since we +grab types pretty often... +\begin{code} +typeOfPrimOp :: PrimOp -> UniType + +#ifdef DPH +typeOfPrimOp (PodNPrimOp d p) + = mkPodizedPodNTy d (typeOfPrimOp p) +#endif {- Data Parallel Haskell -} + +typeOfPrimOp op + = case (primOpInfo op) of + Dyadic str ty -> dyadic_fun_ty ty + Monadic str ty -> monadic_fun_ty ty + Compare str ty -> prim_compare_fun_ty ty + Coerce str ty1 ty2 -> UniFun ty1 ty2 + + PrimResult str tyvars arg_tys prim_tycon kind res_tys -> + mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)) + + AlgResult str tyvars arg_tys tycon res_tys -> + mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)) +\end{code} + +\begin{code} +primOpId op + = case (primOpInfo op) of + Dyadic str ty -> + mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2 + + Monadic str ty -> + mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1 + + Compare str ty -> + mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (prim_compare_fun_ty ty) 2 + + Coerce str ty1 ty2 -> + mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (UniFun ty1 ty2) 1 + + PrimResult str tyvars arg_tys prim_tycon kind res_tys -> + mk_prim_Id op pRELUDE_BUILTIN str + tyvars + arg_tys + (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))) + (length arg_tys) -- arity + + AlgResult str tyvars arg_tys tycon res_tys -> + mk_prim_Id op pRELUDE_BUILTIN str + tyvars + arg_tys + (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))) + (length arg_tys) -- arity + +#ifdef DPH + PodNInfo d i -> panic "primOpId : Oi lazy, PodNInfo needs sorting out" +#endif {- Data Parallel Haskell -} + where + mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity + = mkPreludeId + (mkPrimOpIdUnique prim_op) + (mkPreludeCoreName mod name) + ty + (noIdInfo + `addInfo` (mkArityInfo arity) + `addInfo_UF` (mkUnfolding EssentialUnfolding + (mk_prim_unfold prim_op tyvar_tmpls arg_tys))) +\end{code} + +The functions to make common unfoldings are tedious. + +\begin{code} +mk_prim_unfold :: PrimOp -> [TyVarTemplate] -> [UniType] -> PlainCoreExpr{-template-} + +mk_prim_unfold prim_op tv_tmpls arg_tys + = let + (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls (map getTheUnique tv_tmpls) + inst_arg_tys = map (instantiateTauTy inst_env) arg_tys + vars = mkTemplateLocals inst_arg_tys + in + foldr CoTyLam (mkCoLam vars + (CoPrim prim_op tyvar_tys [CoVarAtom v | v <- vars])) + tyvars +\end{code} + +\begin{code} +data PrimOpResultInfo + = ReturnsPrim PrimKind + | ReturnsAlg TyCon + +-- ToDo: Deal with specialised PrimOps +-- Will need to return specialised tycon and data constructors + +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo + +getPrimOpResultInfo op + = case (primOpInfo op) of + Dyadic _ ty -> ReturnsPrim (kindFromType ty) + Monadic _ ty -> ReturnsPrim (kindFromType ty) + Compare _ ty -> ReturnsAlg boolTyCon + Coerce _ _ ty -> ReturnsPrim (kindFromType ty) + PrimResult _ _ _ _ kind _ -> ReturnsPrim kind + AlgResult _ _ _ tycon _ -> ReturnsAlg tycon +#ifdef DPH + PodNInfo d i -> panic "getPrimOpResultInfo:PodNInfo" +#endif {- Data Parallel Haskell -} + +isCompareOp :: PrimOp -> Bool + +isCompareOp op + = case primOpInfo op of + Compare _ _ -> True + _ -> False +\end{code} + +Utils: +\begin{code} +dyadic_fun_ty ty = ty `UniFun` (ty `UniFun` ty) +monadic_fun_ty ty = ty `UniFun` ty + +compare_fun_ty ty = ty `UniFun` (ty `UniFun` boolTy) +prim_compare_fun_ty ty = ty `UniFun` (ty `UniFun` boolTy) +\end{code} + +Output stuff: +\begin{code} +pprPrimOp :: PprStyle -> PrimOp -> Pretty +showPrimOp :: PprStyle -> PrimOp -> String + +showPrimOp sty op + = ppShow 1000{-random-} (pprPrimOp sty op) + +pprPrimOp sty (CCallOp fun is_casm may_gc arg_tys res_ty) + = let + before + = if is_casm then + if may_gc then "(_casm_GC_ ``" else "(_casm_ ``" + else + if may_gc then "(_ccall_GC_ " else "(_ccall_ " + + after + = if is_casm then ppStr "''" else ppNil + + pp_tys + = ppBesides [ppStr " { [", + ppIntersperse pp'SP{-'-} (map (pprParendUniType sty) arg_tys), + ppRbrack, ppSP, pprParendUniType sty res_ty, ppStr " })"] + + in + ppBesides [ppStr before, ppPStr fun, after, pp_tys] +#ifdef DPH + = fun -- Comment buggers up machine code :-) -- ToDo:DPH +#endif {- Data Parallel Haskell -} + +pprPrimOp sty other_op + = let + str = primOp_str other_op + in + if codeStyle sty + then identToC str + else ppPStr str + +instance Outputable PrimOp where + ppr sty op = pprPrimOp sty op +\end{code} diff --git a/ghc/compiler/prelude/TyPod.lhs b/ghc/compiler/prelude/TyPod.lhs new file mode 100644 index 0000000..c494303 --- /dev/null +++ b/ghc/compiler/prelude/TyPod.lhs @@ -0,0 +1,159 @@ +%************************************************************************ +%* * +\section[TyPod]{The Pod datatype} +%* * +%************************************************************************ +\begin{code} +#include "HsVersions.h" + +module TyPod where + +import PrelFuns -- help functions, types and things +import TyInteger --ToDo:DPH: no such thing any more! +import TyProcs +import TyBool ( boolTy ) +import Unique + +import AbsUniType ( getUniDataTyCon_maybe , mkPodizedPodTyCon ) +import Maybes +\end{code} + +In the implementation of \DPHaskell{} for a SIMD machine, we adopt three +diffrent models of \POD{}s. + +%************************************************************************ +\subsection[User]{The Users model} +%************************************************************************ +The users model of a \POD{} is outlined in ``Data Parallel Haskell: Mixing old +and new glue''\cite{hill:dpglue}. In this model, a \POD{} represents a +collection of index value pairs, where each index uniquely identifies a +single element of a \POD{}. As \POD{}s are an abstraction of the processing +elements of a data parallel machine, we choose to collect the index value +pairs into a data type we call a `processor'. + +The indices of a \POD{} can be thought of as a subset of the +integers\footnote{10/03/93: I've decided to change the index types of \POD{}'s +---they are now Int's {\em not} Integer's. The use of the GMP package has +changed things, Integers are now special, and there's no way I'm going +to have time to implement them on the DAP. I would like Integers to be like +Ints, i.e a single boxed primitive value --- they are'nt like that any more. +I've therefore plumped for Int's as index values, which means indices +are restricted to 32bit signed values.}. We use +the Haskell class system to extend the range of possible types for the indices +such that any type that is an instance of the class {\tt Pid} (processor +identifier) may be used as an index type. + +%************************************************************************ +\subsection[prePodized]{The Core Syntax model before podization} +%************************************************************************ +Desugaring of the abstract syntax introduces the overloaded operators +{\tt fromDomain} and {\tt toDomain} to convert the index types to integers. +We bring the \POD{} type and processor types closer together in the core +syntax; \POD{}s will have types such as {\tt <>} in +which the integer types before the ``;'' determine the position of an +element identified by those integers within a two dimensioned \POD{} +(i.e a matrix). +%************************************************************************ +\subsection[postPodized]{The Core Syntax model after podization} +%************************************************************************ +Things drastically change after podization. There are four different +variety of \POD{}s being used at runtime: +\begin{enumerate} +\item[Interface] A $k$ dimensional Interface \POD{} of $\alpha$'s is + represented by a product type that contains a $k$ dimensional + inside out \POD{} of Boolean values that determine at what + processors the Interface \POD{} is to be defined; and a $k$ + dimensional inside out \POD{} of $\alpha$'s - the \POD{}s that + the user manipulates in \POD{} comprehensions are all + interface \POD{}'s --- see note **1** on efficiency below. + +\item[Podized] The remaining types of \POD{}s are invisible to the user + - See the podization files for more details (even a bit + sketchy their :-( + +\item[Primitive] A $k$ dimensional unboxed \POD{} is a contiguous subset of + primitive unboxed values - these will hopefully be the + staple diet of Data Parallel evaluation. For non SIMD + people, these are just like `C' arrays, except we can apply + primitive parallel operations to them---for example add + two arrays together. + +\item[Hard luck] Hard luck \POD{}s are the ones that we cann't implement in a + parallel manner - see podization files for more details. +\end{enumerate} + +Note **1** : Efficiency of parallel functions. + +There are various (trivial) laws concerning \POD{} comprehensions, such as + +(vectorMap f) . (vectorMap g) == vectorMap (f.g) + +The right of the above expressions is more ``efficient'' because we only +unbox the interface \POD{}, then check for undefined elements once in contrast +to twice in the left expression. Maybe theres some scope here for some +simplifications ?? + +%************************************************************************ +%* * +\section[User_POD]{The ``Users model'' of a Pod} +%* * +%************************************************************************ +\begin{code} +mkPodTy :: UniType -> UniType +mkPodTy ty = UniData podTyCon [ty] + +mkPodNTy:: Int -> UniType -> UniType +mkPodNTy n ty = UniData podTyCon [mkProcessorTy (take n int_tys) ty] + where + int_tys = integerTy : int_tys + +podTyCon = pcDataTyCon podTyConKey pRELUDE_BUILTIN "Pod" [alpha_tv] [] +\end{code} + +%************************************************************************ +%* * +\section[Podized_POD]{The ``Podized model'' of a Pod} +%* * +%************************************************************************ +Theres a small problem with the following code, I wonder if anyone can help?? + +I have defined podized versions of TyCons, by wrapping a TyCon and an Int in +a PodizedTyCon (similiar to technique used for Ids). This is helpfull because +when tycons are attached to cases, they show that they are podized (I want +to preserve the info). TyCons are also used in the unitype world, the problem +being if I want a podized dictionary - I cannt just call getUniDataTyCon +to get me the dictionaries TyCon - it doesnt have one :-( What I've therefore +done is get the tycon out of a unitype if it has one, otherwise I use a +default podizedTyConKey which means the things podized, but dont ask anything +about it - (also for polymorphic types). + +ToDo(hilly): Using @getUniDataTyCon_maybe@ doesnt seem a good way of doing + things... +\begin{code} +mkPodizedPodNTy:: Int -> UniType -> UniType +mkPodizedPodNTy n ty + = case (getUniDataTyCon_maybe ty) of + Nothing ->let tc = pcDataTyCon (podizedPodTyConKey n) pRELUDE_BUILTIN + ("PodizedUnk"++show n) [alpha_tv] [] + in UniData tc [ty] + + Just (tycon,_,_) ->UniData (mkPodizedPodTyCon n tycon) [ty] + +\end{code} +%************************************************************************ +%* * +\section[Podized_POD]{The ``Interface model'' of a Pod} +%* * +%************************************************************************ +\begin{code} +mkInterfacePodNTy n ty + = UniData (interfacePodTyCon n) [mkPodizedPodNTy n ty] + +interfacePodTyCon n + = pcDataTyCon interfacePodTyConKey pRELUDE_BUILTIN + "InterPod" [alpha_tv] [mKINTERPOD_ID n] + +mKINTERPOD_ID n + = pcDataCon interfacePodDataConKey pRELUDE_BUILTIN "MkInterPod" + [] [] [mkPodizedPodNTy n boolTy] (interfacePodTyCon n) nullSpecEnv +\end{code} diff --git a/ghc/compiler/prelude/TyProcs.lhs b/ghc/compiler/prelude/TyProcs.lhs new file mode 100644 index 0000000..546f7e4 --- /dev/null +++ b/ghc/compiler/prelude/TyProcs.lhs @@ -0,0 +1,26 @@ +% +% (c) The GRASP Project, Glasgow University, 1992 +% +\section[TyProcessor]{The processor datatypes} + +This is used only for ``Data Parallel Haskell.'' + +\begin{code} +#include "HsVersions.h" + +module TyProcs where + +import PrelFuns -- help functions, types and things +import PrelUniqs + +import AbsUniType ( applyTyCon, mkProcessorTyCon ) +import Util + +mkProcessorTy :: [UniType] -> UniType -> UniType +mkProcessorTy tys ty + = applyTyCon (mkProcessorTyCon (length tys)) (tys++[ty]) + +processor1TyCon = mkProcessorTyCon (1::Int) +processor2TyCon = mkProcessorTyCon (2::Int) +processor3TyCon = mkProcessorTyCon (3::Int) +\end{code} diff --git a/ghc/compiler/prelude/TysPrim.hi b/ghc/compiler/prelude/TysPrim.hi new file mode 100644 index 0000000..3603479 --- /dev/null +++ b/ghc/compiler/prelude/TysPrim.hi @@ -0,0 +1,67 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TysPrim where +import TyCon(TyCon) +import UniType(UniType) +addrPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +arrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +byteArrayPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +byteArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doublePrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doublePrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mallocPtrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkArrayPrimTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkMutableArrayPrimTy :: UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkMutableByteArrayPrimTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStablePtrPrimTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStatePrimTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkSynchVarPrimTy :: UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mutableArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mutableByteArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldStatePrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysPrim mkStatePrimTy [ _ORIG_ TysPrim realWorldTy ] _N_ #-} +realWorldTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stablePtrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +statePrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +synchVarPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +voidPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordPrimTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs new file mode 100644 index 0000000..d70ed56 --- /dev/null +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -0,0 +1,162 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[TysPrim]{Wired-in knowledge about primitive types} + +This module tracks the ``state interface'' document, ``GHC prelude: +types and operations.'' + +\begin{code} +#include "HsVersions.h" + +module TysPrim where + +import PrelFuns -- help functions, types and things +import PrimKind + +import AbsUniType ( applyTyCon ) +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} +%* * +%************************************************************************ + +\begin{code} +charPrimTy = applyTyCon charPrimTyCon [] +charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharKind) + +intPrimTy = applyTyCon intPrimTyCon [] +intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntKind) + +wordPrimTy = applyTyCon wordPrimTyCon [] +wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordKind) + +addrPrimTy = applyTyCon addrPrimTyCon [] +addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrKind) + +floatPrimTy = applyTyCon floatPrimTyCon [] +floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatKind) + +doublePrimTy = applyTyCon doublePrimTyCon [] +doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleKind) +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-void]{The @Void#@ type} +%* * +%************************************************************************ + +Very similar to the @State#@ type. +\begin{code} +voidPrimTy = applyTyCon voidPrimTyCon [] + where + voidPrimTyCon = pcPrimTyCon voidPrimTyConKey SLIT("Void#") 0 + (\ [] -> VoidKind) +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} +%* * +%************************************************************************ + +\begin{code} +mkStatePrimTy ty = applyTyCon statePrimTyCon [ty] +statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 + (\ [s_kind] -> VoidKind) +\end{code} + +@_RealWorld@ is deeply magical. It {\em is primitive}, but it +{\em is not unboxed}. +\begin{code} +realWorldTy = applyTyCon realWorldTyCon [] +realWorldTyCon + = pcDataTyCon realWorldTyConKey pRELUDE_BUILTIN SLIT("_RealWorld") [] + [{-no data cons!-}] -- we tell you *nothing* about this guy + +realWorldStatePrimTy = mkStatePrimTy realWorldTy +\end{code} + +Note: the ``state-pairing'' types are not truly primitive, so they are +defined in \tr{TysWiredIn.lhs}, not here. + +%************************************************************************ +%* * +\subsection[TysPrim-arrays]{The primitive array types} +%* * +%************************************************************************ + +\begin{code} +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 + (\ [elt_kind] -> ArrayKind) + +byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 + (\ [] -> ByteArrayKind) + +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2 + (\ [s_kind, elt_kind] -> ArrayKind) + +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 + (\ [s_kind] -> ByteArrayKind) + +mkArrayPrimTy elt = applyTyCon arrayPrimTyCon [elt] +byteArrayPrimTy = applyTyCon byteArrayPrimTyCon [] +mkMutableArrayPrimTy s elt = applyTyCon mutableArrayPrimTyCon [s, elt] +mkMutableByteArrayPrimTy s = applyTyCon mutableByteArrayPrimTyCon [s] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-synch-var]{The synchronizing variable type} +%* * +%************************************************************************ + +\begin{code} +synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 + (\ [s_kind, elt_kind] -> PtrKind) + +mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-stable-ptrs]{The stable-pointer type} +%* * +%************************************************************************ + +\begin{code} +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 + (\ [elt_kind] -> StablePtrKind) + +mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-malloc-ptrs]{The ``malloc''-pointer type} +%* * +%************************************************************************ + +``Malloc'' pointers provide a mechanism which will let Haskell's +garbage collector communicate with a {\em simple\/} garbage collector +in the IO world (probably \tr{malloc}, hence the name).We want Haskell +to be able to hold onto references to objects in the IO world and for +Haskell's garbage collector to tell the IO world when these references +become garbage. We are not aiming to provide a mechanism that could +talk to a sophisticated garbage collector such as that provided by a +LISP system (with a correspondingly complex interface); in particular, +we shall ignore the danger of circular structures spread across the +two systems. + +There are no primitive operations on @CHeapPtr#@s (although equality +could possibly be added?) + +\begin{code} +mallocPtrPrimTyCon = pcPrimTyCon mallocPtrPrimTyConKey SLIT("MallocPtr#") 0 + (\ [] -> MallocPtrKind) +\end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.hi b/ghc/compiler/prelude/TysWiredIn.hi new file mode 100644 index 0000000..270b1d6 --- /dev/null +++ b/ghc/compiler/prelude/TysWiredIn.hi @@ -0,0 +1,146 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TysWiredIn where +import Id(Id) +import TyCon(TyCon) +import UniType(UniType) +addrDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +addrTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +boolTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +boolTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +charTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cmpTagTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cmpTagTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +consDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +doubleTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqPrimDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +falseDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +floatTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +getStatePairingConInfo :: UniType -> (Id, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +gtPrimDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +intTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +integerTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +liftDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +liftTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +listTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ltPrimDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mallocPtrTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkLiftTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkListTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkPrimIoTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +mkStateTransformerTy :: UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkTupleTy :: Int -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +nilDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +primIoTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ratioDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ratioTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +rationalTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +rationalTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +realWorldStateTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +return2GMPsTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +returnIntAndGMPTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stablePtrTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndAddrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndByteArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndCharPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndDoublePrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndFloatPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndIntPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMallocPtrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMutableArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndMutableByteArrayPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndPtrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndStablePtrPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndSynchVarPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateAndWordPrimTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stateTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stringTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysWiredIn mkListTy [ _ORIG_ TysWiredIn charTy ] _N_ #-} +stringTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +trueDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +unitTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordDataCon :: Id + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordTy :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +wordTyCon :: TyCon + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs new file mode 100644 index 0000000..ce28587 --- /dev/null +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -0,0 +1,757 @@ +% +% (c) The GRASP Project, Glasgow University, 1994-1995 +% +\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} + +This module is about types that can be defined in Haskell, but which +must be wired into the compiler nonetheless. + +This module tracks the ``state interface'' document, ``GHC prelude: +types and operations.'' + +\begin{code} +#include "HsVersions.h" + +module TysWiredIn ( + addrDataCon, + addrTy, + addrTyCon, + boolTy, + boolTyCon, + charDataCon, + charTy, + charTyCon, + cmpTagTy, + cmpTagTyCon, + consDataCon, + doubleDataCon, + doubleTy, + doubleTyCon, + eqPrimDataCon, + falseDataCon, + floatDataCon, + floatTy, + floatTyCon, + getStatePairingConInfo, + gtPrimDataCon, + intDataCon, + intTy, + intTyCon, + integerTy, + integerTyCon, + liftDataCon, + liftTyCon, + listTyCon, + ltPrimDataCon, + mallocPtrTyCon, + mkLiftTy, + mkListTy, + mkPrimIoTy, + mkStateTransformerTy, + mkTupleTy, + nilDataCon, + primIoTyCon, + ratioDataCon, + ratioTyCon, + rationalTy, + rationalTyCon, + realWorldStateTy, + return2GMPsTyCon, + returnIntAndGMPTyCon, + stTyCon, + stablePtrTyCon, + stateAndAddrPrimTyCon, + stateAndArrayPrimTyCon, + stateAndByteArrayPrimTyCon, + stateAndCharPrimTyCon, + stateAndDoublePrimTyCon, + stateAndFloatPrimTyCon, + stateAndIntPrimTyCon, + stateAndMallocPtrPrimTyCon, + stateAndMutableArrayPrimTyCon, + stateAndMutableByteArrayPrimTyCon, + stateAndPtrPrimTyCon, + stateAndStablePtrPrimTyCon, + stateAndSynchVarPrimTyCon, + stateAndWordPrimTyCon, + stateDataCon, + stateTyCon, + stringTy, + stringTyCon, + trueDataCon, + unitTy, + wordDataCon, + wordTy, + wordTyCon + ) where + +import Pretty --ToDo:rm debugging only + +import PrelFuns -- help functions, types and things +import TysPrim + +import AbsUniType ( applyTyCon, mkTupleTyCon, mkSynonymTyCon, + getUniDataTyCon_maybe, mkSigmaTy, TyCon + , pprUniType --ToDo: rm debugging only + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import IdInfo +import Maybes ( Maybe(..) ) +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} +%* * +%************************************************************************ + +\begin{code} +charTy = UniData charTyCon [] + +charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon] +charDataCon = pcDataCon charDataConKey pRELUDE_BUILTIN SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv +\end{code} + +\begin{code} +intTy = UniData intTyCon [] + +intTyCon = pcDataTyCon intTyConKey pRELUDE_BUILTIN SLIT("Int") [] [intDataCon] +intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv +\end{code} + +\begin{code} +wordTy = UniData wordTyCon [] + +wordTyCon = pcDataTyCon wordTyConKey pRELUDE_BUILTIN SLIT("_Word") [] [wordDataCon] +wordDataCon = pcDataCon wordDataConKey pRELUDE_BUILTIN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv +\end{code} + +\begin{code} +addrTy = UniData addrTyCon [] + +addrTyCon = pcDataTyCon addrTyConKey pRELUDE_BUILTIN SLIT("_Addr") [] [addrDataCon] +addrDataCon = pcDataCon addrDataConKey pRELUDE_BUILTIN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv +\end{code} + +\begin{code} +floatTy = UniData floatTyCon [] + +floatTyCon = pcDataTyCon floatTyConKey pRELUDE_BUILTIN SLIT("Float") [] [floatDataCon] +floatDataCon = pcDataCon floatDataConKey pRELUDE_BUILTIN SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv +\end{code} + +\begin{code} +doubleTy = UniData doubleTyCon [] + +doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE_BUILTIN SLIT("Double") [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv +\end{code} + +\begin{code} +mkStateTy ty = applyTyCon stateTyCon [ty] +realWorldStateTy = mkStateTy realWorldTy -- a common use + +stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alpha_tv] [stateDataCon] +stateDataCon + = pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#") + [alpha_tv] [] [mkStatePrimTy alpha] stateTyCon nullSpecEnv +\end{code} + +\begin{code} +{- OLD: +byteArrayTyCon + = pcDataTyCon byteArrayTyConKey pRELUDE_ARRAY SLIT("_ByteArray") + [alpha_tv] [byteArrayDataCon] + +byteArrayDataCon + = pcDataCon byteArrayDataConKey pRELUDE_ARRAY SLIT("_ByteArray") + [alpha_tv] [] + [mkTupleTy 2 [alpha, alpha], byteArrayPrimTy] + byteArrayTyCon nullSpecEnv +-} +\end{code} + +\begin{code} +{- OLD: +mutableArrayTyCon + = pcDataTyCon mutableArrayTyConKey gLASGOW_ST SLIT("_MutableArray") + [alpha_tv, beta_tv, gamma_tv] [mutableArrayDataCon] + where + mutableArrayDataCon + = pcDataCon mutableArrayDataConKey gLASGOW_ST SLIT("_MutableArray") + [alpha_tv, beta_tv, gamma_tv] [] + [mkTupleTy 2 [beta, beta], applyTyCon mutableArrayPrimTyCon [alpha, gamma]] + mutableArrayTyCon nullSpecEnv +-} +\end{code} + +\begin{code} +{- +mutableByteArrayTyCon + = pcDataTyCon mutableByteArrayTyConKey gLASGOW_ST SLIT("_MutableByteArray") + [alpha_tv, beta_tv] [mutableByteArrayDataCon] + +mutableByteArrayDataCon + = pcDataCon mutableByteArrayDataConKey gLASGOW_ST SLIT("_MutableByteArray") + [alpha_tv, beta_tv] [] + [mkTupleTy 2 [beta, beta], mkMutableByteArrayPrimTy alpha] + mutableByteArrayTyCon nullSpecEnv +-} +\end{code} + +\begin{code} +stablePtrTyCon + = pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr") + [alpha_tv] [stablePtrDataCon] + where + stablePtrDataCon + = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr") + [alpha_tv] [] [applyTyCon stablePtrPrimTyCon [alpha]] stablePtrTyCon nullSpecEnv +\end{code} + +\begin{code} +mallocPtrTyCon + = pcDataTyCon mallocPtrTyConKey gLASGOW_MISC SLIT("_MallocPtr") + [] [mallocPtrDataCon] + where + mallocPtrDataCon + = pcDataCon mallocPtrDataConKey gLASGOW_MISC SLIT("_MallocPtr") + [] [] [applyTyCon mallocPtrPrimTyCon []] mallocPtrTyCon nullSpecEnv +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-Integer]{@Integer@ and its related ``pairing'' types} +%* * +%************************************************************************ + +@Integer@ and its pals are not really primitive. @Integer@ itself, first: +\begin{code} +integerTy :: UniType +integerTy = UniData integerTyCon [] + +integerTyCon = pcDataTyCon integerTyConKey pRELUDE_BUILTIN SLIT("Integer") [] [integerDataCon] + +#ifndef DPH +integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#") + [] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv +#else +-- DPH: For the time being we implement Integers in the same way as Ints. +integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#") + [] [] [intPrimTy] integerTyCon nullSpecEnv +#endif {- Data Parallel Haskell -} +\end{code} + +And the other pairing types: +\begin{code} +return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey + pRELUDE_BUILTIN SLIT("_Return2GMPs") [] [return2GMPsDataCon] + +return2GMPsDataCon + = pcDataCon return2GMPsDataConKey pRELUDE_BUILTIN SLIT("_Return2GMPs") [] [] + [intPrimTy, intPrimTy, byteArrayPrimTy, + intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv + +returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey + pRELUDE_BUILTIN SLIT("_ReturnIntAndGMP") [] [returnIntAndGMPDataCon] + +returnIntAndGMPDataCon + = pcDataCon returnIntAndGMPDataConKey pRELUDE_BUILTIN SLIT("_ReturnIntAndGMP") [] [] + [intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-state-pairing]{``State-pairing'' types} +%* * +%************************************************************************ + +These boring types pair a \tr{State#} with another primitive type. +They are not really primitive, so they are given here, not in +\tr{TysPrim.lhs}. + +We fish one of these \tr{StateAnd#} things with +@getStatePairingConInfo@ (given a little way down). + +\begin{code} +stateAndPtrPrimTyCon + = pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#") + [alpha_tv, beta_tv] [stateAndPtrPrimDataCon] +stateAndPtrPrimDataCon + = pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#") + [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, beta] + stateAndPtrPrimTyCon nullSpecEnv + +stateAndCharPrimTyCon + = pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#") + [alpha_tv] [stateAndCharPrimDataCon] +stateAndCharPrimDataCon + = pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#") + [alpha_tv] [] [mkStatePrimTy alpha, charPrimTy] + stateAndCharPrimTyCon nullSpecEnv + +stateAndIntPrimTyCon + = pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#") + [alpha_tv] [stateAndIntPrimDataCon] +stateAndIntPrimDataCon + = pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#") + [alpha_tv] [] [mkStatePrimTy alpha, intPrimTy] + stateAndIntPrimTyCon nullSpecEnv + +stateAndWordPrimTyCon + = pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#") + [alpha_tv] [stateAndWordPrimDataCon] +stateAndWordPrimDataCon + = pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#") + [alpha_tv] [] [mkStatePrimTy alpha, wordPrimTy] + stateAndWordPrimTyCon nullSpecEnv + +stateAndAddrPrimTyCon + = pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#") + [alpha_tv] [stateAndAddrPrimDataCon] +stateAndAddrPrimDataCon + = pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#") + [alpha_tv] [] [mkStatePrimTy alpha, addrPrimTy] + stateAndAddrPrimTyCon nullSpecEnv + +stateAndStablePtrPrimTyCon + = pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#") + [alpha_tv, beta_tv] [stateAndStablePtrPrimDataCon] +stateAndStablePtrPrimDataCon + = pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#") + [alpha_tv, beta_tv] [] + [mkStatePrimTy alpha, applyTyCon stablePtrPrimTyCon [beta]] + stateAndStablePtrPrimTyCon nullSpecEnv + +stateAndMallocPtrPrimTyCon + = pcDataTyCon stateAndMallocPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#") + [alpha_tv] [stateAndMallocPtrPrimDataCon] +stateAndMallocPtrPrimDataCon + = pcDataCon stateAndMallocPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#") + [alpha_tv] [] + [mkStatePrimTy alpha, applyTyCon mallocPtrPrimTyCon []] + stateAndMallocPtrPrimTyCon nullSpecEnv + +stateAndFloatPrimTyCon + = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#") + [alpha_tv] [stateAndFloatPrimDataCon] +stateAndFloatPrimDataCon + = pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#") + [alpha_tv] [] [mkStatePrimTy alpha, floatPrimTy] + stateAndFloatPrimTyCon nullSpecEnv + +stateAndDoublePrimTyCon + = pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#") + [alpha_tv] [stateAndDoublePrimDataCon] +stateAndDoublePrimDataCon + = pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#") + [alpha_tv] [] [mkStatePrimTy alpha, doublePrimTy] + stateAndDoublePrimTyCon nullSpecEnv +\end{code} + +\begin{code} +stateAndArrayPrimTyCon + = pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#") + [alpha_tv, beta_tv] [stateAndArrayPrimDataCon] +stateAndArrayPrimDataCon + = pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#") + [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkArrayPrimTy beta] + stateAndArrayPrimTyCon nullSpecEnv + +stateAndMutableArrayPrimTyCon + = pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#") + [alpha_tv, beta_tv] [stateAndMutableArrayPrimDataCon] +stateAndMutableArrayPrimDataCon + = pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#") + [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkMutableArrayPrimTy alpha beta] + stateAndMutableArrayPrimTyCon nullSpecEnv + +stateAndByteArrayPrimTyCon + = pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#") + [alpha_tv] [stateAndByteArrayPrimDataCon] +stateAndByteArrayPrimDataCon + = pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#") + [alpha_tv] [] [mkStatePrimTy alpha, byteArrayPrimTy] + stateAndByteArrayPrimTyCon nullSpecEnv + +stateAndMutableByteArrayPrimTyCon + = pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#") + [alpha_tv] [stateAndMutableByteArrayPrimDataCon] +stateAndMutableByteArrayPrimDataCon + = pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#") + [alpha_tv] [] [mkStatePrimTy alpha, applyTyCon mutableByteArrayPrimTyCon [alpha]] + stateAndMutableByteArrayPrimTyCon nullSpecEnv + +stateAndSynchVarPrimTyCon + = pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#") + [alpha_tv, beta_tv] [stateAndSynchVarPrimDataCon] +stateAndSynchVarPrimDataCon + = pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#") + [alpha_tv, beta_tv] [] [mkStatePrimTy alpha, mkSynchVarPrimTy alpha beta] + stateAndSynchVarPrimTyCon nullSpecEnv +\end{code} + +The ccall-desugaring mechanism uses this function to figure out how to +rebox the result. It's really a HACK, especially the part about +how many types to drop from \tr{tys_applied}. + +\begin{code} +getStatePairingConInfo + :: UniType -- primitive type + -> (Id, -- state pair constructor for prim type + UniType) -- type of state pair + +getStatePairingConInfo prim_ty + = case (getUniDataTyCon_maybe prim_ty) of + Nothing -> panic "getStatePairingConInfo:1" + Just (prim_tycon, tys_applied, _) -> + let + (pair_con, pair_tycon, num_tys) = assoc "getStatePairingConInfo" tbl prim_tycon + pair_ty = applyTyCon pair_tycon (realWorldTy : drop num_tys tys_applied) + in + (pair_con, pair_ty) + where + tbl = [ + (charPrimTyCon, (stateAndCharPrimDataCon, stateAndCharPrimTyCon, 0)), + (intPrimTyCon, (stateAndIntPrimDataCon, stateAndIntPrimTyCon, 0)), + (wordPrimTyCon, (stateAndWordPrimDataCon, stateAndWordPrimTyCon, 0)), + (addrPrimTyCon, (stateAndAddrPrimDataCon, stateAndAddrPrimTyCon, 0)), + (stablePtrPrimTyCon, (stateAndStablePtrPrimDataCon, stateAndStablePtrPrimTyCon, 0)), + (mallocPtrPrimTyCon, (stateAndMallocPtrPrimDataCon, stateAndMallocPtrPrimTyCon, 0)), + (floatPrimTyCon, (stateAndFloatPrimDataCon, stateAndFloatPrimTyCon, 0)), + (doublePrimTyCon, (stateAndDoublePrimDataCon, stateAndDoublePrimTyCon, 0)), + (arrayPrimTyCon, (stateAndArrayPrimDataCon, stateAndArrayPrimTyCon, 0)), + (mutableArrayPrimTyCon, (stateAndMutableArrayPrimDataCon, stateAndMutableArrayPrimTyCon, 1)), + (byteArrayPrimTyCon, (stateAndByteArrayPrimDataCon, stateAndByteArrayPrimTyCon, 0)), + (mutableByteArrayPrimTyCon, (stateAndMutableByteArrayPrimDataCon, stateAndMutableByteArrayPrimTyCon, 1)), + (synchVarPrimTyCon, (stateAndSynchVarPrimDataCon, stateAndSynchVarPrimTyCon, 1)) + -- (PtrPrimTyCon, (stateAndPtrPrimDataCon, stateAndPtrPrimTyCon, 0)), + ] +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-ST]{The basic @_ST@ state-transformer type} +%* * +%************************************************************************ + +This is really just an ordinary synonym, except it is ABSTRACT. + +\begin{code} +mkStateTransformerTy s a = applyTyCon stTyCon [s, a] + +stTyCon + = mkSynonymTyCon + stTyConKey + (mkPreludeCoreName gLASGOW_ST SLIT("_ST")) + 2 + [alpha_tv, beta_tv] + (mkStateTy alpha `UniFun` mkTupleTy 2 [beta, mkStateTy alpha]) + True -- ToDo: make... *** ABSTRACT *** +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-IO]{The @PrimIO@ and @IO@ monadic-I/O types} +%* * +%************************************************************************ + +@PrimIO@ and @IO@ really are just a plain synonyms. + +\begin{code} +mkPrimIoTy a = applyTyCon primIoTyCon [a] + +primIoTyCon + = mkSynonymTyCon + primIoTyConKey + (mkPreludeCoreName pRELUDE_PRIMIO SLIT("PrimIO")) + 1 + [alpha_tv] + (mkStateTransformerTy realWorldTy alpha) + True -- need not be abstract +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-Bool]{The @Bool@ type} +%* * +%************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} + +\begin{code} +boolTy = UniData boolTyCon [] + +boolTyCon = pcDataTyCon boolTyConKey pRELUDE_CORE SLIT("Bool") [] [falseDataCon, trueDataCon] + +falseDataCon = pcDataCon falseDataConKey pRELUDE_CORE SLIT("False") [] [] [] boolTyCon nullSpecEnv +trueDataCon = pcDataCon trueDataConKey pRELUDE_CORE SLIT("True") [] [] [] boolTyCon nullSpecEnv +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-CMP-TAG]{The @CMP_TAG#@ type (for fast `derived' comparisons)} +%* * +%************************************************************************ + +\begin{code} +--------------------------------------------- +-- data _CMP_TAG = _LT | _EQ | _GT deriving () +--------------------------------------------- + +cmpTagTy = UniData cmpTagTyCon [] + +cmpTagTyCon = pcDataTyCon cmpTagTyConKey pRELUDE_BUILTIN SLIT("_CMP_TAG") [] + [ltPrimDataCon, eqPrimDataCon, gtPrimDataCon] + +ltPrimDataCon = pcDataCon ltTagDataConKey pRELUDE_BUILTIN SLIT("_LT") [] [] [] cmpTagTyCon nullSpecEnv +eqPrimDataCon = pcDataCon eqTagDataConKey pRELUDE_BUILTIN SLIT("_EQ") [] [] [] cmpTagTyCon nullSpecEnv +gtPrimDataCon = pcDataCon gtTagDataConKey pRELUDE_BUILTIN SLIT("_GT") [] [] [] cmpTagTyCon nullSpecEnv +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-List]{The @List@ type (incl ``build'' magic)} +%* * +%************************************************************************ + +Special syntax, deeply wired in, but otherwise an ordinary algebraic +data type: +\begin{verbatim} +data List a = Nil | a : (List a) +\end{verbatim} + +\begin{code} +mkListTy :: UniType -> UniType +mkListTy ty = UniData listTyCon [ty] + +alphaListTy = mkSigmaTy [alpha_tv] [] (mkListTy alpha) + +listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("List") [alpha_tv] [nilDataCon, consDataCon] + +nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("Nil") [alpha_tv] [] [] listTyCon + (pcGenerateDataSpecs alphaListTy) +consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":") + [alpha_tv] [] [alpha, mkListTy alpha] listTyCon + (pcGenerateDataSpecs alphaListTy) +\end{code} + +This is the @_Build@ data constructor, it does {\em not} appear inside +listTyCon. It has this type: \tr{((a -> b -> b) -> b -> b) -> [a]}. +\begin{code} +{- NOT USED: +buildDataCon + = pcDataCon buildDataConKey pRELUDE_BUILTIN "Build" + [alpha_tv] [] [ + mkSigmaTy [beta_tv] [] + ((alpha `UniFun` (beta `UniFun` beta)) + `UniFun` (beta + `UniFun` beta))] listTyCon nullSpecEnv +-} +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-Tuples]{The @Tuple@ types} +%* * +%************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type +@TyCon@\srcloc{uniType/TyCon.lhs}. +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@\srcloc{basicTypes/Id.lhs}. Again these contain their arity but +don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} + +\begin{code} +mkTupleTy :: Int -> [UniType] -> UniType + +mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys + +unitTy = mkTupleTy 0 [] +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-Ratios]{@Ratio@ and @Rational@} +%* * +%************************************************************************ + +ToDo: make this (mostly) go away. + +\begin{code} +rationalTy :: UniType + +mkRatioTy ty = UniData ratioTyCon [ty] +rationalTy = mkRatioTy integerTy + +ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alpha_tv] [ratioDataCon] + +ratioDataCon = pcDataCon ratioDataConKey pRELUDE_RATIO SLIT(":%") + [alpha_tv] [{-(integralClass,alpha)-}] [alpha, alpha] ratioTyCon nullSpecEnv + -- context omitted to match lib/prelude/ defn of "data Ratio ..." + +rationalTyCon + = mkSynonymTyCon + rationalTyConKey + (mkPreludeCoreName pRELUDE_RATIO SLIT("Rational")) + 0 -- arity + [] -- tyvars + rationalTy -- == mkRatioTy integerTy + True -- unabstract +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-_Lift]{@_Lift@ type: to support array indexing} +%* * +%************************************************************************ + +Again, deeply turgid: \tr{data _Lift a = _Lift a}. + +\begin{code} +mkLiftTy ty = applyTyCon liftTyCon [ty] + +{- +mkLiftTy ty + = mkSigmaTy tvs theta (UniData liftTyCon [tau]) + where + (tvs, theta, tau) = splitType ty + +isLiftTy ty + = case getUniDataTyCon_maybe tau of + Just (tycon, tys, _) -> tycon == liftTyCon + Nothing -> False + where + (tvs, theta, tau) = splitType ty +-} + + +alphaLiftTy = mkSigmaTy [alpha_tv] [] (UniData liftTyCon [alpha]) + +liftTyCon + = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alpha_tv] [liftDataCon] + +liftDataCon + = pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift") + [alpha_tv] [] [alpha] liftTyCon + ((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv` + (SpecInfo [Just realWorldStatePrimTy] 0 bottom)) + where + bottom = panic "liftDataCon:State# _RealWorld" +\end{code} + + +%************************************************************************ +%* * +\subsection[TysWiredIn-for-convenience]{Types wired in for convenience (e.g., @String@)} +%* * +%************************************************************************ + +\begin{code} +stringTy = mkListTy charTy + +stringTyCon + = mkSynonymTyCon + stringTyConKey + (mkPreludeCoreName pRELUDE_CORE SLIT("String")) + 0 + [] -- type variables + stringTy + True -- unabstract +\end{code} + +\begin{code} +{- UNUSED: +packedStringTy = applyTyCon packedStringTyCon [] + +packedStringTyCon + = pcDataTyCon packedStringTyConKey pRELUDE_PS SLIT("_PackedString") [] + [psDataCon, cpsDataCon] + +psDataCon + = pcDataCon psDataConKey pRELUDE_PS SLIT("_PS") + [] [] [intPrimTy, byteArrayPrimTy] packedStringTyCon + +cpsDataCon + = pcDataCon cpsDataConKey pRELUDE_PS SLIT("_CPS") + [] [] [addrPrimTy] packedStringTyCon +-} +\end{code} diff --git a/ghc/compiler/prelude/prelude-structure.fig b/ghc/compiler/prelude/prelude-structure.fig new file mode 100644 index 0000000..0eada43 --- /dev/null +++ b/ghc/compiler/prelude/prelude-structure.fig @@ -0,0 +1,67 @@ +#FIG 2.1 +80 2 +1 2 0 1 -1 0 0 0 0.000 1 0.000 59 49 40 30 19 19 99 79 +1 2 0 1 -1 0 0 0 0.000 1 0.000 324 49 40 30 284 19 364 79 +1 2 0 1 -1 0 0 0 0.000 1 0.000 188 137 29 15 159 123 217 152 +1 2 0 1 -1 0 0 0 0.000 1 0.000 188 181 29 15 159 167 217 196 +1 2 0 1 -1 0 0 0 0.000 1 0.000 188 225 29 15 159 211 217 240 +1 2 0 1 -1 0 0 0 0.000 1 0.000 188 269 29 15 159 254 217 284 +1 2 0 1 -1 0 0 0 0.000 1 0.000 188 313 29 15 159 298 217 328 +1 2 0 1 -1 0 0 0 0.000 1 0.000 188 357 29 15 159 342 217 371 +1 2 0 1 -1 0 0 0 0.000 1 0.000 190 87 39 22 151 65 229 109 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 99 49 279 49 9999 9999 +2 4 0 2 -1 0 0 0 0.000 7 0 0 + 379 389 379 9 9 9 9 389 379 389 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 119 49 119 359 159 359 9999 9999 +2 1 0 1 -1 0 0 0 0.000 24 1 0 + 0 0 1.000 4.000 8.000 + 119 314 159 314 9999 9999 +2 1 0 1 -1 0 0 0 0.000 32 1 0 + 0 0 1.000 4.000 8.000 + 119 269 159 269 9999 9999 +2 1 0 1 -1 0 0 0 0.000 5111825 1 0 + 0 0 1.000 4.000 8.000 + 119 224 159 224 9999 9999 +2 1 0 1 -1 0 0 0 0.000 11534361 1 0 + 0 0 1.000 4.000 8.000 + 119 184 159 184 9999 9999 +2 1 0 1 -1 0 0 0 0.000 13893695 1 0 + 0 0 1.000 4.000 8.000 + 119 139 159 139 9999 9999 +2 1 0 1 -1 0 0 0 0.000 123 1 0 + 0 0 1.000 4.000 8.000 + 119 89 149 89 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 219 359 259 359 259 69 284 59 9999 9999 +2 1 0 1 -1 0 0 0 0.000 16 1 0 + 0 0 1.000 4.000 8.000 + 219 314 239 314 259 299 9999 9999 +2 1 0 1 -1 0 0 0 0.000 16842916 1 0 + 0 0 1.000 4.000 8.000 + 219 269 239 269 259 254 9999 9999 +2 1 0 1 -1 0 0 0 0.000 1703935 1 0 + 0 0 1.000 4.000 8.000 + 219 224 239 224 259 209 9999 9999 +2 1 0 1 -1 0 0 0 0.000 726872 1 0 + 0 0 1.000 4.000 8.000 + 219 179 239 179 259 159 9999 9999 +2 1 0 1 -1 0 0 0 0.000 40 1 0 + 0 0 1.000 4.000 8.000 + 219 139 239 139 259 119 9999 9999 +2 1 0 1 -1 0 0 0 0.000 1 1 0 + 0 0 1.000 4.000 8.000 + 229 89 244 89 259 79 9999 9999 +4 0 1 12 0 -1 0 0.000 0 9 42 39 54 BuiltIn +4 0 1 12 0 -1 0 0.000 0 9 42 309 54 Prelude +4 0 1 10 0 -1 0 0.000 0 9 24 174 94 Core +4 0 1 10 0 -1 0 0.000 0 9 24 179 144 Text +4 0 1 10 0 -1 0 0.000 0 9 30 174 184 Ratio +4 0 1 10 0 -1 0 0.000 0 11 42 169 229 Complex +4 0 1 10 0 -1 0 0.000 0 11 30 174 269 Array +4 0 1 10 0 -1 0 0.000 0 9 12 179 314 IO +4 0 1 10 0 -1 0 0.000 0 9 24 179 359 List diff --git a/ghc/compiler/prelude/prelude-structure.tex b/ghc/compiler/prelude/prelude-structure.tex new file mode 100644 index 0000000..bcb7189 --- /dev/null +++ b/ghc/compiler/prelude/prelude-structure.tex @@ -0,0 +1,7 @@ +\makebox[4.625in][l]{ + \vbox to 4.750in{ + \vfill + \special{psfile=prelude-structure.ps} + } + \vspace{-\baselineskip} +} diff --git a/ghc/compiler/prelude/prelude.lit b/ghc/compiler/prelude/prelude.lit new file mode 100644 index 0000000..615f779 --- /dev/null +++ b/ghc/compiler/prelude/prelude.lit @@ -0,0 +1,420 @@ +\documentstyle[11pt,literate,a4wide]{article} + +%-------------------- +\begin{rawlatex} +%\input{transfig} + +%\newcommand{\folks}[1]{$\spadesuit$ {\em #1} $\spadesuit$} +%\newcommand{\ToDo}[1]{$\spadesuit$ {\bf ToDo:} {\em #1} $\spadesuit$} + +% to avoid src-location marginpars, comment in/out this defn. +%\newcommand{\srcloc}[1]{{\tt #1}} +%\newcommand{\srclocnote}[1]{} +%\newcommand{\srclocnote}[1]{\marginpar{\small\srcloc{#1}}} + +\setcounter{secnumdepth}{6} +\setcounter{tocdepth}{6} +\end{rawlatex} +%-------------------- + +\begin{document} +\title{Basic types and the standard Prelude: OBSOLETE} +\author{The AQUA team} +\date{November 1992 (obsolete February 1994)} +\maketitle +\begin{rawlatex} +\tableofcontents +\pagebreak +\end{rawlatex} + +% added to keep DPH stuff happy: +\begin{rawlatex} +\def\DPHaskell{DPHaskell} +\def\POD{POD} +\end{rawlatex} + +This document describes how we deal with Haskell's standard prelude, +notably what the compiler itself ``knows'' about it. There's nothing +intellectually difficult here---it's just vast and occasionally +delicate. + +First, some introduction, mostly terminology. Second, the actual +compiler source code which defines what the compiler knows about the +prelude. Finally, something about how we compile the prelude code +(with GHC, of course) to produce the executable bits for the prelude. + +%************************************************************************ +%* * +\section{Introduction and terminology} +%* * +%************************************************************************ + +The standard prelude is made of many, many pieces. The GHC system +must deal with these pieces in different ways. For example, the +compiler must obviously do different things for primitive operations +(e.g., addition on machine-level @Ints@) and for plain +written-in-Haskell functions (e.g., @tail@). + +In this section, the main thing we do is explain the various ways that +we categorise prelude thingies, most notably types. + +%************************************************************************ +%* * +\subsection{Background information} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection{Background terms: Heap objects} +%* * +%************************************************************************ + +A {\em heap object} (equivalently {\em closure}) is always a +contiguous block of memory, starting with an info pointer. {\em +Dynamic} heap objects are allocated by a sequence of instructions in +the usual way. + +In contrast, {\em static heap objects} are statically allocated at +fixed, labelled locations outside the dynamic heap --- but we still +call them heap objects! Their GC code does not evacuate them, and +they are never scavenged since they never appear in to-space. Note: +the ``staticness'' does {\em not} mean they are read-only; they may be +updatable. + +(Much) more on this stuff in the STG paper. + +%************************************************************************ +%* * +\subsection{Categorising the prelude bits} +%* * +%************************************************************************ + +Here are four different ways in which we might categorise prelude +things generally. Note, also, the {\em simplifying assumptions} that +we make so that we can have a ``Prelude onion,'' in which each +``layer'' includes the preceding ones. + +\begin{description} +%------------------------------------------------------------------ +\item[Primitive vs Haskell-able:] + +Some parts of the prelude cannot be expressed in Haskell ({\em +primitive}), whereas most of it can be ({\em Haskell-able}). + +BIG NOTE: Because of our non-standard support for unboxed numbers and +operations thereon, some of the things in @PreludeBuiltin@ in the +report {\em are} Haskell-able. For example, the @negate@ operation on +an @Int@ is just: + +\begin{verbatim} +negateInt i + = case i of MkInt i# -> case (negateInt# i#) of j# -> MkInt j# +\end{verbatim} + +Of course, this just moves the goalposts: @negateInt#@ is now the +primitive, non-Haskell-able thingy... + +So: something is ``primitive'' if we cannot define it in our +GHC-extended Haskell. + +For more information, please see \sectionref{prelude-more-on-types} +for further discussion about types in the Prelude. + +%------------------------------------------------------------------ +\item[From (exported by) PreludeCore or not:] +The module @PreludeCore@ exports all the types, classes, and instances +in the prelude. These entities are ``immutable;'' they can't be +hidden, renamed, or really fiddled in any way. + +(NB: The entities {\em exported by} @PreludeCore@ may {\em originally} +be from another module. For example, the @Complex@ datatype is +defined in @PreludeComplex@; nonetheless, it is exported by +@PreludeCore@ and falls into the category under discussion here.) + +{\em Simplifying assumption:} We take everything primitive (see +previous classification) to be ``from PreludeCore''. + +{\em Simplifying assumption:} We take all {\em values} from +@PreludeBuiltin@ to be ``from PreludeCore.'' This includes @error@ +and the various \tr{prim*} functions (which may or may not be +``primitive'' in our system [because of our extensions for unboxery]). +It shouldn't be hard to believe that something from @PreludeBuiltin@ +is (at least) slightly magic and not just another value... + +{\em Simplifying assumption:} The GHC compiler has ``wired in'' +information about {\em all} @fromPreludeCore@ things. The fact that +they are ``immutable'' means we don't have to worry about ``unwiring'' +them in the face of renaming, etc., (which would be pretty bizarre, +anyway). + +Not-exported-by-PreludeCore things (non-@PreludeBuiltin@ values) can +be renamed, hidden, etc. + +%------------------------------------------------------------------ +\item[Compiler-must-know vs compiler-chooses-to-know vs compiler-unknown:] + +There are some prelude things that the compiler has to ``know about.'' +For example, it must know about the @Bool@ data type, because (for one +reason) it needs it to typecheck guards. + +{\em Simplifying assumption:} By decree, the compiler ``must know'' +about everything exported from @PreludeCore@ (see previous +classification). This is only slight overkill: there are a few types +(e.g., @Request@), classes (e.g., @RealFrac@), and instances (e.g., +anything for @RealFrac@)---all @fromPreludeCore@---that the compiler +could, strictly speaking, get away with not knowing about. However, +it is a {\em pain} to maintain the distinction... + +On the other hand, the compiler really {\em doesn't} need to know +about the non-@fromPreludeCore@ stuff (as defined above). It can read +the relevant information out of a \tr{.hi} interface file, just as it +would for a user-defined module (and, indeed, that's what it does). +An example of something the compiler doesn't need to know about is the +@tail@ function, defined in @PreludeList@, exported by @Prelude@. + +There are some non-@fromPreludeCore@ things that the compiler may {\em +choose} to clutch to its bosom: this is so it can do unfolding on the +use of a function. For example, we always want to unfold uses of @&&@ +and @||@, so we wire info about them into the compiler. (We won't +need this when we are able to pass unfolding info via interface +files.) + +%------------------------------------------------------------------ +\item[Per-report vs Glasgow-extension:] +Some of our prelude stuff is not strictly as per the Haskell report, +notably the support for monadic I/O, and our different notion of what +is truly primitive in Haskell (c.f. @PreludeBuiltin@'s ideas). + +In this document, ``Haskell'' always means ``Glasgow-extended +Haskell.'' +\end{description} + +%************************************************************************ +%* * +\subsection[prelude-more-on-types]{More about the Prelude datatypes} +%* * +%************************************************************************ + +The previous section explained how we categorise the prelude as a +whole. In this section, we home in on prelude datatypes. + +%************************************************************************ +%* * +\subsubsection{Boxed vs unboxed types} +%* * +%************************************************************************ + +Objects of a particular type are all represented the same way. +We recognise two kinds of types: +\begin{description} + +\item[Boxed types.] +The domain of a boxed type includes bottom. Values of boxed type are +always represented by a pointer to a heap object, which may or may not +be evaluated. Anyone needing to scrutinise a value of boxed type must +evaluate it first by entering it. Value of boxed type can be passed +to polymorphic functions. + +\item[Unboxed types.] +The domain of an unboxed type does not include bottom, so values of +unboxed type do not need a representation which accommodates the +possibility that it is not yet evaluated. + +Unboxed values are represented by one or more words. At present, if +it is represented by more than one word then none of the words are +pointers, but we plan to lift this restriction eventually. +(At present, the only multi-word values are @Double#@s.) + +An unboxed value may be represented by a pointer to a heap object: +primitive strings and arbitrary-precision integers are examples (see +Section~\ref{sect-primitive}). +\end{description} + +%************************************************************************ +%* * +\subsubsection{Primitive vs algebraic types} +%* * +%************************************************************************ + +There is a second classification of types, which is not quite orthogonal: +\begin{description} + +\item[Primitive types.] +A type is called {\em primitive} if it cannot be defined in +(Glasgow-extended) Haskell, and the only operations which manipulate its +representation are primitive ones. It follows that the domain +corresponding to a primitive type has no bottom element; that is, all +primitive data types are unboxed. + +By convention, the names of all primitive types end with @#@. + +\item[Algebraic data types.] +These are built with Haskell's @data@ declaration. Currently, @data@ +declarations can {\em only} build boxed types (and hence {\em all +unboxed types are also primitive}), but we plan to lift this +restriction in due course. +\end{description} + +%************************************************************************ +%* * +\subsection[prelude-onion]{Summary of the ``Prelude onion''} +%* * +%************************************************************************ + +Summarizing: +\begin{enumerate} +\item +{\em Primitive} types, and operations thereon (@PrimitiveOps@), are at +the core of the onion. + +\item +Everything exported @fromPreludeCore@ (w/ all noted provisos) makes up +the next layer of the onion; and, by decree, the compiler has built-in +knowledge of all of it. All the primitive stuff is included in this +category. + +\item +The compiler {\em chooses to know} about a few of the +non-@fromPreludeCore@ values in the @Prelude@. This is (exclusively) +for access to their unfoldings. + +\item +The rest of the @Prelude@ is ``unknown'' to the compiler itself; it +gets its information from a \tr{Prelude.hi} file, exactly as it does +for user-defined modules. +\end{enumerate} + +%************************************************************************ +%* * +\section{What the compiler knows about the prelude} +%* * +%************************************************************************ + +This is essentially the stuff in the directory \tr{ghc/compiler/prelude}. + +%************************************************************************ +%* * +\subsection{What the compiler knows about prelude types (and ops thereon)} +%* * +%************************************************************************ + +The compiler has wired into it knowledge of all the types in the +standard prelude, all of which are exported by @PreludeCore@. +Strictly speaking, it needn't know about some types (e.g., the +@Request@ and @Response@ datatypes), but it's tidier in the end to +wire in everything. + +Primitive types, and related stuff, are covered first. Then the more +ordinary prelude types. The more turgid parts may be arranged +alphabetically... + +\downsection +\downsection +% pretty ugly, no? +%************************************************************************ +%* * +\section{Primitive types (and ``kinds'') {\em and} operations thereon} +\label{sect-primitive} +%* * +%************************************************************************ + +There are the following primitive types. +%partain:\begin{center} +\begin{tabular}{|llll|} +\hline +Type & Represents & Size (32|64-bit words) & Pointer? \\ +\hline +@Void#@ & zero-element type & 1 & No \\ +@Char#@ & characters & 1 & No \\ +@Int#@ & 32|64-bit integers & 1 & No \\ +@Float#@ & 32|64-bit floats & 1 & No \\ +@Double#@ & 64|128-bit floats & 2 & No \\ +@Arr#@ & array of pointers & ? & Yes \\ +@Arr# Char#@ & array of @Char#@s & ? & No \\ +@Arr# Int#@ & array of @Int#@s & ? & No \\ +@Arr# Float#@ & array of @Float#@s & ? & No \\ +@Arr# Double#@ & array of @Double#@s & ? & No \\ +@Integer#@ & arbitrary-precision integers & 1 & Yes \\ +@LitString#@ & literal C-style strings & 1 & No \\ +\hline +\end{tabular} +%partain:\end{center} + +Notes: (a)~@Integer#s@ have a pointer in them, to a @Arr# Int#@; see +the discussion in @TyInteger@. (b)~@LitString#@ is a magical type +used {\em only} to handle literal C-strings; this is a convenience; we +could use an @Arr# Char#@ instead. + +What the compiler knows about these primitive types is either +(a)~given with the corresponding algebraic type (e.g., @Int#@ stuff is +with @Int@ stuff), or (b)~in a module of its own (e.g., @Void#@). + +\downsection +\input{PrimKind.lhs} + +\section{Details about ``Glasgow-special'' types} + +\downsection +\input{TysPrim.lhs} +\input{TyPod.lhs} +\input{TyProcs.lhs} +\upsection + +\input{PrimOps.lhs} +\upsection + +%************************************************************************ +%* * +\section{Details (mostly) about non-primitive Prelude types} +\label{sect-nonprim-tys} +%* * +%************************************************************************ + +\downsection +\input{TysWiredIn.lhs} +\upsection + +%************************************************************************ +%* * +%\subsection{What the compiler knows about prelude values} +%* * +%************************************************************************ +\downsection +\input{PrelVals.lhs} +\upsection + +%************************************************************************ +%* * +\subsection{Uniquifiers and utility bits for this prelude stuff} +%* * +%************************************************************************ +\downsection +\downsection +\input{PrelFuns.lhs} +\upsection +\upsection + +%************************************************************************ +%* * +%\subsection{The @AbsPrel@ interface to the compiler's prelude knowledge} +%* * +%************************************************************************ +\downsection +\input{AbsPrel.lhs} +\upsection + +%************************************************************************ +%* * +\section{The executable code for prelude bits} +%* * +%************************************************************************ + +This essentially describes what happens in the directories +\tr{ghc/lib/{io,prelude}}; the former is to support the (non-std) +Glasgow I/O; the latter is regular prelude things. + +ToDo: more. + +\printindex +\end{document} diff --git a/ghc/compiler/profiling/CostCentre.hi b/ghc/compiler/profiling/CostCentre.hi new file mode 100644 index 0000000..6b44d01 --- /dev/null +++ b/ghc/compiler/profiling/CostCentre.hi @@ -0,0 +1,76 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CostCentre where +import CharSeq(CSeq) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import UniType(UniType) +import Unique(Unique) +import Unpretty(Unpretty(..)) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data CcKind {-# GHC_PRAGMA UserCC _PackedString | AutoCC Id | DictCC Id #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data IsCafCC = IsCafCC | IsNotCafCC +data IsDupdCC {-# GHC_PRAGMA AnOriginalCC | ADupdCC #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type Unpretty = CSeq +cafifyCC :: CostCentre -> CostCentre + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +ccFromThisModule :: CostCentre -> _PackedString -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +ccMentionsId :: CostCentre -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +cmpCostCentre :: CostCentre -> CostCentre -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +costsAreSubsumed :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: CostCentre) -> case u0 of { _ALG_ _ORIG_ CostCentre SubsumedCosts -> _!_ True [] []; (u1 :: CostCentre) -> _!_ False [] [] } _N_ #-} +currentOrSubsumedCosts :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 13 \ (u0 :: CostCentre) -> case u0 of { _ALG_ _ORIG_ CostCentre SubsumedCosts -> _!_ True [] []; _ORIG_ CostCentre CurrentCC -> _!_ True [] []; (u1 :: CostCentre) -> _!_ False [] [] } _N_ #-} +dontCareCostCentre :: CostCentre + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre DontCareCC [] [] _N_ #-} +dupifyCC :: CostCentre -> CostCentre + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isCafCC :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isDictCC :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isDupdCC :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkAllCafsCC :: _PackedString -> _PackedString -> CostCentre + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _ORIG_ CostCentre AllCafsCC [] [u0, u1] _N_ #-} +mkAllDictsCC :: _PackedString -> _PackedString -> Bool -> CostCentre + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _N_ #-} +mkAutoCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +mkDictCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +mkUserCC :: _PackedString -> _PackedString -> _PackedString -> CostCentre + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +noCostCentre :: CostCentre + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre NoCostCentre [] [] _N_ #-} +noCostCentreAttached :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: CostCentre) -> case u0 of { _ALG_ _ORIG_ CostCentre NoCostCentre -> _!_ True [] []; (u1 :: CostCentre) -> _!_ False [] [] } _N_ #-} +overheadCostCentre :: CostCentre + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre OverheadCC [] [] _N_ #-} +preludeCafsCostCentre :: CostCentre + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre PreludeCafsCC [] [] _N_ #-} +preludeDictsCostCentre :: Bool -> CostCentre + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +setToAbleCostCentre :: CostCentre -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +showCostCentre :: PprStyle -> Bool -> CostCentre -> [Char] + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLS" _N_ _N_ #-} +subsumedCosts :: CostCentre + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre SubsumedCosts [] [] _N_ #-} +unCafifyCC :: CostCentre -> CostCentre + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +uppCostCentre :: PprStyle -> Bool -> CostCentre -> CSeq + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-} +uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> CSeq + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LEL" _N_ _N_ #-} +useCurrentCostCentre :: CostCentre + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre CurrentCC [] [] _N_ #-} + diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs new file mode 100644 index 0000000..2b06375 --- /dev/null +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -0,0 +1,503 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CostCentre]{The @CostCentre@ data type} + +\begin{code} +#include "HsVersions.h" + +module CostCentre ( + CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..), + noCostCentre, subsumedCosts, + useCurrentCostCentre, + noCostCentreAttached, costsAreSubsumed, + currentOrSubsumedCosts, + preludeCafsCostCentre, preludeDictsCostCentre, + overheadCostCentre, dontCareCostCentre, + + mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC, + cafifyCC, unCafifyCC, dupifyCC, + isCafCC, isDictCC, isDupdCC, + setToAbleCostCentre, + ccFromThisModule, + ccMentionsId, + + uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing + + cmpCostCentre, -- used for removing dups in a list + + Id, Maybe, Unpretty(..), CSeq + ) where + +import CmdLineOpts ( GlobalSwitch(..) ) +import CLabelInfo ( identToC, stringToC ) +import Id ( cmpId, showId, pprIdInUnfolding, + externallyVisibleId, Id + ) +import Maybes ( Maybe(..) ) +import Outputable +import Pretty ( ppShow, prettyToUn ) +import UniqSet +import Unpretty +import Util +\end{code} + +\begin{code} +data CostCentre + = NoCostCentre -- Having this constructor avoids having + -- to use "Maybe CostCentre" all the time. + + | NormalCC CcKind -- CcKind will include a cost-centre name + FAST_STRING -- Name of module defining this CC. + FAST_STRING -- "Group" that this CC is in. + IsDupdCC -- see below + IsCafCC -- see below + + | CurrentCC -- Pinned on a let(rec)-bound thunk/function/constructor, + -- this says that the cost centre to be attached to + -- the object, when it is allocated, is whatever is in the + -- current-cost-centre register. + -- This guy is *never* the cost centre for an SCC construct, + -- and is only used for *local* (non-top-level) definitions. + + | SubsumedCosts -- Cost centre for top-level subsumed functions + -- (CAFs get an AllCafsCC). + -- Its execution costs get subsumed into the caller. + -- This guy is *only* ever pinned on static closures, + -- and is *never* the cost centre for an SCC construct. + + | AllCafsCC FAST_STRING -- Ditto for CAFs. + FAST_STRING -- We record module and group names. + -- Again, one "big" CAF cc per module, where all + -- CAF costs are attributed unless the user asked for + -- per-individual-CAF cost attribution. + + | AllDictsCC FAST_STRING -- Ditto for dictionaries. + FAST_STRING -- We record module and group names. + -- Again, one "big" DICT cc per module, where all + -- DICT costs are attributed unless the user asked for + -- per-individual-DICT cost attribution. + IsDupdCC -- see below + + | OverheadCC -- We charge costs due to the profiling-system + -- doing its work to "overhead". + -- + -- Objects whose cost-centre is "Overhead" + -- have their *allocation* charged to "overhead", + -- but have the current CC put into the object + -- itself. + -- + -- For example, if we transform "f g" to "let + -- g' = g in f g'" (so that something about + -- profiling works better...), then we charge + -- the *allocation* of g' to OverheadCC, but + -- we put the cost-centre of the call to f + -- (i.e., current CC) into the g' object. When + -- g' is entered, the cost-centre of the call + -- to f will be set. + + | PreludeCafsCC -- In compiling the prelude, we do sometimes + | PreludeDictsCC -- need a CC to blame; i.e., when there's a CAF, + -- or other costs that really shouldn't be + -- subsumed/blamed-on-the-caller. These costs + -- should be *small*. We treat PreludeCafsCC + -- as if it were shorthand for + -- (AllCafsCC _). Analogously + -- for PreludeDictsCC... + IsDupdCC -- see below/above + + | DontCareCC -- We need a cost-centre to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CC is it. + +data CcKind + = UserCC FAST_STRING -- Supplied by user: String is the cc name + | AutoCC Id -- CC -auto-magically inserted for that Id + | DictCC Id + +data IsDupdCC + = AnOriginalCC -- This says how the CC is *used*. Saying that + | ADupdCC -- it is ADupdCC doesn't make it a different + -- CC, just that it a sub-expression which has + -- been moved ("dupd") into a different scope. + -- In the papers, it's called "SCCsub", + -- i.e. SCCsub CC == SCC ADupdCC, + -- but we are trying to avoid confusion between + -- "subd" and "subsumed". So we call the former + -- "dupd". + +data IsCafCC + = IsCafCC + | IsNotCafCC +\end{code} + +WILL: Would there be any merit to recording ``I am now using a +cost-centre from another module''? I don't know if this would help a +user; it might be interesting to us to know how much computation is +being moved across module boundaries. + +SIMON: Maybe later... + +\begin{code} +noCostCentre = NoCostCentre +subsumedCosts = SubsumedCosts +useCurrentCostCentre = CurrentCC +overheadCostCentre = OverheadCC +preludeCafsCostCentre = PreludeCafsCC +dontCareCostCentre = DontCareCC +preludeDictsCostCentre is_dupd + = PreludeDictsCC (if is_dupd then ADupdCC else AnOriginalCC) + +noCostCentreAttached NoCostCentre = True +noCostCentreAttached _ = False + +costsAreSubsumed SubsumedCosts = True +costsAreSubsumed _ = False + +currentOrSubsumedCosts SubsumedCosts = True +currentOrSubsumedCosts CurrentCC = True +currentOrSubsumedCosts _ = False + +mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre + +mkUserCC cc_name module_name group_name + = NormalCC (UserCC cc_name) module_name group_name + AnOriginalCC IsNotCafCC{-might be changed-} + +mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre + +mkDictCC id module_name group_name is_caf + = NormalCC (DictCC id) module_name group_name + AnOriginalCC is_caf + +mkAutoCC id module_name group_name is_caf + = NormalCC (AutoCC id) module_name group_name + AnOriginalCC is_caf + +mkAllCafsCC m g = AllCafsCC m g +mkAllDictsCC m g is_dupd + = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) + +cafifyCC, unCafifyCC, dupifyCC :: CostCentre -> CostCentre + +cafifyCC cc@(AllDictsCC _ _ _) = cc -- ???????? ToDo +cafifyCC cc@(PreludeDictsCC _) = cc -- ditto +cafifyCC (NormalCC kind m g is_dupd is_caf) + = ASSERT(not_a_calf_already is_caf) + NormalCC kind m g is_dupd IsCafCC + where + not_a_calf_already IsCafCC = False + not_a_calf_already _ = True +cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc)) + +-- WDP 95/07: pretty dodgy +unCafifyCC (NormalCC kind m g is_dupd IsCafCC) = NormalCC kind m g is_dupd IsNotCafCC +unCafifyCC (AllCafsCC _ _) = CurrentCC +unCafifyCC PreludeCafsCC = CurrentCC +unCafifyCC (AllDictsCC _ _ _) = CurrentCC +unCafifyCC (PreludeDictsCC _) = CurrentCC +unCafifyCC other_cc = other_cc + +dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC +dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC +dupifyCC (NormalCC kind m g is_dupd is_caf) + = NormalCC kind m g ADupdCC is_caf +dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc)) + +isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool + +isCafCC (AllCafsCC _ _) = True +isCafCC PreludeCafsCC = True +isCafCC (NormalCC _ _ _ _ IsCafCC) = True +isCafCC _ = False + +isDictCC (AllDictsCC _ _ _) = True +isDictCC (PreludeDictsCC _) = True +isDictCC (NormalCC (DictCC _) _ _ _ _) = True +isDictCC _ = False + +isDupdCC (AllDictsCC _ _ ADupdCC) = True +isDupdCC (PreludeDictsCC ADupdCC) = True +isDupdCC (NormalCC _ _ _ ADupdCC _) = True +isDupdCC _ = False + +setToAbleCostCentre :: CostCentre -> Bool + -- Is this a cost-centre to which CCC might reasonably + -- be set? setToAbleCostCentre is allowed to panic on + -- "nonsense" cases, too... + +#if DEBUG +setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre" +setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts" +setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC" +setToAbleCostCentre DontCareCC = panic "setToAbleCC:DontCareCC" +#endif + +setToAbleCostCentre OverheadCC = False -- see comments in type defn +setToAbleCostCentre other = not (isCafCC other || isDictCC other) + +ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool + +ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name +ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name +ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name +ccFromThisModule PreludeCafsCC _ = False +ccFromThisModule (PreludeDictsCC _) _ = False +ccFromThisModule OverheadCC _ = False +ccFromThisModule DontCareCC _ = False + -- shouldn't ask about any others! +\end{code} + +\begin{code} +ccMentionsId :: CostCentre -> Maybe Id + +ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id +ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id +ccMentionsId other = Nothing +\end{code} + +\begin{code} +cmpCostCentre :: CostCentre -> CostCentre -> TAG_ + +cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2 +cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2 +cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_ +cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_ +cmpCostCentre OverheadCC OverheadCC = EQ_ +cmpCostCentre DontCareCC DontCareCC = EQ_ + +cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) + -- first key is module name, then we use "kinds" (which include + -- names) + = case (_CMP_STRING_ m1 m2) of + LT_ -> LT_ + EQ_ -> cmp_kind k1 k2 + GT__ -> GT_ + +cmpCostCentre other_1 other_2 + = let + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT) + tag_CC (AllCafsCC _ _) = ILIT(2) + tag_CC (AllDictsCC _ _ _) = ILIT(3) + tag_CC PreludeCafsCC = ILIT(4) + tag_CC (PreludeDictsCC _) = ILIT(5) + tag_CC OverheadCC = ILIT(6) + tag_CC DontCareCC = ILIT(7) + + -- some BUG avoidance here... + tag_CC NoCostCentre = case (panic "tag_CC:NoCostCentre") of { c -> tag_CC c } + tag_CC SubsumedCosts = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c } + tag_CC CurrentCC = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c } + + +cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2 +cmp_kind (AutoCC i1) (AutoCC i2) = cmpId i1 i2 +cmp_kind (DictCC i1) (DictCC i2) = cmpId i1 i2 +cmp_kind other_1 other_2 + = let + tag1 = tag_CcKind other_1 + tag2 = tag_CcKind other_2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT) + tag_CcKind (AutoCC _) = ILIT(2) + tag_CcKind (DictCC _) = ILIT(3) +\end{code} + +\begin{code} +showCostCentre :: PprStyle -> Bool -> CostCentre -> String +uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty +uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty + +showCostCentre (PprUnfolding _) print_as_string cc + = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding" + ASSERT(not (noCostCentreAttached cc)) + ASSERT(not (currentOrSubsumedCosts cc)) + uppShow 80 (upp_cc_uf cc) + +showCostCentre sty print_as_string cc + = uppShow 80 (uppCostCentre sty print_as_string cc) + +uppCostCentre sty print_as_string NoCostCentre + | friendly_style sty = uppNil + | print_as_string = uppStr "\"NO_CC\"" + | otherwise = uppPStr SLIT("NO_CC") + +uppCostCentre sty print_as_string SubsumedCosts + | print_as_string = uppStr "\"SUBSUMED\"" + | otherwise = uppPStr SLIT("CC_SUBSUMED") + +uppCostCentre sty print_as_string CurrentCC + | print_as_string = uppStr "\"CURRENT_CC\"" + | otherwise = uppPStr SLIT("CCC") + +uppCostCentre sty print_as_string OverheadCC + | print_as_string = uppStr "\"OVERHEAD\"" + | otherwise = uppPStr SLIT("CC_OVERHEAD") + +uppCostCentre sty print_as_string cc + = let + prefix_CC = uppPStr SLIT("CC_") + + basic_thing -- (basic_thing, suffix_CAF) + = do_cc cc + + basic_thing_string + = if friendly_sty then basic_thing else stringToC basic_thing + in + if print_as_string then + uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"'] + + else if friendly_sty then + uppStr basic_thing + else + uppBesides [prefix_CC, + prettyToUn (identToC (_PK_ basic_thing))] + where + friendly_sty = friendly_style sty + + add_module_name_maybe m str + = if print_as_string then str else (str ++ ('.' : m)) + + ---------------- + do_cc OverheadCC = "OVERHEAD" + do_cc DontCareCC = "DONT_CARE" + do_cc (AllCafsCC m _) = if print_as_string + then "CAFs_in_..." + else "CAFs." ++ _UNPK_ m + do_cc (AllDictsCC m _ d) = do_dupd d ( + if print_as_string + then "DICTs_in_..." + else "DICTs." ++ _UNPK_ m) + do_cc PreludeCafsCC = if print_as_string + then "CAFs_in_..." + else "CAFs" + do_cc (PreludeDictsCC d) = do_dupd d ( + if print_as_string + then "DICTs_in_..." + else "DICTs") + + do_cc (NormalCC kind mod_name grp_name is_dupd is_caf) + = let + basic_kind = do_kind kind + is_a_calf = do_calved is_caf + in + if friendly_sty then + do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf) + else + basic_kind + where + do_kind (UserCC name) = _UNPK_ name + do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "") + do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "") + + do_id :: Id -> String + do_id id + = if print_as_string + then _UNPK_ (getOccurrenceName id) -- don't want module in the name + else showId sty id -- we really do + + do_calved IsCafCC = "/CAF" + do_calved _ = "" + + --------------- + do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str + do_dupd _ str = str + +friendly_style sty -- i.e., probably for human consumption + = case sty of + PprForUser -> True + PprDebug -> True + PprShowAll -> True + _ -> False +\end{code} + +Printing unfoldings is sufficiently weird that we do it separately. +This should only apply to CostCentres that can be ``set to'' (cf +@setToAbleCostCentre@). That excludes CAFs and +`overhead'---which are added at the very end---but includes dictionaries. +Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info; +even if we won't ultimately do a \tr{SET_CCC} from it. +\begin{code} +upp_cc_uf (PreludeDictsCC d) + = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] +upp_cc_uf (AllDictsCC m g d) + = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d] + +upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) + = ASSERT(isDictCC cc || setToAbleCostCentre cc) + uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), + upp_dupd is_dupd, pp_caf is_caf] + where + pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name))) + pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id) + pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id) + + show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id) + where + no_in_scopes = emptyUniqSet + + pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_") + pp_caf IsNotCafCC = uppPStr SLIT("_N_") + +#ifdef DEBUG +upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other)) +#endif + +upp_dupd AnOriginalCC = uppPStr SLIT("_N_") +upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_") +\end{code} + +\begin{code} +uppCostCentreDecl sty is_local cc +#ifdef DEBUG + | noCostCentreAttached cc || currentOrSubsumedCosts cc + = panic "uppCostCentreDecl: no cost centre!" + | otherwise +#endif + = if is_local then + uppBesides [ + uppStr "CC_DECLARE(", + upp_ident, uppComma, + uppCostCentre sty True {-as String!-} cc, uppComma, + pp_str mod_name, uppComma, + pp_str grp_name, uppComma, + uppStr is_subsumed, uppComma, + if externally_visible then uppNil else uppPStr SLIT("static"), + uppStr ");"] + else + uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ] + where + upp_ident = uppCostCentre sty False{-as identifier!-} cc + + pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"') + pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'') + + (mod_name, grp_name, is_subsumed, externally_visible) + = case cc of + AllCafsCC m g -> (m, g, cc_IS_CAF, True) + + AllDictsCC m g _ -> (m, g, cc_IS_DICT, True) + + NormalCC (DictCC i) m g is_dupd is_caf + -> (m, g, cc_IS_DICT, externallyVisibleId i) + + NormalCC x m g is_dupd is_caf + -> (m, g, do_caf is_caf, + case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i}) + where + cc_IS_CAF = "CC_IS_CAF" + cc_IS_DICT = "CC_IS_DICT" + cc_IS_SUBSUMED = "CC_IS_SUBSUMED" + cc_IS_BORING = "CC_IS_BORING" + + do_caf IsCafCC = cc_IS_CAF + do_caf IsNotCafCC = cc_IS_BORING +\end{code} diff --git a/ghc/compiler/profiling/NOTES b/ghc/compiler/profiling/NOTES new file mode 100644 index 0000000..c50cf56 --- /dev/null +++ b/ghc/compiler/profiling/NOTES @@ -0,0 +1,301 @@ +Profiling Implementation Notes -- June/July/Sept 1994 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Simon and Will + +Pre-code-generator-ish +~~~~~~~~~~~~~~~~~~~~~~ + +* Automagic insertion of _sccs_ on... + + - If -auto is specified, add _scc_ on each *exported* top-level definition. + NB this includes CAFs. Done by addAutoCostCentres (Core-to-Core pass). + + - If -auto-all is specified, add _scc_ on *all* top-level definitions. + Done by same pass. + + - Always: just before code generation of module M, onto any CAF + which hasn't already got an explicit cost centre attached, pin + "AllCAFs-M". + + Done by finalStgMassageForProfiling (final STG-to-STG pass) + + Only the one-off costs of evaluating the CAFs will be attributed + to the AllCAFs-M cost centre. We hope that these costs will be + small; since the _scc_s are introduced automatically it's + confusing to attribute any significant costs to them. However if + there *are* significant one-off costs we'd better know about it. + + Why so late in the compilation process? We aren't *absolutely* + sure what is and isn't a CAF until *just* before code generation. + So we don't want to mark them as such until then. + + - Individual DICTs + + We do it in the desugarer, because that's the *only* point at + which we *know* exactly what bindings are introduced by + overloading. NB should include bindings for selected methods, eg + + f d = let op = _scc_ DICT op_sel d in + ...op...op...op + + The DICT CC ensures that: + (a) [minor] that the selection cost is separately attributed + (b) [major] that the cost of executing op is attributed to + its call site, eg + + ...(scc "a" op)...(scc "b" op)...(scc "c" op)... + +* Automagic "boxing" of higher-order args: + + finalStgMassageForProfiling (final STG-to-STG pass) + + This (as well as CAF stuff above) is really quite separate + from the other business of finalStgMassageForProfiling + (collecting up CostCentres that need to be + declared/registered). + + But throwing it all into the pot together means that we don't + have to have Yet Another STG Syntax Walker. + + Furthermore, these "boxes" are really just let-bindings that + many other parts of the compiler will happily substitute away! + Doing them at the very last instant prevents this. + + A down side of doing these so late is that we get lots of + "let"s, which if generated earlier and not substituted away, + could be floated outwards. Having them floated outwards would + lessen the chance of skewing profiling results (because of + gratuitous "let"s added by the compiler into the inner loop of + some program...). The allocation itself will be attributed to + profiling overhead; the only thing which'll be skewed is time measurement. + + So if we have, post-boxing-higher-order-args... + + _scc_ "foo" ( let f' = [f] \ [] f + in + map f' xs ) + + ... we want "foo" to be put in the thunk for "f'", but we want the + allocation cost (heap census stuff) to be attr to OVERHEAD. + + As an example of what could be improved + f = _scc_ "f" (g h) + To save dynamic allocation, we could have a static closure for h: + h_inf = _scc_ "f" h + f = _scc_ "f" (g h_inf) + + + + + +Code generator-ish +~~~~~~~~~~~~~~~~~~ + +(1) _Entry_ code for a closure *usually* sets CC from the closure, + at the fast entry point + + Exceptions: + + (a) Top-level subsumed functions (i.e., w/ no _scc_ on them) + + Refrain from setting CC from the closure + + (b) Constructors + + Again, refrain. (This is *new*) + + Reasons: (i) The CC will be zapped very shortly by the restore + of the enclosing CC when we return to the eval'ing "case". + (ii) Any intervening updates will indirect to this existing + constructor (...mumble... new update mechanism... mumble...) + +(2) "_scc_ cc expr" + + Set current CC to "cc". + No later "restore" of the previous CC is reqd. + +(3) "case e of { ...alts... }" expression (eval) + + Save CC before eval'ing scrutinee + Restore CC at the start of the case-alternative(s) + +(4) _Updates_ : updatee gets current CC + + (???? not sure this is OK yet 94/07/04) + + Reasons: + + * Constructors : want to be insensitive to return-in-heap vs + return-in-regs. For example, + + f x = _scc_ "f" (x, x) + + The pair (x,x) would get CC of "f" if returned-in-heap; + therefore, updatees should get CC of "f". + + * PAPs : Example: + + f x = _scc_ "f" (let g = \ y -> ... in g) + + At the moment of update (updatePAP?), CC is "f", which + is what we want to set it to if the "updatee" is entered + + When we enter the PAP ("please put the arguments back so I can + use them"), we restore the setup as at the moment the + arg-satisfaction check failed. + + Be careful! UPDATE_PAP is called from the arg-satis check, + which is before the fast entry point. So the cost centre + won't yet have been set from the closure which has just + been entered. Solution: in UPDATE_PAP see if the cost centre inside + the function closure which is being entered is "SUB"; if so, use + the current cost centre to update the updatee; otherwise use that + inside the function closure. (See the computation of cc_pap + in rule 16_l for lexical semantics.) + + +(5) CAFs + +CAFs get their own cost centre. Ie + + x = e +is transformed to + x = _scc_ "CAF:x" e + +Or sometimes we lump all the CAFs in a module together. +(Reporting issue or code-gen issue?) + + + +Hybrid stuff +~~~~~~~~~~~~ + +The problem: + + f = _scc_ "CAF:f" (let g = \xy -> ... + in (g,g)) + +Now, g has cost-centre "CAF:f", and is returned as part of +the result. So whenever the function embedded in the result +is called, the costs will accumulate to "CAF:f". This is +particularly (de)pressing for dictionaries, which contain lots +of functions. + +Solution: + + A. Whenever in case (1) above we would otherwise "set the CC from the + closure", we *refrain* from doing so if + (a) the closure is a function, not a thunk; and + (b) the cost-centre in the closure is a CAF cost centre. + + B. Whenever we enter a thunk [at least, one which might return a function] + we save the current cost centre in the update frame. Then, UPDATE_PAP + restores the saved cost centre from the update frame iff the cost + centre at the point of update (cc_pap in (4) above) is a CAF cost centre. + + It isn't necessary to save and possibly-restore the cost centre for + thunks which will certainly return a constructor, because the + cost centre is about to be restored anyway by the enclosing case. + +Both A and B are runtime tests. For A, consider: + + f = _scc_ "CAF:f" (g 2) + + h y = _scc_ "h" g (y+y) + + g x = let w = \p -> ... + in (w,w) + + +Now, in the call to g from h, the cost-centre on w will be "h", and +indeed all calls to the result of the call should be attributed to +"h". + + ... _scc_ "x1" (let (t,_) = h 2 in t 3) ... + + Costs of executing (w 3) attributed to "h". + +But in the call to g from f, the cost-centre on w will be +"CAF:f", and calls to w should be attributed to the call site. + + ..._scc_ "x2" (let (t,_) = f in t 3)... + + Costs of executing (w 3) attributed to "x2". + + + Remaining problem + +Consider + + _scc_ "CAF:f" (if expensive then g 2 else g 3) + +where g is a function with arity 2. In theory we should +restore the enclosing cost centre once we've reduced to +(g 2) or (g 3). In practice this is pretty tiresome; and pretty rare. + +A quick fix: given (_scc_ "CAF" e) where e might be function-valued +(in practice we usually know, because CAF sccs are top level), transform to + + _scc_ "CAF" (let f = e in f) + + + + + +============ + +scc cc x ===> x + + UNLESS + +(a) cc is a user-defined, non-dup'd cost + centre (so we care about entry counts) + +OR + +(b) cc is not a CAF/DICT cost centre and x is top-level subsumed + function. + [If x is lambda/let bound it'll have a cost centre + attached dynamically.] + + To repeat, the transformation is OK if + x is a not top-level subsumed function + OR + cc is a CAF/DICT cost centre and x is a top-level + subsumed function + + + +(scc cc e) x ===> (scc cc e x) + + OK????? IFF + +cc is not CAF/DICT --- remains to be proved!!!!!! +True for lex +False for eval +Can we tell which in hybrid? + +eg Is this ok? + + (scc "f" (scc "CAF" (\x.b))) y ==> (scc "f" (scc "CAF" (\x.b) y)) + + +\x -> (scc cc e) ===> (scc cc \x->e) + + OK IFF cc is not CAF/DICT + + +scc cc1 (scc cc2 e)) ===> scc cc2 e + + IFF not interested in cc1's entry count + AND cc2 is not CAF/DICT + +(scc cc1 ... (scc cc2 e) ...) ===> (scc cc1 ... e ...) + + IFF cc2 is CAF/DICT + AND e is a lambda not appearing as the RHS of a let + OR + e is a variable not bound to SUB + + diff --git a/ghc/compiler/profiling/SCCauto.hi b/ghc/compiler/profiling/SCCauto.hi new file mode 100644 index 0000000..b65db55 --- /dev/null +++ b/ghc/compiler/profiling/SCCauto.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SCCauto where +import CmdLineOpts(GlobalSwitch, SwitchResult) +import CoreSyn(CoreBinding) +import Id(Id) +import PreludePS(_PackedString) +addAutoCostCentres :: (GlobalSwitch -> SwitchResult) -> _PackedString -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLS" _N_ _N_ #-} + diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs new file mode 100644 index 0000000..1a32e56 --- /dev/null +++ b/ghc/compiler/profiling/SCCauto.lhs @@ -0,0 +1,80 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[SCCauto]{Automated SCC annotations} + +Automatic insertion of \tr{_scc_} annotations for top-level bindings. + +Automatic insertion of \tr{_scc_} annotations on CAFs is better left +until STG land. We do DICT annotations there, too, but maybe +that will turn out to be a bummer... (WDP 94/06) + +This is a Core-to-Core pass (usually run {\em last}). + +\begin{code} +#include "HsVersions.h" + +module SCCauto ( addAutoCostCentres ) where + +import CmdLineOpts +import Id ( isTopLevId ) +import PlainCore +import Outputable ( isExported ) +import CostCentre -- ( mkAutoCC ) +import Util -- for pragmas only +\end{code} + +\begin{code} +addAutoCostCentres + :: (GlobalSwitch -> SwitchResult) -- cmd-line switches + -> FAST_STRING -- module name + -> [PlainCoreBinding] -- input + -> [PlainCoreBinding] -- output + +addAutoCostCentres sw_chkr mod_name binds + = if not doing_something then + binds -- now *that* was quick... + else + map scc_top_bind binds + where + doing_something = auto_all_switch_on || auto_exported_switch_on + + auto_all_switch_on = switchIsOn sw_chkr AutoSccsOnAllToplevs -- only use! + auto_exported_switch_on = switchIsOn sw_chkr AutoSccsOnExportedToplevs -- only use! + + grp_name = case (stringSwitchSet sw_chkr SccGroup) of + Just xx -> _PK_ xx + Nothing -> mod_name -- default: module name + + ----------------------------- + scc_top_bind (CoNonRec binder rhs) + = CoNonRec binder (scc_auto binder rhs) + + scc_top_bind (CoRec pairs) + = CoRec (map scc_pair pairs) + where + scc_pair (binder, rhs) = (binder, scc_auto binder rhs) + + ----------------------------- + -- Automatic scc annotation for user-defined top-level Ids + + scc_auto binder rhs + = if isTopLevId binder + && (auto_all_switch_on || isExported binder) + then scc_rhs rhs + else rhs + where + -- park auto SCC inside lambdas; don't put one there + -- if there already is one. + + scc_rhs rhs + = let + (tyvars, vars, body) = digForLambdas rhs + in + case body of + CoSCC _ _ -> rhs -- leave it + CoCon _ _ _ --??? | null vars + -> rhs + _ -> mkFunction tyvars vars + (CoSCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body) +\end{code} diff --git a/ghc/compiler/profiling/SCCfinal.hi b/ghc/compiler/profiling/SCCfinal.hi new file mode 100644 index 0000000..3814da2 --- /dev/null +++ b/ghc/compiler/profiling/SCCfinal.hi @@ -0,0 +1,11 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SCCfinal where +import CmdLineOpts(GlobalSwitch) +import CostCentre(CostCentre) +import Id(Id) +import PreludePS(_PackedString) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +stgMassageForProfiling :: _PackedString -> _PackedString -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [StgBinding Id Id] -> (([CostCentre], [CostCentre]), [StgBinding Id Id]) + {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs new file mode 100644 index 0000000..06d4663 --- /dev/null +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -0,0 +1,445 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[SCCfinal]{Modify and collect code generation for final StgProgram} + +This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. + +* Traverses the STG program collecting the cost centres. These are + required to declare the cost centres at the start of code + generation. + + Note: because of cross-module unfolding, some of these cost centres + may be from other modules. But will still have to give them + "extern" declarations. + +* Puts on CAF cost-centres if the user has asked for individual CAF + cost-centres. + +* Ditto for individual DICT cost-centres. + +* Boxes top-level inherited functions passed as arguments. + +* "Distributes" given cost-centres to all as-yet-unmarked RHSs. + +\begin{code} +#include "HsVersions.h" + +module SCCfinal ( stgMassageForProfiling ) where + +import Pretty -- ToDo: rm (debugging only) + +import AbsUniType ( isDictTy, getUniDataTyCon_maybe, + isTupleTyCon, isFunType, getTauType, + splitType -- pragmas + ) +import CmdLineOpts +import CostCentre +import Id ( mkSysLocal, getIdUniType ) +import SrcLoc ( mkUnknownSrcLoc ) +import StgSyn +import SplitUniq +import UniqSet ( emptyUniqSet + IF_ATTACK_PRAGMAS(COMMA emptyUFM) + ) +import Unique +import Util + +infixr 9 `thenMM`, `thenMM_` +\end{code} + +\begin{code} +type CollectedCCs = ([CostCentre], -- locally defined ones + [CostCentre]) -- ones needing "extern" decls + +stgMassageForProfiling + :: FAST_STRING -> FAST_STRING -- module name, group name + -> SplitUniqSupply -- unique supply + -> (GlobalSwitch -> Bool) -- command-line opts checker + -> [PlainStgBinding] -- input + -> (CollectedCCs, [PlainStgBinding]) + +stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds + = let + ((local_ccs, extern_ccs), + stg_binds2) + = initMM mod_name us (mapMM do_top_binding stg_binds) + + fixed_ccs + = if do_auto_sccs_on_cafs || doing_prelude + then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC) + else [all_cafs_cc] + + local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs) + extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs) + in + ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2) + where + do_auto_sccs_on_cafs = sw_chkr AutoSccsOnIndividualCafs -- only use! +--UNUSED: do_auto_sccs_on_dicts = sw_chkr AutoSccsOnIndividualDicts -- only use! ** UNUSED really ** + doing_prelude = sw_chkr CompilingPrelude + + all_cafs_cc = if doing_prelude + then preludeCafsCostCentre + else mkAllCafsCC mod_name grp_name + + ---------- + do_top_binding :: PlainStgBinding -> MassageM PlainStgBinding + + do_top_binding (StgNonRec b rhs) + = do_top_rhs b rhs `thenMM` \ rhs' -> + returnMM (StgNonRec b rhs') + + do_top_binding (StgRec pairs) + = mapMM do_pair pairs `thenMM` \ pairs2 -> + returnMM (StgRec pairs2) + where + do_pair (b, rhs) + = do_top_rhs b rhs `thenMM` \ rhs2 -> + returnMM (b, rhs2) + + ---------- + do_top_rhs :: Id -> PlainStgRhs -> MassageM PlainStgRhs + + do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgConApp con args lvs))) + -- top-level _scc_ around nothing but static data; toss it -- it's pointless + = returnMM (StgRhsCon dontCareCostCentre con args) + + do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr)) +-- OLD: +-- | noCostCentreAttached rhs_cc || currentOrSubsumedCosts rhs_cc +-- -- doubtful guard... ToDo? + -- Top level CAF with explicit scc expression. Attach CAF + -- cost centre to StgRhsClosure and collect. + = let + calved_cc = cafifyCC cc + in + collectCC calved_cc `thenMM_` + set_prevailing_cc calved_cc ( + do_expr expr + ) `thenMM` \ expr' -> + returnMM (StgRhsClosure calved_cc bi fv u [] expr') + + do_top_rhs binder (StgRhsClosure cc bi fv u [] body) + | noCostCentreAttached cc || currentOrSubsumedCosts cc + -- Top level CAF without a cost centre attached: Collect + -- cost centre with binder name, if collecting CAFs. + = let + (did_something, cc2) + = if do_auto_sccs_on_cafs then + (True, mkAutoCC binder mod_name grp_name IsCafCC) + else + (False, all_cafs_cc) + in + (if did_something + then collectCC cc2 + else nopMM) `thenMM_` + set_prevailing_cc cc2 ( + do_expr body + ) `thenMM` \body2 -> + returnMM (StgRhsClosure cc2 bi fv u [] body2) + + do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr)) + -- We blindly use the cc off the _scc_ + = set_prevailing_cc cc ( + do_expr body + ) `thenMM` \ body2 -> + returnMM (StgRhsClosure cc bi fv u args body2) + + do_top_rhs binder (StgRhsClosure cc bi fv u args body) + = let + cc2 = if noCostCentreAttached cc + then subsumedCosts -- it's not a thunk; it is top-level & arity > 0 + else cc + in + set_prevailing_cc cc2 ( + do_expr body + ) `thenMM` \ body' -> + returnMM (StgRhsClosure cc2 bi fv u args body') + + do_top_rhs binder (StgRhsCon cc con args) + = returnMM (StgRhsCon dontCareCostCentre con args) + -- Top-level (static) data is not counted in heap + -- profiles; nor do we set CCC from it; so we + -- just slam in dontCareCostCentre + + ------ + do_expr :: PlainStgExpr -> MassageM PlainStgExpr + + do_expr (StgApp fn args lvs) + = boxHigherOrderArgs (StgApp fn) args lvs + + do_expr (StgConApp con args lvs) + = boxHigherOrderArgs (StgConApp con) args lvs + + do_expr (StgPrimApp op args lvs) + = boxHigherOrderArgs (StgPrimApp op) args lvs + + do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre! + = collectCC cc `thenMM_` + set_prevailing_cc cc ( + do_expr expr + ) `thenMM` \ expr' -> + returnMM (StgSCC ty cc expr') + + do_expr (StgCase expr fv1 fv2 uniq alts) + = do_expr expr `thenMM` \ expr' -> + do_alts alts `thenMM` \ alts' -> + returnMM (StgCase expr' fv1 fv2 uniq alts') + where + do_alts (StgAlgAlts ty alts def) + = mapMM do_alt alts `thenMM` \ alts' -> + do_deflt def `thenMM` \ def' -> + returnMM (StgAlgAlts ty alts' def') + where + do_alt (id, bs, use_mask, e) + = do_expr e `thenMM` \ e' -> + returnMM (id, bs, use_mask, e') + + do_alts (StgPrimAlts ty alts def) + = mapMM do_alt alts `thenMM` \ alts' -> + do_deflt def `thenMM` \ def' -> + returnMM (StgPrimAlts ty alts' def') + where + do_alt (l,e) + = do_expr e `thenMM` \ e' -> + returnMM (l,e') + + do_deflt StgNoDefault = returnMM StgNoDefault + do_deflt (StgBindDefault b is_used e) + = do_expr e `thenMM` \ e' -> + returnMM (StgBindDefault b is_used e') + + do_expr (StgLet b e) + = set_prevailing_cc_maybe useCurrentCostCentre ( + do_binding b `thenMM` \ b' -> + do_expr e `thenMM` \ e' -> + returnMM (StgLet b' e') ) + + do_expr (StgLetNoEscape lvs1 lvs2 rhs body) + = set_prevailing_cc_maybe useCurrentCostCentre ( + do_binding rhs `thenMM` \ rhs' -> + do_expr body `thenMM` \ body' -> + returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') ) + + ---------- + do_binding :: PlainStgBinding -> MassageM PlainStgBinding + + do_binding (StgNonRec b rhs) + = do_rhs rhs `thenMM` \ rhs' -> + returnMM (StgNonRec b rhs') + + do_binding (StgRec pairs) + = mapMM do_pair pairs `thenMM` \ new_pairs -> + returnMM (StgRec new_pairs) + where + do_pair (b, rhs) + = do_rhs rhs `thenMM` \ rhs' -> + returnMM (b, rhs') + + do_rhs :: PlainStgRhs -> MassageM PlainStgRhs + -- We play much the same game as we did in do_top_rhs above; + -- but we don't have to worry about cafifying, etc. + -- (ToDo: consolidate??) + +{- Patrick says NO: it will mess up our counts (WDP 95/07) + do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgConApp con args lvs))) + = collectCC cc `thenMM_` + returnMM (StgRhsCon cc con args) +-} + + do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _)) + = set_prevailing_cc cc ( + do_expr body + ) `thenMM` \ body' -> + returnMM (StgRhsClosure cc bi fv u args body') + + do_rhs (StgRhsClosure cc bi fv u args body) + = use_prevailing_cc_maybe cc `thenMM` \ cc2 -> + set_prevailing_cc cc2 ( + do_expr body + ) `thenMM` \ body' -> + returnMM (StgRhsClosure cc2 bi fv u args body') + + do_rhs (StgRhsCon cc con args) + = use_prevailing_cc_maybe cc `thenMM` \ cc2 -> + returnMM (StgRhsCon cc2 con args) + -- ToDo: Box args (if lex) Pass back let binding??? + -- Nope: maybe later? WDP 94/06 +\end{code} + +%************************************************************************ +%* * +\subsection{Boxing higher-order args} +%* * +%************************************************************************ + +\begin{code} +boxHigherOrderArgs + :: ([PlainStgAtom] -> PlainStgLiveVars -> PlainStgExpr) + -- An application lacking its arguments and live-var info + -> [PlainStgAtom] -- arguments which we might box + -> PlainStgLiveVars -- live var info, which we do *not* try + -- to maintain/update (setStgVarInfo will + -- do that) + -> MassageM PlainStgExpr + +boxHigherOrderArgs almost_expr args live_vars + = mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) -> + get_prevailing_cc `thenMM` \ cc -> + returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings) + where + --------------- + do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom) + + do_arg bindings atom@(StgVarAtom old_var) + = let + var_type = getIdUniType old_var + in + if not (is_fun_type var_type) then + returnMM (bindings, atom) -- easy + else + -- make a trivial let-binding for the higher-order guy + getUniqueMM `thenMM` \ uniq -> + let + new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc + in + returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var ) + where + is_fun_type ty = isFunType (getTauType ty) + + --------------- + mk_stg_let :: CostCentre -> (Id, Id) -> PlainStgExpr -> PlainStgExpr + + mk_stg_let cc (new_var, old_var) body + = let + rhs_body = StgApp (StgVarAtom old_var) [{-no args-}] bOGUS_LVs + + rhs = StgRhsClosure cc + stgArgOcc -- safe... + [{-junk-}] Updatable [{-no args-}] rhs_body + in + StgLet (StgNonRec new_var rhs) body + where + bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" +\end{code} + +%************************************************************************ +%* * +\subsection{Boring monad stuff for this} +%* * +%************************************************************************ + +\begin{code} +type MassageM result + = FAST_STRING -- module name + -> CostCentre -- prevailing CostCentre + -- if none, subsumedCosts at top-level + -- useCurrentCostCentre at nested levels + -> SplitUniqSupply + -> CollectedCCs + -> (CollectedCCs, result) + +-- the initUs function also returns the final UniqueSupply and CollectedCCs + +initMM :: FAST_STRING -- module name, which we may consult + -> SplitUniqSupply + -> MassageM a + -> (CollectedCCs, a) + +initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[]) + +thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b +thenMM_ :: MassageM a -> (MassageM b) -> MassageM b + +thenMM expr cont mod scope_cc us ccs + = case splitUniqSupply us of { (s1, s2) -> + case (expr mod scope_cc s1 ccs) of { (ccs2, result) -> + cont result mod scope_cc s2 ccs2 }} + +thenMM_ expr cont mod scope_cc us ccs + = case splitUniqSupply us of { (s1, s2) -> + case (expr mod scope_cc s1 ccs) of { (ccs2, _) -> + cont mod scope_cc s2 ccs2 }} + +returnMM :: a -> MassageM a +returnMM result mod scope_cc us ccs = (ccs, result) + +nopMM :: MassageM () +nopMM mod scope_cc us ccs = (ccs, ()) + +mapMM :: (a -> MassageM b) -> [a] -> MassageM [b] + +mapMM f [] = returnMM [] +mapMM f (m:ms) + = f m `thenMM` \ r -> + mapMM f ms `thenMM` \ rs -> + returnMM (r:rs) + +mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y]) + +mapAccumMM f b [] = returnMM (b, []) +mapAccumMM f b (m:ms) + = f b m `thenMM` \ (b2, r) -> + mapAccumMM f b2 ms `thenMM` \ (b3, rs) -> + returnMM (b3, r:rs) + +getUniqueMM :: MassageM Unique +getUniqueMM mod scope_cc us ccs = (ccs, getSUnique us) +\end{code} + +\begin{code} +set_prevailing_cc, set_prevailing_cc_maybe + :: CostCentre -> MassageM a -> MassageM a + +set_prevailing_cc cc_to_set_to action mod scope_cc us ccs + = action mod cc_to_set_to us ccs + -- set unconditionally + +set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs + = let + -- used when switching from top-level to nested + -- scope; if we were chugging along as "subsumed", + -- we change to the new thing; otherwise we + -- keep what we had. + + cc_to_use + = if (costsAreSubsumed scope_cc) + then cc_to_set_to + else scope_cc -- carry on as before + in + action mod cc_to_use us ccs + +get_prevailing_cc :: MassageM CostCentre +get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc) + +use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre + +use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs + = let + cc_to_use + = if not (noCostCentreAttached cc_to_try + || currentOrSubsumedCosts cc_to_try) then + cc_to_try + else + uncalved_scope_cc + -- carry on as before, but be sure it + -- isn't marked as CAFish (we're + -- crossing a lambda...) + in + (ccs, cc_to_use) + where + uncalved_scope_cc = unCafifyCC scope_cc +\end{code} + +\begin{code} +collectCC :: CostCentre -> MassageM () + +collectCC cc mod_name scope_cc us (local_ccs, extern_ccs) + = ASSERT(not (noCostCentreAttached cc)) + ASSERT(not (currentOrSubsumedCosts cc)) + if (cc `ccFromThisModule` mod_name) then + ((cc : local_ccs, extern_ccs), ()) + else -- must declare it "extern" + ((local_ccs, cc : extern_ccs), ()) +\end{code} diff --git a/ghc/compiler/reader/Jmakefile b/ghc/compiler/reader/Jmakefile new file mode 100644 index 0000000..905d494 --- /dev/null +++ b/ghc/compiler/reader/Jmakefile @@ -0,0 +1,18 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) + +HaskellSuffixRules() + +LitSuffixRule(.lit,/*none*/) /* no language really */ +LitSuffixRule(.lhs,.hs) /* Haskell */ +LitSuffixRule(.lhc,.hc) /* Haskell assembler (C) */ +LitSuffixRule(.lprl,.prl) /* Perl */ +LitSuffixRule(.lsh,.sh) /* Bourne shell */ +LitSuffixRule(.lc,.c) /* C */ +LitSuffixRule(.lh,.h) +LitSuffixRule(.llex,.lex) /* Lex */ +LitSuffixRule(.lflex,.flex) /* Flex */ + +LitDocRootTargetWithNamedOutput(reader,lit,reader-standalone) diff --git a/ghc/compiler/reader/PrefixSyn.hi b/ghc/compiler/reader/PrefixSyn.hi new file mode 100644 index 0000000..8ed77a5 --- /dev/null +++ b/ghc/compiler/reader/PrefixSyn.hi @@ -0,0 +1,23 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PrefixSyn where +import HsBinds(Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsExpr(Expr) +import HsImpExp(IfaceImportDecl) +import HsPat(InPat) +import HsPragmas(ClassOpPragmas, GenPragmas) +import HsTypes(PolyType) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +data RdrBinding = RdrNullBind | RdrAndBindings RdrBinding RdrBinding | RdrTyData (TyDecl ProtoName) | RdrTySynonym (TyDecl ProtoName) | RdrFunctionBinding Int [RdrMatch] | RdrPatternBinding Int [RdrMatch] | RdrClassDecl (ClassDecl ProtoName (InPat ProtoName)) | RdrInstDecl (_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)) | RdrDefaultDecl (DefaultDecl ProtoName) | RdrIfaceImportDecl IfaceImportDecl | RdrTySig [ProtoName] (PolyType ProtoName) RdrTySigPragmas SrcLoc | RdrSpecValSig [Sig ProtoName] | RdrInlineValSig (Sig ProtoName) | RdrDeforestSig (Sig ProtoName) | RdrMagicUnfoldingSig (Sig ProtoName) | RdrSpecInstSig (SpecialisedInstanceSig ProtoName) | RdrAbstractTypeSig (DataTypeSig ProtoName) | RdrSpecDataSig (DataTypeSig ProtoName) +type RdrId = ProtoName +data RdrMatch = RdrMatch Int _PackedString (InPat ProtoName) [(Expr ProtoName (InPat ProtoName), Expr ProtoName (InPat ProtoName))] RdrBinding +data RdrTySigPragmas = RdrNoPragma | RdrGenPragmas (GenPragmas ProtoName) | RdrClassOpPragmas (ClassOpPragmas ProtoName) +type SigConverter = RdrBinding -> [Sig ProtoName] +type SrcFile = _PackedString +type SrcFun = _PackedString +type SrcLine = Int +readInteger :: [Char] -> Integer + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs new file mode 100644 index 0000000..6dc0e55 --- /dev/null +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -0,0 +1,121 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[PrefixSyn]{``Prefix-form'' syntax} + +This module contains an algebraic data type into which a prefix form +string from the current Haskell parser is converted. Given in an +order that follows the \tr{Prefix_Form} document. + +\begin{code} +#include "HsVersions.h" + +module PrefixSyn ( + RdrBinding(..), + RdrId(..), + RdrMatch(..), + RdrTySigPragmas(..), + SigConverter(..), + SrcFile(..), + SrcFun(..), + SrcLine(..), + + readInteger + ) where + +import AbsSyn +import ProtoName ( ProtoName(..) ) -- .. is for pragmas only +import Outputable +import Util -- pragmas only + +type RdrId = ProtoName +type SrcLine = Int +type SrcFile = FAST_STRING +type SrcFun = FAST_STRING +\end{code} + +\begin{code} +data RdrBinding + = RdrNullBind + | RdrAndBindings RdrBinding RdrBinding + + | RdrTyData ProtoNameTyDecl + | RdrTySynonym ProtoNameTyDecl + | RdrFunctionBinding SrcLine [RdrMatch] + | RdrPatternBinding SrcLine [RdrMatch] + | RdrClassDecl ProtoNameClassDecl + | RdrInstDecl ( FAST_STRING{-original module's name-} -> + FAST_STRING{-informant module's name-} -> + Bool{-from here?-} -> + ProtoNameInstDecl ) + | RdrDefaultDecl ProtoNameDefaultDecl + | RdrIfaceImportDecl IfaceImportDecl + + -- signatures are mysterious; we can't + -- tell if its a Sig or a ClassOpSig, + -- so we just save the pieces: + | RdrTySig [ProtoName] -- vars getting sigs + ProtoNamePolyType -- the type + RdrTySigPragmas -- val/class-op pragmas + SrcLoc + + -- user pragmas come in in a Sig-ish way/form... + | RdrSpecValSig [ProtoNameSig] + | RdrInlineValSig ProtoNameSig + | RdrDeforestSig ProtoNameSig + | RdrMagicUnfoldingSig ProtoNameSig + | RdrSpecInstSig ProtoNameSpecialisedInstanceSig + | RdrAbstractTypeSig ProtoNameDataTypeSig + | RdrSpecDataSig ProtoNameDataTypeSig + +data RdrTySigPragmas + = RdrNoPragma + | RdrGenPragmas ProtoNameGenPragmas + | RdrClassOpPragmas ProtoNameClassOpPragmas + +type SigConverter = RdrBinding {- a RdrTySig... -} -> [ProtoNameSig] +\end{code} + +\begin{code} +data RdrMatch + = RdrMatch SrcLine SrcFun ProtoNamePat [(ProtoNameExpr, ProtoNameExpr)] RdrBinding + -- (guard, expr) +\end{code} + +Unscramble strings representing oct/dec/hex integer literals: +\begin{code} +readInteger :: String -> Integer + +readInteger ('-' : xs) = - (readInteger xs) +readInteger ('0' : 'o' : xs) = chk (stoo 0 xs) +readInteger ('0' : 'x' : xs) = chk (stox 0 xs) +readInteger ['0'] = 0 -- efficiency shortcut? +readInteger ['1'] = 1 -- ditto? +readInteger xs = chk (stoi 0 xs) + +chk (i, "") = i +chk (i, junk) = panic ("readInteger: junk after reading:"++junk) + +stoo, stoi, stox :: Integer -> String -> (Integer, String) + +stoo a (c:cs) | is_oct c = stoo (a*8 + ord_ c - ord_0) cs +stoo a cs = (a, cs) + +stoi a (c:cs) | isDigit c = stoi (a*10 + ord_ c - ord_0) cs +stoi a cs = (a, cs) + +stox a (c:cs) | isDigit c = stox (a_16_ord_c - ord_0) cs + | is_hex c = stox (a_16_ord_c - ord_a + 10) cs + | is_Hex c = stox (a_16_ord_c - ord_A + 10) cs + where a_16_ord_c = a*16 + ord_ c +stox a cs = (a, cs) + +is_oct c = c >= '0' && c <= '7' +is_hex c = c >= 'a' && c <= 'f' +is_Hex c = c >= 'A' && c <= 'F' + +ord_ c = toInteger (ord c) + +ord_0, ord_a, ord_A :: Integer +ord_0 = ord_ '0'; ord_a = ord_ 'a'; ord_A = ord_ 'A' +\end{code} diff --git a/ghc/compiler/reader/PrefixToHs.hi b/ghc/compiler/reader/PrefixToHs.hi new file mode 100644 index 0000000..c51ebb4 --- /dev/null +++ b/ghc/compiler/reader/PrefixToHs.hi @@ -0,0 +1,33 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface PrefixToHs where +import HsBinds(Binds, MonoBinds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IfaceImportDecl) +import HsMatches(Match) +import HsPat(InPat) +import PrefixSyn(RdrBinding, RdrMatch) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +cvBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> RdrBinding -> Binds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-} +cvClassOpSig :: RdrBinding -> [Sig ProtoName] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +cvInstDeclSig :: RdrBinding -> [Sig ProtoName] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +cvInstDecls :: Bool -> _PackedString -> _PackedString -> [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)] -> [InstDecl ProtoName (InPat ProtoName)] + {-# GHC_PRAGMA _A_ 4 _U_ 2221 _N_ _S_ "LLLS" _N_ _N_ #-} +cvMatches :: _PackedString -> Bool -> [RdrMatch] -> [Match ProtoName (InPat ProtoName)] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +cvMonoBinds :: _PackedString -> [RdrBinding] -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +cvSepdBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> [RdrBinding] -> Binds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-} +cvValSig :: RdrBinding -> [Sig ProtoName] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +sepDeclsForInterface :: RdrBinding -> ([TyDecl ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [RdrBinding], [IfaceImportDecl]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +sepDeclsForTopBinds :: RdrBinding -> ([TyDecl ProtoName], [DataTypeSig ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [SpecialisedInstanceSig ProtoName], [DefaultDecl ProtoName], [RdrBinding]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +sepDeclsIntoSigsAndBinds :: RdrBinding -> ([RdrBinding], [RdrBinding]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs new file mode 100644 index 0000000..e00b771 --- /dev/null +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -0,0 +1,366 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[PrefixToHS]{Support routines for converting ``prefix form'' to Haskell abstract syntax} + +Support routines for reading prefix-form from the Lex/Yacc parser. + +\begin{code} +#include "HsVersions.h" + +module PrefixToHs ( + cvBinds, + cvClassOpSig, + cvInstDeclSig, + cvInstDecls, + cvMatches, + cvMonoBinds, + cvSepdBinds, + cvValSig, + sepDeclsForInterface, + sepDeclsForTopBinds, + sepDeclsIntoSigsAndBinds + ) where + +IMPORT_Trace -- ToDo: rm +import Pretty + +import AbsSyn +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Outputable +import PrefixSyn +import ProtoName -- ProtoName(..), etc. +import SrcLoc ( mkSrcLoc2 ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[cvDecls]{Convert various top-level declarations} +%* * +%************************************************************************ + +\begin{code} +cvInstDecls :: Bool -> FAST_STRING -> FAST_STRING + -> [FAST_STRING -> FAST_STRING -> Bool -> ProtoNameInstDecl] -- incomplete InstDecls + -> [ProtoNameInstDecl] + +cvInstDecls from_here orig_modname informant_modname decls + = [ decl_almost orig_modname informant_modname from_here + | decl_almost <- decls ] +\end{code} + +We make a point not to throw any user-pragma ``sigs'' at +these conversion functions: +\begin{code} +cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter + +cvValSig (RdrTySig vars poly_ty pragmas src_loc) + = [ Sig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ] + where + cvt_pragmas RdrNoPragma = NoGenPragmas + cvt_pragmas (RdrGenPragmas ps) = ps + +cvClassOpSig (RdrTySig vars poly_ty pragmas src_loc) + = [ ClassOpSig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ] + where + cvt_pragmas RdrNoPragma = NoClassOpPragmas + cvt_pragmas (RdrClassOpPragmas ps) = ps + +cvInstDeclSig (RdrInlineValSig sig) = [ sig ] +cvInstDeclSig (RdrDeforestSig sig) = [ sig ] +cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ] +\end{code} + +%************************************************************************ +%* * +\subsection[cvBinds-etc]{Converting to @Binds@, @MonoBinds@, etc.} +%* * +%************************************************************************ + +Function definitions are restructured here. Each is assumed to be recursive +initially, and non recursive definitions are discovered by the dependency +analyser. + +\begin{code} +cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameBinds +cvBinds sf sig_cvtr raw_binding + = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding) + +cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameBinds +cvSepdBinds sf sig_cvtr bindings + = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) -> + if (null sigs) + then SingleBind (RecBind mbs) + else BindWith (RecBind mbs) sigs + } + +cvMonoBinds :: SrcFile -> [RdrBinding] -> ProtoNameMonoBinds +cvMonoBinds sf bindings + = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) -> + if (null sigs) + then mbs + else panic "cvMonoBinds: some sigs present" + } + where + bottom = panic "cvMonoBinds: sig converter!" +\end{code} + +\begin{code} +mkMonoBindsAndSigs :: SrcFile + -> SigConverter + -> [RdrBinding] + -> (ProtoNameMonoBinds, [ProtoNameSig]) + +mkMonoBindsAndSigs sf sig_cvtr fbs + = foldl mangle_bind (EmptyMonoBinds, []) fbs + where + -- If the function being bound has at least one argument, then the + -- guarded right hand sides of each pattern binding are knitted + -- into a series of patterns, each matched with its corresponding + -- guarded right hand side (which may contain several + -- alternatives). This series is then paired with the name of the + -- function. Otherwise there is only one pattern, which is paired + -- with a guarded right hand side. + + mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _ _) + = (b_acc, s_acc ++ sig_cvtr sig) + + mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc) + mangle_bind (b_acc, s_acc) (RdrInlineValSig sig) = (b_acc, sig : s_acc) + mangle_bind (b_acc, s_acc) (RdrDeforestSig sig) = (b_acc, sig : s_acc) + mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc) + + mangle_bind (b_acc, s_acc) + (RdrPatternBinding lousy_srcline [patbinding@(RdrMatch good_srcline _ _ _ _)]) + -- WDP: the parser has trouble getting a good line-number on RdrPatternBindings. + = case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) -> + let + src_loc = mkSrcLoc2 sf good_srcline + in + (b_acc `AndMonoBinds` + PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc) + } + + mangle_bind _ (RdrPatternBinding _ _) + = panic "mangleBinding: more than one pattern on a RdrPatternBinding" + + mangle_bind (b_acc, s_acc) (RdrFunctionBinding srcline patbindings) + -- must be a function binding... + = case (cvFunMonoBind sf patbindings) of { (var, matches) -> + (b_acc `AndMonoBinds` + FunMonoBind var matches (mkSrcLoc2 sf srcline), s_acc) + } +\end{code} + +\begin{code} +cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameBinds) + +cvPatMonoBind sf (RdrMatch srcline srcfun pat guardedexprs binding) + = (pat, cvGRHSs srcfun sf srcline guardedexprs, cvBinds sf cvValSig binding) + +cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch]) + +cvFunMonoBind sf matches@((RdrMatch srcline srcfun pat guardedexprs binding):_) + = ( Unk srcfun, -- cheating ... + cvMatches sf False matches ) + +cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [ProtoNameMatch] +cvMatch :: SrcFile -> Bool -> RdrMatch -> ProtoNameMatch + +cvMatches sf is_case matches = map (cvMatch sf is_case) matches + +cvMatch sf is_case (RdrMatch srcline srcfun pat guardedexprs binding) + = foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn (cvGRHSs srcfun sf srcline guardedexprs) + (cvBinds sf cvValSig binding))) + + -- For a FunMonoBinds, the first flattened "pattern" is + -- just the function name, and we don't want to keep it. + -- For a case expr, it's (presumably) a constructor name -- and + -- we most certainly want to keep it! Hence the monkey busines... + +-- (trace ("cvMatch:"++(ppShow 80 (ppr PprDebug pat))) ( + (if is_case then -- just one pattern: leave it untouched... + [pat'] + else + case pat' of + ConPatIn _ pats -> pats + ) +-- )) + where + pat' = doctor_pat pat + + -- a ConOpPatIn in the corner may be handled by converting it to + -- ConPatIn... + + doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2] + doctor_pat other_pat = other_pat + +cvGRHSs :: FAST_STRING -> SrcFile -> SrcLine -> [(ProtoNameExpr, ProtoNameExpr)] -> [ProtoNameGRHS] + +cvGRHSs sfun sf sl guarded_exprs = map (cvGRHS sfun sf sl) guarded_exprs + +cvGRHS :: FAST_STRING -> SrcFile -> SrcLine -> (ProtoNameExpr, ProtoNameExpr) -> ProtoNameGRHS + +cvGRHS sfun sf sl (Var v@(Unk str), e) + | str == SLIT("__o") -- "__otherwise" ToDo: de-urgh-ify + = OtherwiseGRHS e (mkSrcLoc2 sf sl) + +cvGRHS sfun sf sl (g, e) + = GRHS g e (mkSrcLoc2 sf sl) +\end{code} + +%************************************************************************ +%* * +\subsection[PrefixToHS-utils]{Utilities for conversion} +%* * +%************************************************************************ + +Separate declarations into all the various kinds: +\begin{display} +tys RdrTyData RdrTySynonym +type "sigs" RdrAbstractTypeSig RdrSpecDataSig +classes RdrClassDecl +instances RdrInstDecl +instance "sigs" RdrSpecInstSig +defaults RdrDefaultDecl +binds RdrFunctionBinding RdrPatternBinding RdrTySig + RdrSpecValSig RdrInlineValSig RdrDeforestSig + RdrMagicUnfoldingSig +iimps RdrIfaceImportDecl (interfaces only) +\end{display} + +This function isn't called directly; some other function calls it, +then checks that what it got is appropriate for that situation. +(Those functions follow...) + +\begin{code} +sepDecls (RdrTyData a) + tys tysigs classes insts instsigs defaults binds iimps + = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) + +sepDecls (RdrTySynonym a) + tys tysigs classes insts instsigs defaults binds iimps + = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) + +sepDecls a@(RdrFunctionBinding _ _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +sepDecls a@(RdrPatternBinding _ _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +-- RdrAndBindings catered for below... + +sepDecls (RdrClassDecl a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps) + +sepDecls (RdrInstDecl a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps) + +sepDecls (RdrDefaultDecl a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps) + +sepDecls a@(RdrTySig _ _ _ _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +sepDecls (RdrIfaceImportDecl a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps) + +sepDecls a@(RdrSpecValSig _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +sepDecls a@(RdrInlineValSig _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +sepDecls a@(RdrDeforestSig _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +sepDecls a@(RdrMagicUnfoldingSig _) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps) + +sepDecls (RdrSpecInstSig a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps) + +sepDecls (RdrAbstractTypeSig a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps) + +sepDecls (RdrSpecDataSig a) + tys tysigs classes insts instsigs defaults binds iimps + = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps) + +sepDecls RdrNullBind + tys tysigs classes insts instsigs defaults binds iimps + = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) + +sepDecls (RdrAndBindings bs1 bs2) + tys tysigs classes insts instsigs defaults binds iimps + = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps) of { + (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) -> + sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps + } +\end{code} + +\begin{code} +sepDeclsForTopBinds binding + = case (sepDecls binding [] [] [] [] [] [] [] []) + of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) -> + ASSERT (null iimps) + (tys,tysigs,classes,insts,instsigs,defaults,binds) + } + +sepDeclsForBinds binding + = case (sepDecls binding [] [] [] [] [] [] [] []) + of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps) -> + ASSERT ((null tys) + && (null tysigs) + && (null classes) + && (null insts) + && (null instsigs) + && (null defaults) + && (null iimps)) + binds + } + +sepDeclsIntoSigsAndBinds binding + = case (sepDeclsForBinds binding) of { sigs_and_binds -> + foldr sep_stuff ([],[]) sigs_and_binds + } + where + sep_stuff s@(RdrTySig _ _ _ _) (sigs,defs) = (s:sigs,defs) + sep_stuff s@(RdrInlineValSig _) (sigs,defs) = (s:sigs,defs) + sep_stuff s@(RdrDeforestSig _) (sigs,defs) = (s:sigs,defs) + sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs) + sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs) + sep_stuff d@(RdrPatternBinding _ _) (sigs,defs) = (sigs,d:defs) + + +sepDeclsForInterface binding + = case (sepDecls binding [] [] [] [] [] [] [] []) + of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps) -> + ASSERT ((null defaults) + && (null tysigs) + && (null instsigs)) + ASSERT (not (not_all_sigs sigs)) + (tys,classes,insts,sigs,iimps) + } + where + not_all_sigs sigs = not (all is_a_sig sigs) + + is_a_sig (RdrTySig _ _ _ _) = True + is_a_sig anything_else = False +\end{code} diff --git a/ghc/compiler/reader/ReadPragmas.hi b/ghc/compiler/reader/ReadPragmas.hi new file mode 100644 index 0000000..d504e45 --- /dev/null +++ b/ghc/compiler/reader/ReadPragmas.hi @@ -0,0 +1,46 @@ +{-# GHC_PRAGMA INTERFACE VERSION 3 #-} +interface ReadPragmas where +import BasicLit(BasicLit) +import HsCore(UfId, UnfoldingCoreAtom, UnfoldingCoreExpr) +import HsPragmas(ClassPragmas, DataPragmas, GenPragmas, InstancePragmas, TypePragmas) +import HsTypes(MonoType, PolyType) +import LiftMonad(LiftM) +import Maybes(Labda) +import PrefixSyn(RdrTySigPragmas) +import ProtoName(ProtoName) +import SimplEnv(UnfoldingGuidance) +cvt_IdString :: [Char] -> ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-} +rdBasicLit :: [Char] -> LiftM (BasicLit, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdClassPragma :: [Char] -> LiftM (ClassPragmas ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdCoreAtom :: [Char] -> LiftM (UnfoldingCoreAtom ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdCoreBinder :: [Char] -> LiftM ((ProtoName, PolyType ProtoName), [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdCoreExpr :: [Char] -> LiftM (UnfoldingCoreExpr ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdCoreId :: [Char] -> LiftM (UfId ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdCoreType :: [Char] -> LiftM (PolyType ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-} +rdCoreTypeMaybe :: [Char] -> LiftM (Labda (PolyType ProtoName), [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdDataPragma :: [Char] -> LiftM (DataPragmas ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdGenPragma :: [Char] -> LiftM (GenPragmas ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdGuidance :: [Char] -> LiftM (UnfoldingGuidance, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdInstPragma :: [Char] -> LiftM (Labda [Char], InstancePragmas ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdMonoTypeMaybe :: [Char] -> LiftM (Labda (MonoType ProtoName), [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdTySigPragmas :: [Char] -> LiftM (RdrTySigPragmas, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-} +rdTypePragma :: [Char] -> LiftM (TypePragmas, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rd_constm :: [Char] -> LiftM ((ProtoName, GenPragmas ProtoName), [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/reader/ReadPragmas.lhs b/ghc/compiler/reader/ReadPragmas.lhs new file mode 100644 index 0000000..c9c4831 --- /dev/null +++ b/ghc/compiler/reader/ReadPragmas.lhs @@ -0,0 +1,607 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[ReadPragmas]{Read pragmatic interface info, including Core} + +\begin{code} +-- HBC does not have stack stubbing; you get a space leak w/ +-- default defns from HsVersions.h. + +-- GHC may be overly slow to compile w/ the defaults... + +#define BIND {--} +#define _TO_ `thenLft` ( \ {--} +#define BEND ) +#define RETN returnLft +#define RETN_TYPE LiftM + +#include "HsVersions.h" +\end{code} + +\begin{code} +module ReadPragmas where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty + +import AbsPrel ( nilDataCon, readUnfoldingPrimOp, PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsSyn +import BasicLit ( mkMachInt, BasicLit(..) ) +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Id ( mkTupleCon ) +import IdInfo -- ( UnfoldingGuidance(..) ) +import LiftMonad +import Maybes ( Maybe(..) ) +import PrefixToHs +import PrefixSyn +import ProtoName +import Outputable +import ReadPrefix ( rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType ) +import Util +\end{code} + +\begin{code} +rdDataPragma :: String -> RETN_TYPE (ProtoNameDataPragmas, String) + +rdDataPragma ('P' : 'N' : xs) = RETN (DataPragmas [] [], xs) + +rdDataPragma ('P' : 'd' : xs) + = BIND (rdList (rdConDecl srcfile) xs) _TO_ (cons, xs1) -> + BIND (rdList rd_spec xs1) _TO_ (specs, xs2) -> + RETN (DataPragmas cons specs, xs2) + BEND BEND + where + srcfile = SLIT("") + + rd_spec ('P' : '4' : xs) + = BIND (rdList rdMonoTypeMaybe xs) _TO_ (spec, xs1) -> + RETN (spec, xs1) + BEND +\end{code} + +\begin{code} +rdTypePragma :: String -> RETN_TYPE (TypePragmas, String) + +rdTypePragma ('P' : 'N' : xs) = RETN (NoTypePragmas, xs) +rdTypePragma ('P' : 't' : xs) = RETN (AbstractTySynonym, xs) +\end{code} + +\begin{code} +rdClassPragma :: String -> RETN_TYPE (ProtoNameClassPragmas, String) + +rdClassPragma ('P' : 'N' : xs) = RETN (NoClassPragmas, xs) +rdClassPragma ('P' : 'c' : xs) + = BIND (rdList rdGenPragma xs) _TO_ (gen_pragmas, xs1) -> + ASSERT(not (null gen_pragmas)) + RETN (SuperDictPragmas gen_pragmas, xs1) + BEND +\end{code} + +\begin{code} +rdInstPragma :: String -> RETN_TYPE (Maybe FAST_STRING, ProtoNameInstancePragmas, String) + +rdInstPragma ('P' : 'N' : xs) = RETN (Nothing, NoInstancePragmas, xs) + +rdInstPragma ('P' : 'i' : 's' : xs) + = BIND (rdIdString xs) _TO_ (modname, xs1) -> + BIND (rdGenPragma xs1) _TO_ (gen_pragmas, xs2) -> + RETN (Just modname, SimpleInstancePragma gen_pragmas, xs2) + BEND BEND + +rdInstPragma ('P' : 'i' : 'c' : xs) + = BIND (rdIdString xs) _TO_ (modname, xs1) -> + BIND (rdGenPragma xs1) _TO_ (gen_pragma, xs2) -> + BIND (rdList rd_constm xs2) _TO_ (constm_pragmas, xs3) -> + RETN (Just modname, ConstantInstancePragma gen_pragma constm_pragmas, xs3) + BEND BEND BEND + +rdInstPragma ('P' : 'i' : 'S' : xs) + = BIND (rdIdString xs) _TO_ (modname, xs1) -> + BIND (rdGenPragma xs1) _TO_ (gen_pragma, xs2) -> + BIND (rdList rd_spec xs2) _TO_ (spec_pragmas, xs3) -> + RETN (Just modname, SpecialisedInstancePragma gen_pragma spec_pragmas, xs3) + BEND BEND BEND + where + rd_spec ('P' : '3' : xs) + = BIND (rdList rdMonoTypeMaybe xs) _TO_ (mono_tys_maybe, xs1) -> + BIND (rdIdString xs1) _TO_ (num_dicts, xs2) -> + BIND (rdGenPragma xs2) _TO_ (gen_prag, xs3) -> + BIND (rdList rd_constm xs3) _TO_ (constms, xs4) -> + let + inst_prag + = if null constms then + if null_gen_prag gen_prag + then NoInstancePragmas + else SimpleInstancePragma gen_prag + else -- some constms... + ConstantInstancePragma gen_prag constms + in + RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts)) :: Int), inst_prag), xs4) + BEND BEND BEND BEND + where + null_gen_prag NoGenPragmas = True + null_gen_prag _ = False + +rd_constm ('P' : '1' : xs) + = BIND (rdId xs) _TO_ (name, xs1) -> + BIND (rdGenPragma xs1) _TO_ (prag, xs2) -> + RETN ((name, prag), xs2) + BEND BEND +\end{code} + +\begin{code} +rdGenPragma :: String -> RETN_TYPE (ProtoNameGenPragmas, String) + +rdGenPragma ('P' : 'N' : xs) = RETN (NoGenPragmas, xs) + +rdGenPragma ('P': 'g' : xs) + = BIND (rd_arity xs) _TO_ (arity, xs1) -> + BIND (rd_update xs1) _TO_ (upd, xs2) -> + BIND (rd_strict xs2) _TO_ (strict, xs3) -> + BIND (rd_unfold xs3) _TO_ (unfold, xs4) -> + BIND (rdList rd_spec xs4) _TO_ (specs, xs5) -> +ToDo: do something for DeforestInfo + RETN (GenPragmas arity upd strict unfold specs, xs5) + BEND BEND BEND BEND BEND + where + rd_arity ('P' : 'N' : xs) = RETN (Nothing, xs) + rd_arity ('P' : 'A' : xs) + = BIND (rdIdString xs) _TO_ (a_str, xs1) -> + RETN (Just ((read (_UNPK_ a_str))::Int), xs1) + BEND + + rd_update ('P' : 'N' : xs) = RETN (Nothing, xs) + rd_update ('P' : 'u' : xs) + = BIND (rdIdString xs) _TO_ (upd_spec, xs1) -> + RETN (Just ((read (_UNPK_ upd_spec))::UpdateInfo), xs1) + BEND + + rd_unfold ('P' : 'N' : xs) = RETN (NoImpUnfolding, xs) + + rd_unfold ('P' : 'M' : xs) + = BIND (rdIdString xs) _TO_ (str, xs1) -> + RETN (ImpMagicUnfolding str, xs1) + BEND + + rd_unfold ('P' : 'U' : xs) + = BIND (rdGuidance xs) _TO_ (guidance, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (core, xs2) -> + RETN (ImpUnfolding guidance core, xs2) + BEND BEND + + rd_strict ('P' : 'N' : xs) = RETN (NoImpStrictness, xs) + rd_strict ('P' : 'S' : xs) + = BIND (rdString xs) _TO_ (strict_spec, xs1) -> + BIND (rdGenPragma xs1) _TO_ (wrkr_pragma, xs2) -> + let + ww_strict_info = (read (_UNPK_ strict_spec))::[Demand] + in + RETN (ImpStrictness (trace "ImpStrictness" False) ww_strict_info wrkr_pragma, xs2) + BEND BEND + + rd_spec ('P' : '2' : xs) + = BIND (rdList rdMonoTypeMaybe xs) _TO_ (mono_tys_maybe, xs1) -> + BIND (rdIdString xs1) _TO_ (num_dicts, xs2) -> + BIND (rdGenPragma xs2) _TO_ (gen_prag, xs3) -> + RETN ((mono_tys_maybe, ((read (_UNPK_ num_dicts))::Int), gen_prag), xs3) + BEND BEND BEND +\end{code} + +The only tricky case is pragmas on signatures; we have no way of +knowing whether it is a @GenPragma@ or a @ClassOp@ pragma. So we read +whatever comes, store it in a @RdrTySigPragmas@ structure, and someone +will sort it out later. +\begin{code} +rdTySigPragmas :: String -> RETN_TYPE (RdrTySigPragmas, String) + +rdTySigPragmas ('P' : 'N' : xs) = RETN (RdrNoPragma, xs) + +rdTySigPragmas ('P' : 'o' : xs) + = BIND (rdGenPragma xs) _TO_ (dsel_pragma, xs1) -> + BIND (rdGenPragma xs1) _TO_ (defm_pragma, xs2) -> + RETN (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma), xs2) + BEND BEND + +rdTySigPragmas xs + = BIND (rdGenPragma xs) _TO_ (gen_pragmas, xs1) -> + RETN (RdrGenPragmas gen_pragmas, xs1) + BEND +\end{code} + +\begin{code} +rdGuidance ('P' : 'x' : xs) = RETN (UnfoldAlways, xs) + +-- EssentialUnfolding should never appear in interfaces, so we +-- don't have any way to read them. + +rdGuidance ('P' : 'y' : xs) + = BIND (rdIdString xs) _TO_ (m_ty_args, xs1) -> + BIND (rdIdString xs1) _TO_ (n_val_args, xs2) -> + BIND (rdIdString xs2) _TO_ (con_arg_spec, xs3) -> + BIND (rdIdString xs3) _TO_ (size_str, xs4) -> + let + num_val_args = ((read (_UNPK_ n_val_args)) :: Int) + con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec)) + -- if there were 0 args, we want to throw away + -- any dummy con_arg_spec stuff... + in + RETN (UnfoldIfGoodArgs (read (_UNPK_ m_ty_args)) num_val_args + con_arg_info (read (_UNPK_ size_str)), xs4) + BEND BEND BEND BEND + where + cvt 'C' = True -- want a constructor in this arg position + cvt _ = False + +{- OLD: +rdGuidance ('P' : 'z' : xs) + = BIND (rdIdString xs) _TO_ (m_ty_args, xs1) -> + BIND (rdIdString xs1) _TO_ (size, xs2) -> + RETN (trace "read:UnfoldIsCon" UnfoldNever, xs2) -- ToDo: rm + BEND BEND +-} +\end{code} + +\begin{code} +rdCoreExpr :: String -> RETN_TYPE (ProtoNameUnfoldingCoreExpr, String) + +rdCoreExpr ('F' : 'g' : xs) + = BIND (rdCoreId xs) _TO_ (var, xs1) -> + RETN (UfCoVar var, xs1) + BEND + +rdCoreExpr ('F' : 'h' : xs) + = BIND (rdBasicLit xs) _TO_ (lit, xs1) -> + RETN (UfCoLit lit, xs1) + BEND + +rdCoreExpr ('F' : 'i' : xs) + = BIND (rdCoreId xs) _TO_ (BoringUfId con, xs1) -> + BIND (rdList rdCoreType xs1) _TO_ (tys, xs2) -> + BIND (rdList rdCoreAtom xs2) _TO_ (vs, xs3) -> + RETN (UfCoCon con tys vs, xs3) + BEND BEND BEND + +rdCoreExpr ('F' : 'j' : xs) + = BIND (rd_primop xs) _TO_ (op, xs1) -> + BIND (rdList rdCoreType xs1) _TO_ (tys, xs2) -> + BIND (rdList rdCoreAtom xs2) _TO_ (vs, xs3) -> + RETN (UfCoPrim op tys vs, xs3) + BEND BEND BEND + where + +-- Question: why did ccall once panic if you looked at the maygc flag? +-- Was this just laziness or is it not needed? In that case, modify +-- the stuff that writes them to pragmas so that it never adds the _GC_ +-- tag. ADR + + rd_primop ('F' : 'w' : xs) + = BIND (rdIdString xs) _TO_ (op_str, xs1) -> + RETN (UfOtherOp (readUnfoldingPrimOp op_str), xs1) + BEND + rd_primop ('F' : 'x' : t_or_f : xs) + = BIND (rdIdString xs) _TO_ (fun_str, xs1) -> + BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) -> + BIND (rdCoreType xs2) _TO_ (res_ty, xs3) -> + RETN (UfCCallOp fun_str False (is_T_or_F t_or_f) arg_tys res_ty, xs3) + BEND BEND BEND + rd_primop ('F' : 'y' : t_or_f : xs) + = BIND (rdBasicLit xs) _TO_ (casm_litlit, xs1) -> + BIND (rdList rdCoreType xs1) _TO_ (arg_tys, xs2) -> + BIND (rdCoreType xs2) _TO_ (res_ty, xs3) -> + let + (MachLitLit casm_str _) = casm_litlit + in + RETN (UfCCallOp casm_str True (is_T_or_F t_or_f) arg_tys res_ty, xs3) + BEND BEND BEND + + is_T_or_F 'T' = True + is_T_or_F 'F' = False + +rdCoreExpr ('F' : 'k' : xs) + = BIND (rdList rdCoreBinder xs) _TO_ (bs, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (body, xs2) -> + RETN (UfCoLam bs body, xs2) + BEND BEND + +rdCoreExpr ('F' : 'l' : xs) + = BIND (rdList rdId xs) _TO_ (tvs, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (body, xs2) -> + RETN (foldr UfCoTyLam body tvs, xs2) + BEND BEND + +rdCoreExpr ('F' : 'm' : xs) + = BIND (rdCoreExpr xs) _TO_ (fun, xs1) -> + BIND (rdList rdCoreAtom xs1) _TO_ (args, xs2) -> + RETN (foldl UfCoApp fun args, xs2) + BEND BEND + + +rdCoreExpr ('F' : 'n' : xs) + = BIND (rdCoreExpr xs) _TO_ (expr, xs1) -> + BIND (rdCoreType xs1) _TO_ (ty, xs2) -> + RETN (UfCoTyApp expr ty, xs2) + BEND BEND + +rdCoreExpr ('F' : 'o' : xs) + = BIND (rdCoreExpr xs) _TO_ (scrut, xs1) -> + BIND (rd_alts xs1) _TO_ (alts, xs2) -> + RETN (UfCoCase scrut alts, xs2) + BEND BEND + where + rd_alts ('F' : 'q' : xs) + = BIND (rdList rd_alg_alt xs) _TO_ (alts, xs1) -> + BIND (rd_deflt xs1) _TO_ (deflt, xs2) -> + RETN (UfCoAlgAlts alts deflt, xs2) + BEND BEND + where + rd_alg_alt ('F' : 'r' : xs) + = BIND (rdCoreId xs) _TO_ (BoringUfId con, xs1) -> + BIND (rdList rdCoreBinder xs1) _TO_ (params, xs2) -> + BIND (rdCoreExpr xs2) _TO_ (rhs, xs3) -> + RETN ((con, params, rhs), xs3) + BEND BEND BEND + + rd_alts ('F' : 's' : xs) + = BIND (rdList rd_prim_alt xs) _TO_ (alts, xs1) -> + BIND (rd_deflt xs1) _TO_ (deflt, xs2) -> + RETN (UfCoPrimAlts alts deflt, xs2) + BEND BEND + where + rd_prim_alt ('F' : 't' : xs) + = BIND (rdBasicLit xs) _TO_ (lit, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) -> + RETN ((lit, rhs), xs2) + BEND BEND + + rd_deflt ('F' : 'u' : xs) = RETN (UfCoNoDefault, xs) + rd_deflt ('F' : 'v' : xs) + = BIND (rdCoreBinder xs) _TO_ (b, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) -> + RETN (UfCoBindDefault b rhs, xs2) + BEND BEND + +rdCoreExpr ('F' : 'p' : xs) + = BIND (rd_bind xs) _TO_ (bind, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (body, xs2) -> + RETN (UfCoLet bind body, xs2) + BEND BEND + where + rd_bind ('F' : 'd' : xs) + = BIND (rdCoreBinder xs) _TO_ (b, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) -> + RETN (UfCoNonRec b rhs, xs2) + BEND BEND + + rd_bind ('F' : 'e' : xs) + = BIND (rdList rd_pair xs) _TO_ (pairs, xs1) -> + RETN (UfCoRec pairs, xs1) + BEND + where + rd_pair ('F' : 'f' : xs) + = BIND (rdCoreBinder xs) _TO_ (b, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (rhs, xs2) -> + RETN ((b, rhs), xs2) + BEND BEND + +rdCoreExpr ('F' : 'z' : xs) + = BIND (rd_cc xs) _TO_ (cc, xs1) -> + BIND (rdCoreExpr xs1) _TO_ (body, xs2) -> + RETN (UfCoSCC cc body, xs2) + BEND BEND + where + rd_cc ('F' : '?' : 'a' : xs) + = BIND (rd_dupd xs) _TO_ (is_dupd, xs1) -> + RETN (UfPreludeDictsCC is_dupd, xs1) + BEND + + rd_cc ('F' : '?' : 'b' : xs) + = BIND (rdString xs) _TO_ (m, xs1) -> + BIND (rdString xs1) _TO_ (g, xs2) -> + BIND (rd_dupd xs2) _TO_ (is_dupd, xs3) -> + RETN (UfAllDictsCC m g is_dupd, xs3) + BEND BEND BEND + + rd_cc ('F' : '?' : 'c' : xs) + = BIND (rdString xs) _TO_ (n, xs1) -> + BIND (rdString xs1) _TO_ (m, xs2) -> + BIND (rdString xs2) _TO_ (g, xs3) -> + BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) -> + BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) -> + RETN (UfUserCC n m g is_dupd is_cafd, xs5) + BEND BEND BEND BEND BEND + + rd_cc ('F' : '?' : 'd' : xs) + = BIND (rdCoreId xs) _TO_ (i, xs1) -> + BIND (rdString xs1) _TO_ (m, xs2) -> + BIND (rdString xs2) _TO_ (g, xs3) -> + BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) -> + BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) -> + RETN (UfAutoCC i m g is_dupd is_cafd, xs5) + BEND BEND BEND BEND BEND + + rd_cc ('F' : '?' : 'e' : xs) + = BIND (rdCoreId xs) _TO_ (i, xs1) -> + BIND (rdString xs1) _TO_ (m, xs2) -> + BIND (rdString xs2) _TO_ (g, xs3) -> + BIND (rd_dupd xs3) _TO_ (is_dupd, xs4) -> + BIND (rd_cafd xs4) _TO_ (is_cafd, xs5) -> + RETN (UfDictCC i m g is_dupd is_cafd, xs5) + BEND BEND BEND BEND BEND + + ------ + rd_cafd ('F' : '?' : 'f' : xs) = RETN (False, xs) + rd_cafd ('F' : '?' : 'g' : xs) = RETN (True, xs) +-- rd_cafd xs = panic ("rd_cafd:\n"++xs) + + rd_dupd ('F' : '?' : 'h' : xs) = RETN (False, xs) + rd_dupd ('F' : '?' : 'i' : xs) = RETN (True, xs) +\end{code} + +\begin{code} +rdCoreBinder ('F' : 'a' : xs) + = BIND (rdId xs) _TO_ (b, xs1) -> + BIND (rdCoreType xs1) _TO_ (ty, xs2) -> + RETN ((b, ty), xs2) + BEND BEND + +rdCoreAtom ('F' : 'b' : xs) + = BIND (rdBasicLit xs) _TO_ (lit, xs1) -> + RETN (UfCoLitAtom lit, xs1) + BEND + +rdCoreAtom ('F' : 'c' : xs) + = BIND (rdCoreId xs) _TO_ (v, xs1) -> + RETN (UfCoVarAtom v, xs1) + BEND +\end{code} + +\begin{code} +rdCoreType :: String -> RETN_TYPE (ProtoNamePolyType, String) + +rdCoreType ('2' : 'C' : xs) + = BIND (rdList rdId xs) _TO_ (tvs, xs1) -> + BIND (rdMonoType xs1) _TO_ (ty, xs2) -> + RETN (ForAllTy tvs ty, xs2) + BEND BEND + +rdCoreType other + = BIND (rdMonoType other) _TO_ (ty, xs1) -> + RETN (UnoverloadedTy ty, xs1) + BEND +\end{code} + +\begin{code} +rdCoreTypeMaybe :: String -> RETN_TYPE(Maybe ProtoNamePolyType, String) + +rdCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs) +rdCoreTypeMaybe ('2' : 'E' : xs) + = BIND (rdCoreType xs) _TO_ (ty, xs1) -> + RETN(Just ty, xs1) + BEND + +rdMonoTypeMaybe ('2' : 'D' : xs) = RETN (Nothing, xs) + +rdMonoTypeMaybe ('2' : 'E' : xs) + = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) -> + RETN (Just mono_ty, xs1) + BEND +\end{code} + +\begin{code} +rdCoreId :: String -> RETN_TYPE (UfId ProtoName, String) + +rdCoreId ('F' : '1' : xs) + = BIND (rdIdString xs) _TO_ (v, xs1) -> + RETN (BoringUfId (cvt_IdString v), xs1) + BEND +rdCoreId ('F' : '9' : xs) + = BIND (rdIdString xs) _TO_ (mod, xs1) -> + BIND (rdIdString xs1) _TO_ (nm, xs2) -> + RETN (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm), xs2) + BEND BEND +rdCoreId ('F' : '2' : xs) + = BIND (rdId xs) _TO_ (clas, xs1) -> + BIND (rdId xs1) _TO_ (super_clas, xs2) -> + RETN (SuperDictSelUfId clas super_clas, xs2) + BEND BEND +rdCoreId ('F' : '3' : xs) + = BIND (rdId xs) _TO_ (clas, xs1) -> + BIND (rdId xs1) _TO_ (method, xs2) -> + RETN (ClassOpUfId clas method, xs2) + BEND BEND +rdCoreId ('F' : '4' : xs) + = BIND (rdId xs) _TO_ (clas, xs1) -> + BIND (rdId xs1) _TO_ (method, xs2) -> + RETN (DefaultMethodUfId clas method, xs2) + BEND BEND +rdCoreId ('F' : '5' : xs) + = BIND (rdId xs) _TO_ (clas, xs1) -> + BIND (rdCoreType xs1) _TO_ (ty, xs2) -> + RETN (DictFunUfId clas ty, xs2) + BEND BEND +rdCoreId ('F' : '6' : xs) + = BIND (rdId xs) _TO_ (clas, xs1) -> + BIND (rdId xs1) _TO_ (op, xs2) -> + BIND (rdCoreType xs2) _TO_ (ty, xs3) -> + RETN (ConstMethodUfId clas op ty, xs3) + BEND BEND BEND +rdCoreId ('F' : '7' : xs) + = BIND (rdCoreId xs) _TO_ (unspec, xs1) -> + BIND (rdList rdMonoTypeMaybe xs1) _TO_ (ty_maybes, xs2) -> + RETN (SpecUfId unspec ty_maybes, xs2) + BEND BEND +rdCoreId ('F' : '8' : xs) + = BIND (rdCoreId xs) _TO_ (unwrkr, xs1) -> + RETN (WorkerUfId unwrkr, xs1) + BEND + +cvt_IdString :: FAST_STRING -> ProtoName + +cvt_IdString s + = if (_HEAD_ s /= '_') then + boring + else if (sub_s == SLIT("NIL_")) then +-- trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") ( + Prel (WiredInVal nilDataCon) +-- ) + else if (sub_s == SLIT("TUP_")) then +-- trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") ( + Prel (WiredInVal (mkTupleCon arity)) +-- ) + else +-- trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") ( + boring +-- ) + where + boring = Unk s + sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin) + arity = read (_UNPK_ (_SUBSTR_ s 5 999999)) + -- chars 5 onwards give the arity +\end{code} + +\begin{code} +rdBasicLit :: String -> RETN_TYPE (BasicLit, String) + +rdBasicLit ('R' : xs) + = BIND (rdString xs) _TO_ (n, xs1) -> + BIND (rdString xs1) _TO_ (d, xs2) -> + let + num = ((read (_UNPK_ n)) :: Integer) + den = ((read (_UNPK_ d)) :: Integer) + in + RETN (NoRepRational (num % den), xs2) + BEND BEND + +rdBasicLit ( tag : xs) + = BIND (rdString xs) _TO_ (x, zs) -> + let + s = _UNPK_ x + + as_char = chr ((read s) :: Int) + -- a char comes in as a number string + -- representing its ASCII code + as_integer = readInteger s +#ifdef __GLASGOW_HASKELL__ + as_rational = _readRational s -- non-std +#else + as_rational = ((read s)::Rational) +#endif + as_double = ((read s) :: Double) + in + case tag of { + 'H' -> RETN (mkMachInt as_integer, zs); + 'J' -> RETN (MachDouble as_rational,zs); + 'K' -> RETN (MachFloat as_rational,zs); + 'P' -> RETN (MachChar as_char, zs); + 'V' -> RETN (MachStr x, zs); + 'Y' -> BIND (rdString zs) _TO_ (k, zs2) -> + RETN (MachLitLit x (guessPrimKind k), zs2) + BEND; + 'I' -> RETN (NoRepInteger as_integer, zs); + 's' -> RETN (NoRepStr x, zs) + } BEND +\end{code} diff --git a/ghc/compiler/reader/ReadPragmas2.hi b/ghc/compiler/reader/ReadPragmas2.hi new file mode 100644 index 0000000..4e787b3 --- /dev/null +++ b/ghc/compiler/reader/ReadPragmas2.hi @@ -0,0 +1,21 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ReadPragmas2 where +import HsPragmas(ClassPragmas, DataPragmas, InstancePragmas, TypePragmas) +import HsTypes(PolyType) +import Maybes(Labda) +import PrefixSyn(RdrTySigPragmas) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_hpragma(U_hpragma) +type ProtoUfBinder = (ProtoName, PolyType ProtoName) +wlkClassPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (ClassPragmas ProtoName, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} +wlkDataPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (DataPragmas ProtoName, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} +wlkInstPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> ((Labda _PackedString, InstancePragmas ProtoName), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} +wlkTySigPragmas :: U_hpragma -> _PackedString -> _State _RealWorld -> (RdrTySigPragmas, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +wlkTypePragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (TypePragmas, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/reader/ReadPragmas2.lhs b/ghc/compiler/reader/ReadPragmas2.lhs new file mode 100644 index 0000000..0bfb178 --- /dev/null +++ b/ghc/compiler/reader/ReadPragmas2.lhs @@ -0,0 +1,595 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[ReadPragmas2]{Read pragmatic interface info, including Core} + +\begin{code} +#include "HsVersions.h" + +module ReadPragmas2 ( + ProtoUfBinder(..), + + wlkClassPragma, + wlkDataPragma, + wlkInstPragma, + wlkTySigPragmas, + wlkTypePragma + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty + +import UgenAll + +import AbsPrel ( nilDataCon, readUnfoldingPrimOp, PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import PrimKind ( guessPrimKind, PrimKind ) +import AbsSyn +import BasicLit ( mkMachInt, BasicLit(..) ) +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Id ( mkTupleCon ) +import IdInfo -- ( UnfoldingGuidance(..) ) +import Maybes ( Maybe(..) ) +import PrefixToHs +import PrefixSyn +import ProtoName +import Outputable +import ReadPrefix2 ( wlkList, rdConDecl, wlkMonoType ) +import Util +\end{code} + +\begin{code} +wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas + +wlkDataPragma pragma + = case pragma of + U_no_pragma -> returnUgn (DataPragmas [] []) + U_idata_pragma cs ss -> + wlkList rdConDecl cs `thenUgn` \ cons -> + wlkList rd_spec ss `thenUgn` \ specs -> + returnUgn (DataPragmas cons specs) + where + rd_spec pt + = rdU_hpragma pt `thenUgn` \ stuff -> + case stuff of { U_idata_pragma_4s ss -> + + wlkList rdMonoTypeMaybe ss `thenUgn` \ specs -> + returnUgn specs } +\end{code} + +\begin{code} +wlkTypePragma :: U_hpragma -> UgnM TypePragmas + +wlkTypePragma pragma + = case pragma of + U_no_pragma -> returnUgn NoTypePragmas + U_itype_pragma -> returnUgn AbstractTySynonym +\end{code} + +\begin{code} +wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas + +wlkClassPragma pragma + = case pragma of + U_no_pragma -> returnUgn NoClassPragmas + U_iclas_pragma gens -> + wlkList rdGenPragma gens `thenUgn` \ gen_pragmas -> + ASSERT(not (null gen_pragmas)) + returnUgn (SuperDictPragmas gen_pragmas) +\end{code} + +\begin{code} +wlkInstPragma :: U_hpragma -> UgnM (Maybe FAST_STRING, ProtoNameInstancePragmas) + +wlkInstPragma pragma + = case pragma of + U_no_pragma -> returnUgn (Nothing, NoInstancePragmas) + + U_iinst_simpl_pragma modname dfun_gen -> + wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas -> + returnUgn (Just modname, SimpleInstancePragma gen_pragmas) + + U_iinst_const_pragma modname dfun_gen constm_stuff -> + wlkGenPragma dfun_gen `thenUgn` \ gen_pragma -> + wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas -> + returnUgn (Just modname, ConstantInstancePragma gen_pragma constm_pragmas) + + U_iinst_spec_pragma modname dfun_gen spec_stuff -> + wlkGenPragma dfun_gen `thenUgn` \ gen_pragma -> + wlkList rd_spec spec_stuff `thenUgn` \ spec_pragmas -> + returnUgn (Just modname, SpecialisedInstancePragma gen_pragma spec_pragmas) + where + rd_spec pt + = rdU_hpragma pt `thenUgn` \ stuff -> + case stuff of { U_iinst_pragma_3s maybe_tys num_dicts gen consts -> + + wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe -> + wlkGenPragma gen `thenUgn` \ gen_prag -> + wlkList rd_constm consts `thenUgn` \ constms -> + let + inst_prag + = if null constms then + if null_gen_prag gen_prag + then NoInstancePragmas + else SimpleInstancePragma gen_prag + else -- some constms... + ConstantInstancePragma gen_prag constms + in + returnUgn (mono_tys_maybe, num_dicts, inst_prag) } + where + null_gen_prag NoGenPragmas = True + null_gen_prag _ = False + +rd_constm pt + = rdU_hpragma pt `thenUgn` \ stuff -> + case stuff of { U_iname_pragma_pr name gen -> + + wlkGenPragma gen `thenUgn` \ prag -> + returnUgn (name, prag) } +\end{code} + +\begin{code} +rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas + +rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag + +wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas + +wlkGenPragma pragma + = case pragma of + U_no_pragma -> returnUgn NoGenPragmas + + U_igen_pragma aritee update deforest strct uf speccs -> + wlk_arity aritee `thenUgn` \ arity -> + wlk_update update `thenUgn` \ upd -> + wlk_deforest deforest `thenUgn` \ def -> + wlk_strict strct `thenUgn` \ strict -> + wlk_unfold uf `thenUgn` \ unfold -> + wlkList rd_spec speccs `thenUgn` \ specs -> + returnUgn (GenPragmas arity upd def strict unfold specs) + where + wlk_arity stuff + = case stuff of + U_no_pragma -> returnUgn Nothing + U_iarity_pragma arity -> + returnUgn (Just arity) + + ------------ + wlk_update stuff + = case stuff of + U_no_pragma -> returnUgn Nothing + U_iupdate_pragma upd_spec -> + returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo)) + + ------------ + wlk_deforest stuff + = case stuff of + U_no_pragma -> returnUgn Don'tDeforest + U_ideforest_pragma -> returnUgn DoDeforest + + ------------ + wlk_unfold stuff + = case stuff of + U_no_pragma -> returnUgn NoImpUnfolding + + U_imagic_unfolding_pragma magic -> + returnUgn (ImpMagicUnfolding magic) + + U_iunfolding_pragma guide core -> + wlkGuidance guide `thenUgn` \ guidance -> + wlkCoreExpr core `thenUgn` \ coresyn -> + returnUgn (ImpUnfolding guidance coresyn) + + ------------ + wlk_strict stuff + = case stuff of + U_no_pragma -> returnUgn NoImpStrictness + + U_istrictness_pragma strict_spec wrkr_stuff -> + wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma -> + let + strict_spec_str = _UNPK_ strict_spec + (is_bot, ww_strict_info) + = if (strict_spec_str == "B") + then (True, []) + else (False, (read strict_spec_str)::[Demand]) + in + returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma) + + ------------ + rd_spec pt + = rdU_hpragma pt `thenUgn` \ stuff -> + case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag -> + + wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe -> + wlkGenPragma prag `thenUgn` \ gen_prag -> + returnUgn (mono_tys_maybe, num_dicts, gen_prag) } +\end{code} + +The only tricky case is pragmas on signatures; we have no way of +knowing whether it is a @GenPragma@ or a @ClassOp@ pragma. So we read +whatever comes, store it in a @RdrTySigPragmas@ structure, and someone +will sort it out later. +\begin{code} +wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas + +wlkTySigPragmas pragma + = case pragma of + U_no_pragma -> returnUgn RdrNoPragma + + U_iclasop_pragma dsel defm -> + wlkGenPragma dsel `thenUgn` \ dsel_pragma -> + wlkGenPragma defm `thenUgn` \ defm_pragma -> + returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma)) + + other -> + wlkGenPragma other `thenUgn` \ gen_pragmas -> + returnUgn (RdrGenPragmas gen_pragmas) +\end{code} + +\begin{code} +wlkGuidance guide + = case guide of + U_iunfold_always -> returnUgn UnfoldAlways + + U_iunfold_if_args num_ty_args num_val_args con_arg_spec size -> + let + con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec)) + -- if there were 0 args, we want to throw away + -- any dummy con_arg_spec stuff... + in + returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args + con_arg_info size) + where + cvt 'C' = True -- want a constructor in this arg position + cvt _ = False +\end{code} + +\begin{code} +wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr + +wlkCoreExpr core_expr + = case core_expr of + U_covar v -> + wlkCoreId v `thenUgn` \ var -> + returnUgn (UfCoVar var) + + U_coliteral l -> + wlkBasicLit l `thenUgn` \ lit -> + returnUgn (UfCoLit lit) + + U_cocon c ts as -> + wlkCoreId c `thenUgn` \ (BoringUfId con) -> + wlkList rdCoreType ts `thenUgn` \ tys -> + wlkList rdCoreAtom as `thenUgn` \ vs -> + returnUgn (UfCoCon con tys vs) + + U_coprim o ts as -> + wlk_primop o `thenUgn` \ op -> + wlkList rdCoreType ts `thenUgn` \ tys -> + wlkList rdCoreAtom as `thenUgn` \ vs -> + let + fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs } + in + returnUgn (UfCoPrim op tys fixed_vs) + where + + -- Question: why did ccall once panic if you looked at the + -- maygc flag? Was this just laziness or is it not needed? + -- In that case, modify the stuff that writes them to pragmas + -- so that it never adds the _GC_ tag. ADR + + wlk_primop op + = case op of + U_co_primop op_str -> + returnUgn (UfOtherOp (readUnfoldingPrimOp op_str)) + + U_co_ccall fun_str may_gc a_tys r_ty -> + wlkList rdCoreType a_tys `thenUgn` \ arg_tys -> + wlkCoreType r_ty `thenUgn` \ res_ty -> + returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty) + + U_co_casm litlit may_gc a_tys r_ty -> + wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) -> + wlkList rdCoreType a_tys `thenUgn` \ arg_tys -> + wlkCoreType r_ty `thenUgn` \ res_ty -> + returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty) + where + is_T_or_F 0 = False + is_T_or_F _ = True + + -- Now *this* is a hack: we can't distinguish Int# literals + -- from Word# literals as they come in; this is only likely + -- to bite on the args of certain PrimOps (shifts, etc); so + -- we look for those and fix things up!!! (WDP 95/05) + + fixup AndOp [a1, a2] = [fixarg a1, fixarg a2] + fixup OrOp [a1, a2] = [fixarg a1, fixarg a2] + fixup NotOp [a1] = [fixarg a1] + fixup SllOp [a1, a2] = [fixarg a1, a2] + fixup SraOp [a1, a2] = [fixarg a1, a2] + fixup SrlOp [a1, a2] = [fixarg a1, a2] + fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2] + fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2] + fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2] + fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2] + fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2] + fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2] + fixup _ as = as + + fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-}) + fixarg arg = arg + + U_colam vars expr -> + wlkList rdCoreBinder vars `thenUgn` \ bs -> + wlkCoreExpr expr `thenUgn` \ body -> + returnUgn (UfCoLam bs body) + + U_cotylam vars expr -> + wlkList rdU_unkId vars `thenUgn` \ tvs -> + wlkCoreExpr expr `thenUgn` \ body -> + returnUgn (foldr UfCoTyLam body tvs) + + U_coapp f as -> + wlkCoreExpr f `thenUgn` \ fun -> + wlkList rdCoreAtom as `thenUgn` \ args -> + returnUgn (foldl UfCoApp fun args) + + U_cotyapp e t -> + wlkCoreExpr e `thenUgn` \ expr -> + wlkCoreType t `thenUgn` \ ty -> + returnUgn (UfCoTyApp expr ty) + + U_cocase s as -> + wlkCoreExpr s `thenUgn` \ scrut -> + wlk_alts as `thenUgn` \ alts -> + returnUgn (UfCoCase scrut alts) + where + wlk_alts (U_coalg_alts as d) + = wlkList rd_alg_alt as `thenUgn` \ alts -> + wlk_deflt d `thenUgn` \ deflt -> + returnUgn (UfCoAlgAlts alts deflt) + where + rd_alg_alt pt + = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) -> + + wlkCoreId c `thenUgn` \ (BoringUfId con) -> + wlkList rdCoreBinder bs `thenUgn` \ params -> + wlkCoreExpr exp `thenUgn` \ rhs -> + returnUgn (con, params, rhs) + + wlk_alts (U_coprim_alts as d) + = wlkList rd_prim_alt as `thenUgn` \ alts -> + wlk_deflt d `thenUgn` \ deflt -> + returnUgn (UfCoPrimAlts alts deflt) + where + rd_prim_alt pt + = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) -> + + wlkBasicLit l `thenUgn` \ lit -> + wlkCoreExpr exp `thenUgn` \ rhs -> + returnUgn (lit, rhs) + + wlk_deflt U_conodeflt = returnUgn UfCoNoDefault + wlk_deflt (U_cobinddeflt v exp) + = wlkCoreBinder v `thenUgn` \ b -> + wlkCoreExpr exp `thenUgn` \ rhs -> + returnUgn (UfCoBindDefault b rhs) + + U_colet b expr -> + wlk_bind b `thenUgn` \ bind -> + wlkCoreExpr expr `thenUgn` \ body -> + returnUgn (UfCoLet bind body) + where + wlk_bind (U_cononrec v expr) + = wlkCoreBinder v `thenUgn` \ b -> + wlkCoreExpr expr `thenUgn` \ rhs -> + returnUgn (UfCoNonRec b rhs) + + wlk_bind (U_corec prs) + = wlkList rd_pair prs `thenUgn` \ pairs -> + returnUgn (UfCoRec pairs) + where + rd_pair pt + = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) -> + + wlkCoreBinder v `thenUgn` \ b -> + wlkCoreExpr expr `thenUgn` \ rhs -> + returnUgn (b, rhs) + + U_coscc c expr -> + wlk_cc c `thenUgn` \ cc -> + wlkCoreExpr expr `thenUgn` \ body -> + returnUgn (UfCoSCC cc body) + where + wlk_cc (U_co_preludedictscc dupd) + = wlk_dupd dupd `thenUgn` \ is_dupd -> + returnUgn (UfPreludeDictsCC is_dupd) + + wlk_cc (U_co_alldictscc m g dupd) + = wlk_dupd dupd `thenUgn` \ is_dupd -> + returnUgn (UfAllDictsCC m g is_dupd) + + wlk_cc (U_co_usercc n m g dupd cafd) + = wlk_dupd dupd `thenUgn` \ is_dupd -> + wlk_cafd cafd `thenUgn` \ is_cafd -> + returnUgn (UfUserCC n m g is_dupd is_cafd) + + wlk_cc (U_co_autocc id m g dupd cafd) + = wlkCoreId id `thenUgn` \ i -> + wlk_dupd dupd `thenUgn` \ is_dupd -> + wlk_cafd cafd `thenUgn` \ is_cafd -> + returnUgn (UfAutoCC i m g is_dupd is_cafd) + + wlk_cc (U_co_dictcc id m g dupd cafd) + = wlkCoreId id `thenUgn` \ i -> + wlk_dupd dupd `thenUgn` \ is_dupd -> + wlk_cafd cafd `thenUgn` \ is_cafd -> + returnUgn (UfDictCC i m g is_dupd is_cafd) + + ------ + wlk_cafd U_co_scc_noncaf = returnUgn False + wlk_cafd U_co_scc_caf = returnUgn True + + wlk_dupd U_co_scc_nondupd = returnUgn False + wlk_dupd U_co_scc_dupd = returnUgn True +\end{code} + +\begin{code} +type ProtoUfBinder = (ProtoName, PolyType ProtoName) + +rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder + +rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x + +wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder + +wlkCoreBinder (U_cobinder b t) + = wlkCoreType t `thenUgn` \ ty -> + returnUgn (b, ty) + +rdCoreAtom pt + = rdU_coresyn pt `thenUgn` \ atom -> + case atom of + U_colit l -> + wlkBasicLit l `thenUgn` \ lit -> + returnUgn (UfCoLitAtom lit) + + U_colocal var -> + wlkCoreId var `thenUgn` \ v -> + returnUgn (UfCoVarAtom v) +\end{code} + +\begin{code} +rdCoreType :: ParseTree -> UgnM ProtoNamePolyType + +rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype + +wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType + +wlkCoreType (U_uniforall ts t) + = wlkList rdU_unkId ts `thenUgn` \ tvs -> + wlkMonoType t `thenUgn` \ ty -> + returnUgn (ForAllTy tvs ty) + +wlkCoreType other + = wlkMonoType other `thenUgn` \ ty -> + returnUgn (UnoverloadedTy ty) +\end{code} + +\begin{code} +{- OLD??? +wlkCoreTypeMaybe :: ParseTree -> RETN_TYPE(Maybe ProtoNamePolyType, FAST_STRING) + +wlkCoreTypeMaybe ('2' : 'D' : xs) = RETN(Nothing, xs) +wlkCoreTypeMaybe ('2' : 'E' : xs) + = wlkCoreType xs) `thenUgn` \ (ty, xs1) -> + RETN(Just ty, xs1) + BEND +-} + +rdMonoTypeMaybe pt + = rdU_ttype pt `thenUgn` \ ty -> + case ty of + U_ty_maybe_nothing -> returnUgn Nothing + + U_ty_maybe_just t -> + wlkMonoType t `thenUgn` \ mono_ty -> + returnUgn (Just mono_ty) +\end{code} + +\begin{code} +wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName) + +wlkCoreId (U_co_id v) + = returnUgn (BoringUfId (cvt_IdString v)) + +wlkCoreId (U_co_orig_id mod nm) + = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm)) + +wlkCoreId (U_co_sdselid clas super_clas) + = returnUgn (SuperDictSelUfId clas super_clas) + +wlkCoreId (U_co_classopid clas method) + = returnUgn (ClassOpUfId clas method) + +wlkCoreId (U_co_defmid clas method) + = returnUgn (DefaultMethodUfId clas method) + +wlkCoreId (U_co_dfunid clas t) + = wlkCoreType t `thenUgn` \ ty -> + returnUgn (DictFunUfId clas ty) + +wlkCoreId (U_co_constmid clas op t) + = wlkCoreType t `thenUgn` \ ty -> + returnUgn (ConstMethodUfId clas op ty) + +wlkCoreId (U_co_specid id tys) + = wlkCoreId id `thenUgn` \ unspec -> + wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes -> + returnUgn (SpecUfId unspec ty_maybes) + +wlkCoreId (U_co_wrkrid un) + = wlkCoreId un `thenUgn` \ unwrkr -> + returnUgn (WorkerUfId unwrkr) + +------------ +cvt_IdString :: FAST_STRING -> ProtoName + +cvt_IdString s + = if (_HEAD_ s /= '_') then +-- trace (show s++(show (_HEAD_ s /= '_'))++(_HEAD_ s):'_':"/*0*/\n") ( + boring +-- ) + else if (sub_s == SLIT("NIL_")) then +-- trace (show s++"/*1*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") ( + Prel (WiredInVal nilDataCon) +-- ) + else if (sub_s == SLIT("TUP_")) then +-- trace (show s++"/*2*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") ( + Prel (WiredInVal (mkTupleCon arity)) +-- ) + else +-- trace (show s++"/*3*/"++show sub_s++"/"++show (_SUBSTR_ s 5 99999)++"\n") ( + boring +-- ) + where + boring = Unk s + sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin) + arity = read (_UNPK_ (_SUBSTR_ s 5 999999)) + -- chars 5 onwards give the arity +\end{code} + +\begin{code} +wlkBasicLit :: U_literal -> UgnM BasicLit + +wlkBasicLit (U_norepr n d) + = let + num = ((read (_UNPK_ n)) :: Integer) + den = ((read (_UNPK_ d)) :: Integer) + in + returnUgn (NoRepRational (num % den)) + +wlkBasicLit other + = returnUgn ( + case other of + U_intprim s -> mkMachInt (as_integer s) + U_doubleprim s -> MachDouble (as_rational s) + U_floatprim s -> MachFloat (as_rational s) + U_charprim s -> MachChar (as_char s) + U_stringprim s -> MachStr (as_string s) + + U_clitlit s k -> MachLitLit (as_string s) (guessPrimKind (_UNPK_ k)) + + U_norepi s -> NoRepInteger (as_integer s) + U_noreps s -> NoRepStr (as_string s) + ) + where + as_char s = _HEAD_ s + as_integer s = readInteger (_UNPK_ s) + as_rational s = _readRational (_UNPK_ s) -- non-std + as_string s = s +\end{code} diff --git a/ghc/compiler/reader/ReadPrefix.hi b/ghc/compiler/reader/ReadPrefix.hi new file mode 100644 index 0000000..7c18e69 --- /dev/null +++ b/ghc/compiler/reader/ReadPrefix.hi @@ -0,0 +1,23 @@ +{-# GHC_PRAGMA INTERFACE VERSION 3 #-} +interface ReadPrefix where +import AbsSyn(Module) +import HsDecls(ConDecl) +import HsPat(InPat) +import HsTypes(MonoType) +import LiftMonad(LiftM) +import ProtoName(ProtoName) +rdConDecl :: [Char] -> [Char] -> LiftM (ConDecl ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _S_ "LS" _N_ _N_ #-} +rdId :: [Char] -> LiftM (ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdIdString :: [Char] -> LiftM ([Char], [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-} +rdList :: ([Char] -> LiftM (a, [Char])) -> [Char] -> LiftM ([a], [Char]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _S_ "LS" _N_ _N_ #-} +rdModule :: [Char] -> ([Char], [Char] -> Bool, Module ProtoName (InPat ProtoName)) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _S_ "S" _N_ _N_ #-} +rdMonoType :: [Char] -> LiftM (MonoType ProtoName, [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-} +rdString :: [Char] -> LiftM ([Char], [Char]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs new file mode 100644 index 0000000..5458884 --- /dev/null +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -0,0 +1,996 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[ReadPrefix]{Read prefix-form input} + +This module contains a function, @rdModule@, which reads a Haskell +module in `prefix form' emitted by the Lex/Yacc parser. + +The prefix form string is converted into an algebraic data type +defined in @PrefixSyn@. + +Identifier names are converted into the @ProtoName@ data type. + +@sf@ is used consistently to mean ``source file'' (name). + +\begin{code} +-- HBC does not have stack stubbing; you get a space leak w/ +-- default defns from HsVersions.h. + +-- GHC may be overly slow to compile w/ the defaults... + +#define BIND {--} +#define _TO_ `thenLft` ( \ {--} +#define BEND ) +#define RETN returnLft +#define RETN_TYPE LiftM + +#include "HsVersions.h" +\end{code} + +\begin{code} +module ReadPrefix ( + rdModule, + + rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty + +import AbsSyn +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import IdInfo ( UnfoldingGuidance(..) ) +import LiftMonad +import Maybes ( Maybe(..) ) +import PrefixToHs +import PrefixSyn +import ProtoName +import Outputable +import ReadPragmas +import SrcLoc ( mkSrcLoc ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[ReadPrefix-help]{Help Functions} +%* * +%************************************************************************ + +\begin{code} +rdList :: (String -> RETN_TYPE (a, String)) -> String -> RETN_TYPE ([a], String) + +rdList rd_it ('N':xs) = RETN ([], xs) +rdList rd_it ('L':xs) + = BIND (rd_it xs) _TO_ (hd_it, xs1) -> + BIND (rdList rd_it xs1) _TO_ (tl_it, xs2) -> + RETN (hd_it : tl_it, xs2) + BEND BEND +rdList rd_it junk = panic ("ReadPrefix.rdList:"++junk) + +rdString, rdIdString :: String -> RETN_TYPE (FAST_STRING, String) +rdId :: String -> RETN_TYPE (ProtoName, String) + +rdString ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) -> + RETN (_PK_ (de_escape str), rest) + BEND + where + -- partain: tabs and backslashes are escaped + de_escape [] = [] + de_escape ('\\':'\\':xs) = '\\' : (de_escape xs) + de_escape ('\\':'t':xs) = '\t' : (de_escape xs) + de_escape (x:xs) = x : (de_escape xs) + +rdString xs = panic ("ReadPrefix.rdString:"++xs) + +rdIdString ('#':xs) = BIND (split_at_tab xs) _TO_ (stuff,rest) -> -- no de-escaping... + RETN (_PK_ stuff, rest) + BEND +rdIdString other = panic ("rdIdString:"++other) + + -- no need to de-escape it... +rdId ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) -> + RETN (Unk (_PK_ str), rest) + BEND + +split_at_tab :: String -> RETN_TYPE (String, String) -- a la Lennart +split_at_tab xs + = split_me [] xs + where + split_me acc ('\t' : ys) = BIND (my_rev acc []) _TO_ reversed -> + RETN (reversed, ys) + BEND + split_me acc (y : ys) = split_me (y:acc) ys + + my_rev "" acc = RETN acc -- instead of reverse, so can see on heap-profiles + my_rev (x:xs) acc = my_rev xs (x:acc) +\end{code} + +%************************************************************************ +%* * +\subsection[rdModule]{@rdModule@: reads in a Haskell module} +%* * +%************************************************************************ + +\begin{code} +rdModule :: String + -> (FAST_STRING, -- this module's name + (FAST_STRING -> Bool, -- a function to chk if is in the export list + FAST_STRING -> Bool), -- a function to chk if is among the M.. + -- ("dotdot") modules in the export list. + ProtoNameModule) -- the main goods + +rdModule (next_char:xs) + = case next_char of { 'M' -> + + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdIdString xs1) _TO_ (name, xs2) -> + BIND (rdString xs2) _TO_ (srcfile, xs3) -> + BIND (rdBinding srcfile xs3) _TO_ (binding, xs4) -> + BIND (rdList rdFixity xs4) _TO_ (fixities, xs5) -> + BIND (rdList (rdImportedInterface srcfile) xs5) _TO_ (imports, xs6) -> + BIND (rdList rdEntity xs6) _TO_ (export_list, _) -> + + case sepDeclsForTopBinds binding of { + (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) -> + + (name, + mk_export_list_chker export_list, + Module name + export_list + imports + fixities + tydecls + tysigs + classdecls + (cvInstDecls True name name instdecls) -- True indicates not imported + instsigs + defaultdecls + (cvSepdBinds srcfile cvValSig binds) + [{-no sigs-}] + (mkSrcLoc srcfile srcline) + ) + } BEND BEND BEND BEND BEND BEND BEND + } + where + mk_export_list_chker exp_list + = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) -> + ( \ n -> n `elemFM` just_the_strings, + \ n -> n `elemFM` dotdot_modules ) + } +\end{code} + +%************************************************************************ +%* * +\subsection[rdExprOrPat]{@rdExpr@ and @rdPat@} +%* * +%************************************************************************ + +\begin{code} +rdExpr :: SrcFile -> String -> RETN_TYPE (ProtoNameExpr, String) +rdPat :: SrcFile -> String -> RETN_TYPE (ProtoNamePat, String) + +rdExpr sf (next_char:xs) + = case next_char of + '(' -> -- left section + BIND (rdExpr sf xs) _TO_ (expr,xs1) -> + BIND (rdId xs1) _TO_ (id, xs2) -> + RETN (SectionL expr (Var id), xs2) + BEND BEND + + ')' -> -- right section + BIND (rdId xs) _TO_ (id, xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr,xs2) -> + RETN (SectionR (Var id) expr, xs2) + BEND BEND + + 'j' -> -- ccall/casm + BIND (rdString xs) _TO_ (fun, xs1) -> + BIND (rdString xs1) _TO_ (flavor, xs2) -> + BIND (rdList (rdExpr sf) xs2) _TO_ (args, xs3) -> + RETN (CCall fun args + (flavor == SLIT("p") || flavor == SLIT("P")) -- may invoke GC + (flavor == SLIT("N") || flavor == SLIT("P")) -- really a "casm" + (panic "CCall:result_ty"), + xs3) + BEND BEND BEND + + 'k' -> -- scc (set-cost-centre) expression + BIND (rdString xs) _TO_ (label, xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr, xs2) -> + RETN (SCC label expr, xs2) + BEND BEND + + 'l' -> -- lambda expression + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdList (rdPat sf) xs1) _TO_ (pats, xs2) -> + BIND (rdExpr sf xs2) _TO_ (body, xs3) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (Lam (foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn + [OtherwiseGRHS body src_loc] + EmptyBinds)) + pats + ), + xs3) + BEND BEND BEND + + 'c' -> -- case expression + BIND (rdExpr sf xs) _TO_ (expr, xs1) -> + BIND (rdList (rdMatch sf) xs1) _TO_ (mats, xs2) -> + let + matches = cvMatches sf True mats + in + RETN (Case expr matches, xs2) + BEND BEND + + 'b' -> -- if expression + BIND (rdExpr sf xs) _TO_ (e1, xs1) -> + BIND (rdExpr sf xs1) _TO_ (e2, xs2) -> + BIND (rdExpr sf xs2) _TO_ (e3, xs3) -> + RETN (If e1 e2 e3, xs3) + BEND BEND BEND + + 'E' -> -- let expression + BIND (rdBinding sf xs) _TO_ (binding,xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr, xs2) -> + let + binds = cvBinds sf cvValSig binding + in + RETN (Let binds expr, xs2) + BEND BEND + + 'Z' -> -- list comprehension + BIND (rdExpr sf xs) _TO_ (expr, xs1) -> + BIND (rdList rd_qual xs1) _TO_ (quals, xs2) -> + RETN (ListComp expr quals, xs2) + BEND BEND + where + rd_qual ('G':xs) + = BIND (rdPat sf xs) _TO_ (pat, xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr,xs2) -> + RETN (GeneratorQual pat expr, xs2) + BEND BEND + + rd_qual ('g':xs) + = BIND (rdExpr sf xs) _TO_ (expr,xs1) -> + RETN (FilterQual expr, xs1) + BEND + + '.' -> -- arithmetic sequence + BIND (rdExpr sf xs) _TO_ (e1, xs1) -> + BIND (rdList (rdExpr sf) xs1) _TO_ (es2, xs2) -> + BIND (rdList (rdExpr sf) xs2) _TO_ (es3, xs3) -> + RETN (cv_arith_seq e1 es2 es3, xs3) + BEND BEND BEND + where + cv_arith_seq e1 [] [] = ArithSeqIn (From e1) + cv_arith_seq e1 [] [e3] = ArithSeqIn (FromTo e1 e3) + cv_arith_seq e1 [e2] [] = ArithSeqIn (FromThen e1 e2) + cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3) + + 'R' -> -- expression with type signature + BIND (rdExpr sf xs) _TO_ (expr,xs1) -> + BIND (rdPolyType xs1) _TO_ (ty, xs2) -> + RETN (ExprWithTySig expr ty, xs2) + BEND BEND + + '-' -> -- negated expression + BIND (rdExpr sf xs) _TO_ (expr,xs1) -> + RETN (App (Var (Unk SLIT("negate"))) expr, xs1) + BEND +#ifdef DPH + '5' -> -- parallel ZF expression + BIND (rdExpr sf xs) _TO_ (expr, xs1) -> + BIND (rdList (rd_par_qual sf) xs1) _TO_ (qual_list, xs2) -> + let + quals = foldr1 AndParQuals qual_list + in + RETN (RdrParallelZF expr quals, xs2) + BEND BEND + where + rdParQual sf inp + = case inp of + -- ToDo:DPH: I have kawunkled your RdrExplicitProcessor hack + '0':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor pats pat, xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr, xs2) -> + RETN (DrawnGenIn pats pat expr, xs2) + BEND BEND + + 'w':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor exprs pat, xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr, xs2) -> + RETN (IndexGen exprs pat expr, xs2) + BEND BEND + + 'I':xs -> BIND (rdExpr sf xs) _TO_ (expr,xs1) -> + RETN (ParFilter expr, xs1) + BEND + + '6' -> -- explicitPod expression + BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) -> + RETN (RdrExplicitPod exprs,xs1) + BEND +#endif {- Data Parallel Haskell -} + + -------------------------------------------------------------- + -- now the prefix items that can either be an expression or + -- pattern, except we know they are *expressions* here + -- (this code could be commoned up with the pattern version; + -- but it probably isn't worth it) + -------------------------------------------------------------- + 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) -> + RETN (Lit lit, xs1) + BEND + + 'i' -> -- simple identifier + BIND (rdId xs) _TO_ (str,xs1) -> + RETN (Var str, xs1) + BEND + + 'a' -> -- application + BIND (rdExpr sf xs) _TO_ (expr1, xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr2, xs2) -> + RETN (App expr1 expr2, xs2) + BEND BEND + + '@' -> -- operator application + BIND (rdExpr sf xs) _TO_ (expr1, xs1) -> + BIND (rdId xs1) _TO_ (op, xs2) -> + BIND (rdExpr sf xs2) _TO_ (expr2, xs3) -> + RETN (OpApp expr1 (Var op) expr2, xs3) + BEND BEND BEND + + ':' -> -- explicit list + BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) -> + RETN (ExplicitList exprs, xs1) + BEND + + ',' -> -- explicit tuple + BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) -> + RETN (ExplicitTuple exprs, xs1) + BEND + +#ifdef DPH + 'O' -> -- explicitProcessor expression + BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) -> + BIND (rdExpr sf xs1) _TO_ (expr, xs2) -> + RETN (ExplicitProcessor exprs expr, xs2) + BEND BEND +#endif {- Data Parallel Haskell -} + + huh -> panic ("ReadPrefix.rdExpr:"++(next_char:xs)) +\end{code} + +Patterns: just bear in mind that lists of patterns are represented as +a series of ``applications''. +\begin{code} +rdPat sf (next_char:xs) + = case next_char of + 's' -> -- "as" pattern + BIND (rdId xs) _TO_ (id, xs1) -> + BIND (rdPat sf xs1) _TO_ (pat,xs2) -> + RETN (AsPatIn id pat, xs2) + BEND BEND + + '~' -> -- irrefutable ("twiddle") pattern + BIND (rdPat sf xs) _TO_ (pat,xs1) -> + RETN (LazyPatIn pat, xs1) + BEND + + '+' -> -- n+k pattern + BIND (rdPat sf xs) _TO_ (pat, xs1) -> + BIND (rdLiteral xs1) _TO_ (lit, xs2) -> + let + n = case pat of + VarPatIn n -> n + WildPatIn -> error "ERROR: rdPat: GHC can't handle _+k patterns yet" + in + RETN (NPlusKPatIn n lit, xs2) + BEND BEND + + '_' -> -- wildcard pattern + RETN (WildPatIn, xs) + + -------------------------------------------------------------- + -- now the prefix items that can either be an expression or + -- pattern, except we know they are *patterns* here. + -------------------------------------------------------------- + '-' -> BIND (rdPat sf xs) _TO_ (lit_pat, xs1) -> + case lit_pat of + LitPatIn lit -> RETN (LitPatIn (negLiteral lit), xs1) + _ -> panic "rdPat: bad negated pattern!" + BEND + + 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) -> + RETN (LitPatIn lit, xs1) + BEND + + 'i' -> -- simple identifier + BIND (rdIdString xs) _TO_ (str, xs1) -> + RETN (if isConop str then + ConPatIn (Unk str) [] + else + VarPatIn (Unk str), + xs1) + BEND + + 'a' -> -- "application": there's a list of patterns lurking here! + BIND (rd_curried_pats xs) _TO_ (lpat:lpats, xs1) -> + BIND (rdPat sf xs1) _TO_ (rpat, xs2) -> + let + (n, llpats) + = case lpat of + VarPatIn x -> (x, []) + ConPatIn x [] -> (x, []) + ConOpPatIn x op y -> (op, [x, y]) + other -> -- sorry about the weedy msg; the parser missed this one + error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)])) + + arg_pats = llpats ++ lpats ++ [rpat] + bad_app = (lpat:lpats) ++ [rpat] + in + RETN (ConPatIn n arg_pats, xs2) + BEND BEND + where + rd_curried_pats ('a' : ys) + = BIND (rd_curried_pats ys) _TO_ (lpats, ys1) -> + BIND (rdPat sf ys1) _TO_ (rpat, ys2) -> + RETN (lpats ++ [rpat], ys2) + BEND BEND + rd_curried_pats ys + = BIND (rdPat sf ys) _TO_ (pat, ys1) -> + RETN ([pat], ys1) + BEND + + '@' -> -- operator application + BIND (rdPat sf xs) _TO_ (pat1, xs1) -> + BIND (rdId xs1) _TO_ (op, xs2) -> + BIND (rdPat sf xs2) _TO_ (pat2, xs3) -> + RETN (ConOpPatIn pat1 op pat2, xs3) + BEND BEND BEND + + ':' -> -- explicit list + BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) -> + RETN (ListPatIn pats, xs1) + BEND + + ',' -> -- explicit tuple + BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) -> + RETN (TuplePatIn pats, xs1) + BEND + +#ifdef DPH + 'O' -> -- explicitProcessor pattern + BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) -> + BIND (rdPat sf xs1) _TO_ (pat, xs2) -> + RETN (ProcessorPatIn pats pat, xs2) + BEND BEND +#endif {- Data Parallel Haskell -} + + huh -> panic ("ReadPrefix.rdPat:"++(next_char:xs)) +\end{code} + +OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that +to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no +expressions). Therefore in the pattern matching below we are taking +this into consideration to create the @DrawGen@ whose fields are the +\tr{K} patterns, pat and the exp right of the generator. + +\begin{code} +rdLiteral :: String -> RETN_TYPE (Literal, String) + +rdLiteral (tag : xs) + = BIND (rdString xs) _TO_ (x, zs) -> + let + s = _UNPK_ x + + as_char = chr ((read s) :: Int) + -- a char comes in as a number string + -- representing its ASCII code + as_integer = readInteger s +#if __GLASGOW_HASKELL__ <= 22 + as_rational = toRational ((read s)::Double) +#else +#ifdef __GLASGOW_HASKELL__ + as_rational = _readRational s -- non-std +#else + as_rational = ((read s)::Rational) +#endif +#endif + as_double = ((read s) :: Double) + in + case tag of { + '4' -> RETN (IntLit as_integer, zs); + 'F' -> RETN (FracLit as_rational, zs); + 'H' -> RETN (IntPrimLit as_integer, zs); +#if __GLASGOW_HASKELL__ <= 22 + 'J' -> RETN (DoublePrimLit as_double,zs); + 'K' -> RETN (FloatPrimLit as_double, zs); +#else + 'J' -> RETN (DoublePrimLit as_rational,zs); + 'K' -> RETN (FloatPrimLit as_rational, zs); +#endif + 'C' -> RETN (CharLit as_char, zs); + 'P' -> RETN (CharPrimLit as_char, zs); + 'S' -> RETN (StringLit x, zs); + 'V' -> RETN (StringPrimLit x, zs); + 'Y' -> RETN (LitLitLitIn x, zs) + } BEND +\end{code} + +%************************************************************************ +%* * +\subsection[rdBinding]{rdBinding} +%* * +%************************************************************************ + +\begin{code} +rdBinding :: SrcFile -> String -> RETN_TYPE (RdrBinding, String) + +rdBinding sf (next_char:xs) + = case next_char of + 'B' -> -- null binding + RETN (RdrNullBind, xs) + + 'A' -> -- "and" binding (just glue, really) + BIND (rdBinding sf xs) _TO_ (binding1, xs1) -> + BIND (rdBinding sf xs1) _TO_ (binding2, xs2) -> + RETN (RdrAndBindings binding1 binding2, xs2) + BEND BEND + + 't' -> -- "data" declaration + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdContext xs1) _TO_ (ctxt, xs2) -> + BIND (rdList rdId xs2) _TO_ (derivings, xs3) -> + BIND (rdTyConAndTyVars xs3) _TO_ ((tycon, tyvars), xs4) -> + BIND (rdList (rdConDecl sf) xs4) _TO_ (cons, xs5) -> + BIND (rdDataPragma xs5) _TO_ (pragma, xs6) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc), + xs6) + BEND BEND BEND BEND BEND BEND + + 'n' -> -- "type" declaration + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdTyConAndTyVars xs1) _TO_ ((tycon, tyvars), xs2) -> + BIND (rdMonoType xs2) _TO_ (expansion, xs3) -> + BIND (rdTypePragma xs3) _TO_ (pragma, xs4) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc), + xs4) + BEND BEND BEND BEND + + 'f' -> -- function binding + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) -> + RETN (RdrFunctionBinding (read (_UNPK_ srcline)) matches, xs2) + BEND BEND + + 'p' -> -- pattern binding + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) -> + RETN (RdrPatternBinding (read (_UNPK_ srcline)) matches, xs2) + BEND BEND + + '$' -> -- "class" declaration + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdContext xs1) _TO_ (ctxt, xs2) -> + BIND (rdClassAssertTy xs2) _TO_ ((clas, tyvar), xs3) -> + BIND (rdBinding sf xs3) _TO_ (binding, xs4) -> + BIND (rdClassPragma xs4) _TO_ (pragma, xs5) -> + let + (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding + + final_sigs = concat (map cvClassOpSig class_sigs) + final_methods = cvMonoBinds sf class_methods + + src_loc = mkSrcLoc sf srcline + in + RETN (RdrClassDecl + (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc), + xs5) + BEND BEND BEND BEND BEND + + '%' -> -- "instance" declaration + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdContext xs1) _TO_ (ctxt, xs2) -> + BIND (rdId xs2) _TO_ (clas, xs3) -> + BIND (rdMonoType xs3) _TO_ (inst_ty, xs4) -> + BIND (rdBinding sf xs4) _TO_ (binding, xs5) -> + BIND (rdInstPragma xs5) _TO_ (modname_maybe, pragma, xs6) -> + let + (ss, bs) = sepDeclsIntoSigsAndBinds binding + binds = cvMonoBinds sf bs + uprags = concat (map cvInstDeclSig ss) + src_loc = mkSrcLoc sf srcline + in + case modname_maybe of { + Nothing -> + RETN (RdrInstDecl (\ orig_mod infor_mod here -> + InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc), + xs6); + Just orig_mod -> + RETN (RdrInstDecl (\ _ infor_mod here -> + InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc), + xs6) + } + BEND BEND BEND BEND BEND BEND + + 'D' -> -- "default" declaration + BIND (rdString xs) _TO_ (srcline,xs1) -> + BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) -> + + RETN (RdrDefaultDecl (DefaultDecl tys (mkSrcLoc sf srcline)), + xs2) + BEND BEND + + '7' -> -- "import" declaration in an interface + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdIdString xs1) _TO_ (mod, xs2) -> + BIND (rdList rdEntity xs2) _TO_ (entities, xs3) -> + BIND (rdList rdRenaming xs3) _TO_ (renamings, xs4) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc), + xs4) + BEND BEND BEND BEND + + 'S' -> -- signature(-like) things, including user pragmas + rd_sig_thing sf xs +\end{code} + +\begin{code} +rd_sig_thing sf (next_char:xs) + = case next_char of + 't' -> -- type signature + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdList rdId xs1) _TO_ (vars, xs2) -> + BIND (rdPolyType xs2) _TO_ (poly_ty, xs3) -> + BIND (rdTySigPragmas xs3) _TO_ (pragma, xs4) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrTySig vars poly_ty pragma src_loc, xs4) + BEND BEND BEND BEND + + 's' -> -- value specialisation user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (var, xs2) -> + BIND (rdList rdPolyType xs2) _TO_ (tys, xs3) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrSpecValSig [SpecSig var ty Nothing{-ToDo: using...s-} src_loc | ty <- tys], xs3) + BEND BEND BEND + + 'S' -> -- instance specialisation user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (clas, xs2) -> + BIND (rdMonoType xs2) _TO_ (ty, xs3) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrSpecInstSig (InstSpecSig clas ty src_loc), xs3) + BEND BEND BEND + + 'i' -> -- value inlining user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (var, xs2) -> + BIND (rdList rdIdString xs2) _TO_ (howto, xs3) -> + let + src_loc = mkSrcLoc sf srcline + + guidance + = (case howto of { + [] -> id; + [x] -> trace "ignoring unfold howto" }) UnfoldAlways + in + RETN (RdrInlineValSig (InlineSig var guidance src_loc), xs3) + BEND BEND BEND + + 'd' -> -- value deforest user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (var, xs2) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrDeforestSig (DeforestSig var src_loc), xs2) + BEND BEND + + 'u' -> -- value magic-unfolding user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (var, xs2) -> + BIND (rdIdString xs2) _TO_ (str, xs3) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc), xs3) + BEND BEND BEND + + 'a' -> -- abstract-type-synonym user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (tycon, xs2) -> + let + src_loc = mkSrcLoc sf srcline + in + RETN (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc), xs2) + BEND BEND + + 'd' -> -- data specialisation user-pragma + BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (tycon, xs2) -> + BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) -> + let + src_loc = mkSrcLoc sf srcline + spec_ty = MonoTyCon tycon tys + in + RETN (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc), xs3) + BEND BEND BEND +\end{code} + +%************************************************************************ +%* * +\subsection[rdTypes]{Reading in types in various forms (and data constructors)} +%* * +%************************************************************************ + +\begin{code} +rdPolyType :: String -> RETN_TYPE (ProtoNamePolyType, String) +rdMonoType :: String -> RETN_TYPE (ProtoNameMonoType, String) + +rdPolyType ('3' : xs) + = BIND (rdContext xs) _TO_ (ctxt, xs1) -> + BIND (rdMonoType xs1) _TO_ (ty, xs2) -> + RETN (OverloadedTy ctxt ty, xs2) + BEND BEND + +rdPolyType ('2' : 'C' : xs) + = BIND (rdList rdId xs) _TO_ (tvs, xs1) -> + BIND (rdMonoType xs1) _TO_ (ty, xs2) -> + RETN (ForAllTy tvs ty, xs2) + BEND BEND + +rdPolyType other + = BIND (rdMonoType other) _TO_ (ty, xs1) -> + RETN (UnoverloadedTy ty, xs1) + BEND + +rdMonoType ('T' : xs) + = BIND (rdId xs) _TO_ (tycon, xs1) -> + BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) -> + RETN (MonoTyCon tycon tys, xs2) + BEND BEND + +rdMonoType (':' : xs) + = BIND (rdMonoType xs) _TO_ (ty, xs1) -> + RETN (ListMonoTy ty, xs1) + BEND + +rdMonoType (',' : xs) + = BIND (rdList rdPolyType xs) _TO_ (tys, xs1) -> + RETN (TupleMonoTy tys, xs1) + BEND + +rdMonoType ('>' : xs) + = BIND (rdMonoType xs) _TO_ (ty1, xs1) -> + BIND (rdMonoType xs1) _TO_ (ty2, xs2) -> + RETN (FunMonoTy ty1 ty2, xs2) + BEND BEND + +rdMonoType ('y' : xs) + = BIND (rdId xs) _TO_ (tyvar, xs1) -> + RETN (MonoTyVar tyvar, xs1) + BEND + +rdMonoType ('2' : 'A' : xs) + = BIND (rdId xs) _TO_ (clas, xs1) -> + BIND (rdMonoType xs1) _TO_ (ty, xs2) -> + RETN (MonoDict clas ty, xs2) + BEND BEND + +rdMonoType ('2' : 'B' : xs) + = BIND (rdId xs) _TO_ (tv_tmpl, xs1) -> + RETN (MonoTyVarTemplate tv_tmpl, xs1) + BEND + +#ifdef DPH +rdMonoType ('v' : xs) + = BIND (rdMonoType xs) _TO_ (ty, xs1) -> + RETN (RdrExplicitPodTy ty, xs1) + BEND + +rdMonoType ('u' : xs) + = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) -> + BIND (rdMonoType xs1) _TO_ (ty, xs2) -> + RETN (RdrExplicitProcessorTy tys ty, xs2) + BEND BEND +#endif {- Data Parallel Haskell -} + +rdMonoType oops = panic ("rdMonoType:"++oops) +\end{code} + +\begin{code} +rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String) +rdContext :: String -> RETN_TYPE (ProtoNameContext, String) +rdClassAssertTy :: String -> RETN_TYPE ((ProtoName, ProtoName), String) + +rdTyConAndTyVars xs + = BIND (rdMonoType xs) _TO_ (MonoTyCon tycon ty_args, xs1) -> + let + args = [ a | (MonoTyVar a) <- ty_args ] + in + RETN ((tycon, args), xs1) + BEND + +rdContext xs + = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) -> + RETN (map mk_class_assertion tys, xs1) + BEND + +rdClassAssertTy xs + = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) -> + RETN (mk_class_assertion mono_ty, xs1) + BEND + +mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName) + +mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname) +mk_class_assertion other + = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n") + -- regrettably, the parser does let some junk past + -- e.g., f :: Num {-nothing-} => a -> ... +\end{code} + +\begin{code} +rdConDecl :: SrcFile -> String -> RETN_TYPE (ProtoNameConDecl, String) + +rdConDecl sf ('1':xs) + = BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdId xs1) _TO_ (id, xs2) -> + BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) -> + RETN (ConDecl id tys (mkSrcLoc sf srcline), xs3) + BEND BEND BEND +\end{code} + +%************************************************************************ +%* * +\subsection[rdMatch]{Read a ``match''} +%* * +%************************************************************************ + +\begin{code} +rdMatch :: SrcFile -> String -> RETN_TYPE (RdrMatch, String) + +rdMatch sf ('W':xs) + = BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdIdString xs1) _TO_ (srcfun, xs2) -> + BIND (rdPat sf xs2) _TO_ (pat, xs3) -> + BIND (rdList rd_guarded xs3) _TO_ (grhss, xs4) -> + BIND (rdBinding sf xs4) _TO_ (binding, xs5) -> + + RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5) + BEND BEND BEND BEND BEND + where + rd_guarded xs + = BIND (rdExpr sf xs) _TO_ (g, xs1) -> + BIND (rdExpr sf xs1) _TO_ (e, xs2) -> + RETN ((g, e), xs2) + BEND BEND +\end{code} + +%************************************************************************ +%* * +\subsection[rdFixity]{Read in a fixity declaration} +%* * +%************************************************************************ + +\begin{code} +rdFixity :: String -> RETN_TYPE (ProtoNameFixityDecl, String) +rdFixity xs + = BIND (rdId xs) _TO_ (op, xs1) -> + BIND (rdString xs1) _TO_ (associativity, xs2) -> + BIND (rdString xs2) _TO_ (prec_str, xs3) -> + let + precedence = read (_UNPK_ prec_str) + in + case (_UNPK_ associativity) of { + "infix" -> RETN (InfixN op precedence, xs3); + "infixl" -> RETN (InfixL op precedence, xs3); + "infixr" -> RETN (InfixR op precedence, xs3) + } BEND BEND BEND +\end{code} + +%************************************************************************ +%* * +\subsection[rdImportedInterface]{Read an imported interface} +%* * +%************************************************************************ + +\begin{code} +rdImportedInterface :: FAST_STRING -> String + -> RETN_TYPE (ProtoNameImportedInterface, String) + +rdImportedInterface importing_srcfile (x:xs) + = BIND (rdString xs) _TO_ (srcline, xs1) -> + BIND (rdString xs1) _TO_ (srcfile, xs2) -> + BIND (rdIdString xs2) _TO_ (modname, xs3) -> + BIND (rdList rdEntity xs3) _TO_ (imports, xs4) -> + BIND (rdList rdRenaming xs4) _TO_ (renamings,xs5) -> + BIND (rdBinding srcfile xs5) _TO_ (iface_bs, xs6) -> + + case (sepDeclsForInterface iface_bs) of { + (tydecls,classdecls,instdecls,sigs,iimpdecls) -> + let + expose_or_hide = case x of { 'e' -> ImportSome; 'h' -> ImportButHide } + + cv_iface + = MkInterface modname + iimpdecls + [{-fixity decls-}] -- can't get fixity decls in here yet (ToDo) + tydecls + classdecls + (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-} + modname instdecls) + -- False indicates imported + (concat (map cvValSig sigs)) + (mkSrcLoc importing_srcfile srcline) + in + RETN ( + (if null imports then + ImportAll cv_iface renamings + else + expose_or_hide cv_iface imports renamings + , xs6)) + } BEND BEND BEND BEND BEND BEND +\end{code} + +\begin{code} +rdRenaming :: String -> RETN_TYPE (Renaming, String) + +rdRenaming xs + = BIND (rdIdString xs) _TO_ (id1, xs1) -> + BIND (rdIdString xs1) _TO_ (id2, xs2) -> + RETN (MkRenaming id1 id2, xs2) + BEND BEND +\end{code} + +\begin{code} +rdEntity :: String -> RETN_TYPE (IE, String) + +rdEntity inp + = case inp of + 'x':xs -> BIND (rdIdString xs) _TO_ (var, xs1) -> + RETN (IEVar var, xs1) + BEND + + 'X':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) -> + RETN (IEThingAbs thing, xs1) + BEND + + 'z':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) -> + RETN (IEThingAll thing, xs1) + BEND + + '8':xs -> BIND (rdIdString xs) _TO_ (tycon, xs1) -> + BIND (rdList rdString xs1) _TO_ (cons, xs2) -> + RETN (IEConWithCons tycon cons, xs2) + BEND BEND + + '9':xs -> BIND (rdIdString xs) _TO_ (c, xs1) -> + BIND (rdList rdString xs1) _TO_ (ops, xs2) -> + RETN (IEClsWithOps c ops, xs2) + BEND BEND + + 'm':xs -> BIND (rdIdString xs) _TO_ (m, xs1) -> + RETN (IEModuleContents m, xs1) + BEND +\end{code} diff --git a/ghc/compiler/reader/ReadPrefix2.hi b/ghc/compiler/reader/ReadPrefix2.hi new file mode 100644 index 0000000..5857d24 --- /dev/null +++ b/ghc/compiler/reader/ReadPrefix2.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ReadPrefix2 where +import AbsSyn(Module) +import HsDecls(ConDecl) +import HsPat(InPat) +import HsTypes(MonoType) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_list(U_list) +import U_ttype(U_ttype) +rdConDecl :: _Addr -> _PackedString -> _State _RealWorld -> (ConDecl ProtoName, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdModule :: _State _RealWorld -> ((_PackedString, (_PackedString -> Bool, _PackedString -> Bool), Module ProtoName (InPat ProtoName)), _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +wlkList :: (_Addr -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> U_list -> _PackedString -> _State _RealWorld -> ([a], _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +wlkMonoType :: U_ttype -> _PackedString -> _State _RealWorld -> (MonoType ProtoName, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/reader/ReadPrefix2.lhs b/ghc/compiler/reader/ReadPrefix2.lhs new file mode 100644 index 0000000..85990cb --- /dev/null +++ b/ghc/compiler/reader/ReadPrefix2.lhs @@ -0,0 +1,856 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[ReadPrefix2]{Read parse tree built by Yacc parser} + +Comments? + +\begin{code} +#include "HsVersions.h" + +module ReadPrefix2 ( + rdModule, + + -- used over in ReadPragmas2... + wlkList, rdConDecl, wlkMonoType + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty + +import UgenAll + +import AbsSyn +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import FiniteMap +import IdInfo ( UnfoldingGuidance(..) ) +import MainMonad +import Maybes ( Maybe(..) ) +import PrefixToHs +import PrefixSyn +import ProtoName +import Outputable +import ReadPragmas2 +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[ReadPrefix-help]{Help Functions} +%* * +%************************************************************************ + +\begin{code} +wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a] + +wlkList wlk_it U_lnil = returnUgn [] + +wlkList wlk_it (U_lcons hd tl) + = wlk_it hd `thenUgn` \ hd_it -> + wlkList wlk_it tl `thenUgn` \ tl_it -> + returnUgn (hd_it : tl_it) +\end{code} + +%************************************************************************ +%* * +\subsection[rdModule]{@rdModule@: reads in a Haskell module} +%* * +%************************************************************************ + +\begin{code} +rdModule :: MainIO + (FAST_STRING, -- this module's name + (FAST_STRING -> Bool, -- a function to chk if is in the export list + FAST_STRING -> Bool), -- a function to chk if is among the M.. + -- ("dotdot") modules in the export list. + ProtoNameModule) -- the main goods + +rdModule + = _ccall_ hspmain `thenMn` \ pt -> -- call the Yacc parser! + let + srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM) + in + initUgn srcfile ( + + rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hmodlist srcline) -> + rdFixities `thenUgn` \ fixities -> + wlkBinding hmodlist `thenUgn` \ binding -> + wlkList rdImportedInterface himplist `thenUgn` \ imports -> + wlkList rdEntity hexplist `thenUgn` \ export_list-> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + + case sepDeclsForTopBinds binding of { + (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) -> + -- ToDo: bad for laziness?? + + returnUgn ( + name, + mk_export_list_chker export_list, + Module name + export_list + imports + fixities + tydecls + tysigs + classdecls + (cvInstDecls True name name instdecls) -- True indicates not imported + instsigs + defaultdecls + (cvSepdBinds srcfile cvValSig binds) + [{-no sigs-}] + src_loc + ) } ) + where + mk_export_list_chker exp_list + = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) -> + ( \ n -> n `elemFM` entity_info, + \ n -> n `elemFM` dotdot_modules ) + } +\end{code} + +Convert fixities table: +\begin{code} +rdFixities :: UgnM [ProtoNameFixityDecl] + +rdFixities + = ioToUgnM (_ccall_ nfixes) `thenUgn` \ num_fixities@(I# _) -> + let + rd i acc + | i >= num_fixities + = returnUgn acc + + | otherwise + = ioToUgnM (_ccall_ fixtype i) `thenUgn` \ fix_ty@(A# _) -> + if fix_ty == ``NULL'' then + rd (i+1) acc + else + ioToUgnM (_ccall_ fixop i) `thenUgn` \ fix_op@(A# _) -> + ioToUgnM (_ccall_ precedence i) `thenUgn` \ precedence@(I# _) -> + let + op = Unk (_packCString fix_op) + + associativity + = _UNPK_ (_packCString fix_ty) + + new_fix + = case associativity of + "infix" -> InfixN op precedence + "infixl" -> InfixL op precedence + "infixr" -> InfixR op precedence + in + rd (i+1) (new_fix : acc) + in + rd 0 [] +\end{code} + +%************************************************************************ +%* * +\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@} +%* * +%************************************************************************ + +\begin{code} +rdExpr :: ParseTree -> UgnM ProtoNameExpr +rdPat :: ParseTree -> UgnM ProtoNamePat + +rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree +rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree + +wlkExpr :: U_tree -> UgnM ProtoNameExpr +wlkPat :: U_tree -> UgnM ProtoNamePat + +wlkExpr expr + = case expr of + U_par expr -> -- parenthesised expr + wlkExpr expr + + U_lsection lsexp op -> -- left section + wlkExpr lsexp `thenUgn` \ expr -> + returnUgn (SectionL expr (Var op)) + + U_rsection op rsexp -> -- right section + wlkExpr rsexp `thenUgn` \ expr -> + returnUgn (SectionR (Var op) expr) + + U_ccall fun flavor ccargs -> -- ccall/casm + wlkList rdExpr ccargs `thenUgn` \ args -> + let + tag = _HEAD_ flavor + in + returnUgn (CCall fun args + (tag == 'p' || tag == 'P') -- may invoke GC + (tag == 'N' || tag == 'P') -- really a "casm" + (panic "CCall:result_ty")) + + U_scc label sccexp -> -- scc (set-cost-centre) expression + wlkExpr sccexp `thenUgn` \ expr -> + returnUgn (SCC label expr) + + U_lambda lampats lamexpr srcline -> -- lambda expression + wlkList rdPat lampats `thenUgn` \ pats -> + wlkExpr lamexpr `thenUgn` \ body -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn ( + Lam (foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn + [OtherwiseGRHS body src_loc] + EmptyBinds)) + pats) + ) + + U_casee caseexpr casebody -> -- case expression + wlkExpr caseexpr `thenUgn` \ expr -> + wlkList rdMatch casebody `thenUgn` \ mats -> + getSrcFileUgn `thenUgn` \ sf -> + let + matches = cvMatches sf True mats + in + returnUgn (Case expr matches) + + U_ife ifpred ifthen ifelse -> -- if expression + wlkExpr ifpred `thenUgn` \ e1 -> + wlkExpr ifthen `thenUgn` \ e2 -> + wlkExpr ifelse `thenUgn` \ e3 -> + returnUgn (If e1 e2 e3) + + U_let letvdeflist letvexpr -> -- let expression + wlkBinding letvdeflist `thenUgn` \ binding -> + wlkExpr letvexpr `thenUgn` \ expr -> + getSrcFileUgn `thenUgn` \ sf -> + let + binds = cvBinds sf cvValSig binding + in + returnUgn (Let binds expr) + + U_comprh cexp cquals -> -- list comprehension + wlkExpr cexp `thenUgn` \ expr -> + wlkList rd_qual cquals `thenUgn` \ quals -> + returnUgn (ListComp expr quals) + where + rd_qual pt + = rdU_tree pt `thenUgn` \ qual -> + wlk_qual qual + + wlk_qual qual + = case qual of + U_par expr -> wlk_qual expr -- overkill? (ToDo?) + + U_qual qpat qexp -> + wlkPat qpat `thenUgn` \ pat -> + wlkExpr qexp `thenUgn` \ expr -> + returnUgn (GeneratorQual pat expr) + + U_guard gexp -> + wlkExpr gexp `thenUgn` \ expr -> + returnUgn (FilterQual expr) + + U_eenum efrom estep eto -> -- arithmetic sequence + wlkExpr efrom `thenUgn` \ e1 -> + wlkList rdExpr estep `thenUgn` \ es2 -> + wlkList rdExpr eto `thenUgn` \ es3 -> + returnUgn (cv_arith_seq e1 es2 es3) + where -- ToDo: use Maybe type + cv_arith_seq e1 [] [] = ArithSeqIn (From e1) + cv_arith_seq e1 [] [e3] = ArithSeqIn (FromTo e1 e3) + cv_arith_seq e1 [e2] [] = ArithSeqIn (FromThen e1 e2) + cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3) + + U_restr restre restrt -> -- expression with type signature + wlkExpr restre `thenUgn` \ expr -> + wlkPolyType restrt `thenUgn` \ ty -> + returnUgn (ExprWithTySig expr ty) + + U_negate nexp -> -- negated expression + wlkExpr nexp `thenUgn` \ expr -> + returnUgn (App (Var (Unk SLIT("negate"))) expr) + + -- ToDo: DPH stuff + + -------------------------------------------------------------- + -- now the prefix items that can either be an expression or + -- pattern, except we know they are *expressions* here + -- (this code could be commoned up with the pattern version; + -- but it probably isn't worth it) + -------------------------------------------------------------- + U_lit lit -> + wlkLiteral lit `thenUgn` \ lit -> + returnUgn (Lit lit) + + U_ident n -> -- simple identifier + returnUgn (Var n) + + U_ap fun arg -> -- application + wlkExpr fun `thenUgn` \ expr1 -> + wlkExpr arg `thenUgn` \ expr2 -> + returnUgn (App expr1 expr2) + + U_tinfixop (op, arg1, arg2) -> + wlkExpr arg1 `thenUgn` \ expr1 -> + wlkExpr arg2 `thenUgn` \ expr2 -> + returnUgn (OpApp expr1 (Var op) expr2) + + U_llist llist -> -- explicit list + wlkList rdExpr llist `thenUgn` \ exprs -> + returnUgn (ExplicitList exprs) + + U_tuple tuplelist -> -- explicit tuple + wlkList rdExpr tuplelist `thenUgn` \ exprs -> + returnUgn (ExplicitTuple exprs) + +#ifdef DEBUG + U_hmodule _ _ _ _ _ -> error "U_hmodule" + U_as _ _ -> error "U_as" + U_lazyp _ -> error "U_lazyp" + U_plusp _ _ -> error "U_plusp" + U_wildp -> error "U_wildp" + U_qual _ _ -> error "U_qual" + U_guard _ -> error "U_guard" + U_def _ -> error "U_def" +#endif + +-- ToDo: DPH stuff +\end{code} + +Patterns: just bear in mind that lists of patterns are represented as +a series of ``applications''. +\begin{code} +wlkPat pat + = case pat of + U_par pat -> -- parenthesised pattern + wlkPat pat + + U_as var as_pat -> -- "as" pattern + wlkPat as_pat `thenUgn` \ pat -> + returnUgn (AsPatIn var pat) + + U_lazyp lazyp -> -- irrefutable ("twiddle") pattern + wlkPat lazyp `thenUgn` \ pat -> + returnUgn (LazyPatIn pat) + + U_plusp plusn plusk -> -- n+k pattern + wlkPat plusn `thenUgn` \ pat -> + wlkLiteral plusk `thenUgn` \ lit -> + let + n = case pat of + VarPatIn n -> n + WildPatIn -> error "ERROR: wlkPat: GHC can't handle _+k patterns\n" + in + returnUgn (NPlusKPatIn n lit) + + U_wildp -> returnUgn WildPatIn -- wildcard pattern + + -------------------------------------------------------------- + -- now the prefix items that can either be an expression or + -- pattern, except we know they are *patterns* here. + -------------------------------------------------------------- + U_negate nexp -> -- negated pattern: negatee must be a literal + wlkPat nexp `thenUgn` \ lit_pat -> + case lit_pat of + LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit)) + _ -> panic "wlkPat: bad negated pattern!" + + U_lit lit -> + wlkLiteral lit `thenUgn` \ lit -> + returnUgn (LitPatIn lit) + + U_ident n -> -- simple identifier + returnUgn ( + if isConopPN n + then ConPatIn n [] + else VarPatIn n + ) + + U_ap l r -> -- "application": there's a list of patterns lurking here! + wlk_curried_pats l `thenUgn` \ (lpat:lpats) -> + wlkPat r `thenUgn` \ rpat -> + let + (n, llpats) + = case lpat of + VarPatIn x -> (x, []) + ConPatIn x [] -> (x, []) + ConOpPatIn x op y -> (op, [x, y]) + _ -> -- sorry about the weedy msg; the parser missed this one + error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)])) + + arg_pats = llpats ++ lpats ++ [rpat] + bad_app = (lpat:lpats) ++ [rpat] + in + returnUgn (ConPatIn n arg_pats) + where + wlk_curried_pats pat + = case pat of + U_ap l r -> + wlk_curried_pats l `thenUgn` \ lpats -> + wlkPat r `thenUgn` \ rpat -> + returnUgn (lpats ++ [rpat]) + other -> + wlkPat other `thenUgn` \ pat -> + returnUgn [pat] + + U_tinfixop (op, arg1, arg2) -> + wlkPat arg1 `thenUgn` \ pat1 -> + wlkPat arg2 `thenUgn` \ pat2 -> + returnUgn (ConOpPatIn pat1 op pat2) + + U_llist llist -> -- explicit list + wlkList rdPat llist `thenUgn` \ pats -> + returnUgn (ListPatIn pats) + + U_tuple tuplelist -> -- explicit tuple + wlkList rdPat tuplelist `thenUgn` \ pats -> + returnUgn (TuplePatIn pats) + + -- ToDo: DPH +\end{code} + +OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that +to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no +expressions). Therefore in the pattern matching below we are taking +this into consideration to create the @DrawGen@ whose fields are the +\tr{K} patterns, pat and the exp right of the generator. + +\begin{code} +wlkLiteral :: U_literal -> UgnM Literal + +wlkLiteral ulit + = returnUgn ( + case ulit of + U_integer s -> IntLit (as_integer s) + U_floatr s -> FracLit (as_rational s) + U_intprim s -> IntPrimLit (as_integer s) + U_doubleprim s -> DoublePrimLit (as_rational s) + U_floatprim s -> FloatPrimLit (as_rational s) + U_charr s -> CharLit (as_char s) + U_charprim s -> CharPrimLit (as_char s) + U_string s -> StringLit (as_string s) + U_stringprim s -> StringPrimLit (as_string s) + U_clitlit s _ -> LitLitLitIn (as_string s) + ) + where + as_char s = _HEAD_ s + as_integer s = readInteger (_UNPK_ s) + as_rational s = _readRational (_UNPK_ s) -- non-std + as_string s = s +\end{code} + +%************************************************************************ +%* * +\subsection{wlkBinding} +%* * +%************************************************************************ + +\begin{code} +wlkBinding :: U_binding -> UgnM RdrBinding + +wlkBinding binding + = case binding of + U_nullbind -> -- null binding + returnUgn RdrNullBind + + U_abind a b -> -- "and" binding (just glue, really) + wlkBinding a `thenUgn` \ binding1 -> + wlkBinding b `thenUgn` \ binding2 -> + returnUgn (RdrAndBindings binding1 binding2) + + U_tbind tbindc tbindid tbindl tbindd srcline tpragma -> -- "data" declaration + wlkContext tbindc `thenUgn` \ ctxt -> + wlkList rdU_unkId tbindd `thenUgn` \ derivings -> + wlkTyConAndTyVars tbindid `thenUgn` \ (tycon, tyvars) -> + wlkList rdConDecl tbindl `thenUgn` \ cons -> + wlkDataPragma tpragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc)) + + U_nbind nbindid nbindas srcline npragma -> -- "type" declaration + wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> + wlkMonoType nbindas `thenUgn` \ expansion -> + wlkTypePragma npragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc)) + + U_fbind fbindl srcline -> -- function binding + wlkList rdMatch fbindl `thenUgn` \ matches -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrFunctionBinding srcline matches) + + U_pbind pbindl srcline -> -- pattern binding + wlkList rdMatch pbindl `thenUgn` \ matches -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrPatternBinding srcline matches) + + U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration + wlkContext cbindc `thenUgn` \ ctxt -> + wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar) -> + wlkBinding cbindw `thenUgn` \ binding -> + wlkClassPragma cpragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + getSrcFileUgn `thenUgn` \ sf -> + let + (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding + + final_sigs = concat (map cvClassOpSig class_sigs) + final_methods = cvMonoBinds sf class_methods + in + returnUgn (RdrClassDecl + (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc)) + + U_ibind ibindc clas ibindi ibindw srcline ipragma -> -- "instance" declaration + wlkContext ibindc `thenUgn` \ ctxt -> + wlkMonoType ibindi `thenUgn` \ inst_ty -> + wlkBinding ibindw `thenUgn` \ binding -> + wlkInstPragma ipragma `thenUgn` \ (modname_maybe, pragma) -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + getSrcFileUgn `thenUgn` \ sf -> + let + (ss, bs) = sepDeclsIntoSigsAndBinds binding + binds = cvMonoBinds sf bs + uprags = concat (map cvInstDeclSig ss) + in + returnUgn ( + case modname_maybe of { + Nothing -> + RdrInstDecl (\ orig_mod infor_mod here -> + InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc); + Just orig_mod -> + RdrInstDecl (\ _ infor_mod here -> + InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc) + }) + + U_dbind dbindts srcline -> -- "default" declaration + wlkList rdMonoType dbindts `thenUgn` \ tys -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc)) + + U_mbind mod mbindimp mbindren srcline -> + -- "import" declaration in an interface + wlkList rdEntity mbindimp `thenUgn` \ entities -> + wlkList rdRenaming mbindren `thenUgn` \ renamings -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc)) + + a_sig_we_hope -> + -- signature(-like) things, including user pragmas + wlk_sig_thing a_sig_we_hope +\end{code} + +ToDo: really needed as separate? +\begin{code} +wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature + = wlkList rdU_unkId sbindids `thenUgn` \ vars -> + wlkPolyType sbindid `thenUgn` \ poly_ty -> + wlkTySigPragmas spragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTySig vars poly_ty pragma src_loc) + +wlk_sig_thing (U_vspec_uprag var vspec_tys srcline) -- value specialisation user-pragma + = wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc + | (ty, using_id) <- tys_and_ids ]) + where + rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName) + rd_ty_and_id pt + = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) -> + wlkPolyType vspec_ty `thenUgn` \ ty -> + wlkList rdU_unkId vspec_id `thenUgn` \ id_list -> + returnUgn(ty, case id_list of { [] -> Nothing; [x] -> Just x }) + +wlk_sig_thing (U_ispec_uprag clas ispec_ty srcline)-- instance specialisation user-pragma + = wlkMonoType ispec_ty `thenUgn` \ ty -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrSpecInstSig (InstSpecSig clas ty src_loc)) + +wlk_sig_thing (U_inline_uprag var inline_howto srcline) -- value inlining user-pragma + = wlkList rdU_stringId inline_howto `thenUgn` \ howto -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + let + guidance -- ToDo: use Maybe type + = (case howto of { + [] -> id; + [x] -> trace "ignoring unfold howto" }) UnfoldAlways + in + returnUgn (RdrInlineValSig (InlineSig var guidance src_loc)) + +wlk_sig_thing (U_deforest_uprag var srcline) -- "deforest me" user-pragma + = mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrDeforestSig (DeforestSig var src_loc)) + +wlk_sig_thing (U_magicuf_uprag var str srcline) -- "magic" unfolding user-pragma + = mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc)) + +wlk_sig_thing (U_abstract_uprag tycon srcline) -- abstract-type-synonym user-pragma + = mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc)) + +wlk_sig_thing (U_dspec_uprag tycon dspec_tys srcline) + = mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkList rdMonoType dspec_tys `thenUgn` \ tys -> + let + spec_ty = MonoTyCon tycon tys + in + returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc)) +\end{code} + +%************************************************************************ +%* * +\subsection[wlkTypes]{Reading in types in various forms (and data constructors)} +%* * +%************************************************************************ + +\begin{code} +rdPolyType :: ParseTree -> UgnM ProtoNamePolyType +rdMonoType :: ParseTree -> UgnM ProtoNameMonoType + +rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype +rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype + +wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType +wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType + +wlkPolyType ttype + = case ttype of + U_context tcontextl tcontextt -> -- context + wlkContext tcontextl `thenUgn` \ ctxt -> + wlkMonoType tcontextt `thenUgn` \ ty -> + returnUgn (OverloadedTy ctxt ty) + + U_uniforall utvs uty -> -- forall type (pragmas) + wlkList rdU_unkId utvs `thenUgn` \ tvs -> + wlkMonoType uty `thenUgn` \ ty -> + returnUgn (ForAllTy tvs ty) + + other -> -- something else + wlkMonoType other `thenUgn` \ ty -> + returnUgn (UnoverloadedTy ty) + +wlkMonoType ttype + = case ttype of + U_tname tycon typel -> -- tycon + wlkList rdMonoType typel `thenUgn` \ tys -> + returnUgn (MonoTyCon tycon tys) + + U_tllist tlist -> -- list type + wlkMonoType tlist `thenUgn` \ ty -> + returnUgn (ListMonoTy ty) + + U_ttuple ttuple -> + wlkList rdPolyType ttuple `thenUgn` \ tys -> + returnUgn (TupleMonoTy tys) + + U_tfun tfun targ -> + wlkMonoType tfun `thenUgn` \ ty1 -> + wlkMonoType targ `thenUgn` \ ty2 -> + returnUgn (FunMonoTy ty1 ty2) + + U_namedtvar tyvar -> -- type variable + returnUgn (MonoTyVar tyvar) + + U_unidict clas t -> -- UniDict (pragmas) + wlkMonoType t `thenUgn` \ ty -> + returnUgn (MonoDict clas ty) + + U_unityvartemplate tv_tmpl -> -- pragmas only + returnUgn (MonoTyVarTemplate tv_tmpl) + +#ifdef DPH +wlkMonoType ('v' : xs) + = wlkMonoType xs `thenUgn` \ (ty, xs1) -> + returnUgn (RdrExplicitPodTy ty, xs1) + BEND + +wlkMonoType ('u' : xs) + = wlkList rdMonoType xs `thenUgn` \ (tys, xs1) -> + wlkMonoType xs1 `thenUgn` \ (ty, xs2) -> + returnUgn (RdrExplicitProcessorTy tys ty, xs2) + BEND BEND +#endif {- Data Parallel Haskell -} + +--wlkMonoType oops = panic ("wlkMonoType:"++oops) +\end{code} + +\begin{code} +wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName]) +wlkContext :: U_list -> UgnM ProtoNameContext +wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName) + +wlkTyConAndTyVars ttype + = wlkMonoType ttype `thenUgn` \ (MonoTyCon tycon ty_args) -> + let + args = [ a | (MonoTyVar a) <- ty_args ] + in + returnUgn (tycon, args) + +wlkContext list + = wlkList rdMonoType list `thenUgn` \ tys -> + returnUgn (map mk_class_assertion tys) + +wlkClassAssertTy xs + = wlkMonoType xs `thenUgn` \ mono_ty -> + returnUgn (mk_class_assertion mono_ty) + +mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName) + +mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname) +mk_class_assertion other + = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n") + -- regrettably, the parser does let some junk past + -- e.g., f :: Num {-nothing-} => a -> ... +\end{code} + +\begin{code} +rdConDecl :: ParseTree -> UgnM ProtoNameConDecl + +rdConDecl pt + = rdU_atype pt `thenUgn` \ (U_atc con atctypel srcline) -> + + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkList rdMonoType atctypel `thenUgn` \ tys -> + returnUgn (ConDecl con tys src_loc) +\end{code} + +%************************************************************************ +%* * +\subsection{Read a ``match''} +%* * +%************************************************************************ + +\begin{code} +rdMatch :: ParseTree -> UgnM RdrMatch + +rdMatch pt + = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind srcfun srcline) -> + + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkPat gpat `thenUgn` \ pat -> + wlkList rd_guarded gdexprs `thenUgn` \ grhss -> + wlkBinding gbind `thenUgn` \ binding -> + + returnUgn (RdrMatch srcline srcfun pat grhss binding) + where + rd_guarded pt + = rdU_list pt `thenUgn` \ list -> + wlkList rdExpr list `thenUgn` \ [g,e] -> + returnUgn (g, e) +\end{code} + +%************************************************************************ +%* * +\subsection[wlkFixity]{Read in a fixity declaration} +%* * +%************************************************************************ + +\begin{code} +{- +wlkFixity :: ParseTree -> UgnM ProtoNameFixityDecl + +wlkFixity pt + = wlkId xs `thenUgn` \ (op, xs1) -> + wlkIdString xs1 `thenUgn` \ (associativity, xs2) -> + wlkIdString xs2 `thenUgn` \ (prec_str, xs3) -> + let + precedence = read prec_str + in + case associativity of { + "infix" -> returnUgn (InfixN op precedence, xs3); + "infixl" -> returnUgn (InfixL op precedence, xs3); + "infixr" -> returnUgn (InfixR op precedence, xs3) + } BEND BEND BEND +-} +\end{code} + +%************************************************************************ +%* * +\subsection[rdImportedInterface]{Read an imported interface} +%* * +%************************************************************************ + +\begin{code} +rdImportedInterface :: ParseTree + -> UgnM ProtoNameImportedInterface + +rdImportedInterface pt + = grab_pieces pt `thenUgn` + \ (expose_or_hide, + modname, + bindexp, + bindren, + binddef, + bindfile, + srcline) -> + + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkList rdEntity bindexp `thenUgn` \ imports -> + wlkList rdRenaming bindren `thenUgn` \ renamings -> + + setSrcFileUgn bindfile ( -- OK, we're now looking inside the .hi file... + wlkBinding binddef + ) `thenUgn` \ iface_bs -> + + case (sepDeclsForInterface iface_bs) of { + (tydecls,classdecls,instdecls,sigs,iimpdecls) -> + let + cv_iface + = MkInterface modname + iimpdecls + [{-fixity decls-}] -- can't get fixity decls in here yet (ToDo) + tydecls + classdecls + (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-} + modname instdecls) + -- False indicates imported + (concat (map cvValSig sigs)) + src_loc -- OLD: (mkSrcLoc importing_srcfile srcline) + in + returnUgn ( + if null imports then + ImportAll cv_iface renamings + else + expose_or_hide cv_iface imports renamings + )} + where + grab_pieces pt + = rdU_binding pt `thenUgn` \ binding -> + returnUgn ( + case binding of + U_import a b c d e f -> (ImportSome, a, b, c, d, e, f) + U_hiding a b c d e f -> (ImportButHide, a, b, c, d, e, f) + ) +\end{code} + +\begin{code} +rdRenaming :: ParseTree -> UgnM Renaming + +rdRenaming pt + = rdU_list pt `thenUgn` \ list -> + wlkList rdU_stringId list `thenUgn` \ [id1, id2] -> + returnUgn (MkRenaming id1 id2) +\end{code} + +\begin{code} +rdEntity :: ParseTree -> UgnM IE + +rdEntity pt + = rdU_entidt pt `thenUgn` \ entity -> + case entity of + U_entid var -> -- just a value + returnUgn (IEVar var) + + U_enttype thing -> -- abstract type constructor/class + returnUgn (IEThingAbs thing) + + U_enttypeall thing -> -- non-abstract type constructor/class + returnUgn (IEThingAll thing) + + U_enttypecons tycon ctentcons -> -- type con w/ data cons listed + wlkList rdU_stringId ctentcons `thenUgn` \ cons -> + returnUgn (IEConWithCons tycon cons) + + U_entclass clas centops -> -- class with ops listed + wlkList rdU_stringId centops `thenUgn` \ ops -> + returnUgn (IEClsWithOps clas ops) + + U_entmod mod -> -- everything provided by a module + returnUgn (IEModuleContents mod) +\end{code} diff --git a/ghc/compiler/reader/reader.lit b/ghc/compiler/reader/reader.lit new file mode 100644 index 0000000..27b6dac --- /dev/null +++ b/ghc/compiler/reader/reader.lit @@ -0,0 +1,30 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Glasgow Haskell compiler: reader} +\author{The GRASP team} +\date{August 1993} +\maketitle +\begin{rawlatex} +\tableofcontents +\pagebreak +\end{rawlatex} +\end{onlystandalone} + +\begin{onlypartofdoc} +\section[reader]{Reader} +\downsection +\end{onlypartofdoc} + +\input{PrefixSyn.lhs} +\input{ReadPrefix.lhs} +\input{PrefixToHs.lhs} + +\upsection +\begin{onlypartofdoc} +\upsection +\end{onlypartofdoc} +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/rename/Rename.hi b/ghc/compiler/rename/Rename.hi new file mode 100644 index 0000000..5735736 --- /dev/null +++ b/ghc/compiler/rename/Rename.hi @@ -0,0 +1,46 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Rename where +import AbsSyn(Module) +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import HsBinds(Binds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsPat(InPat, ProtoNamePat(..), RenamedPat(..)) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..), PreludeNameFun(..), PreludeNameFuns(..)) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import Unique(Unique) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type ProtoNamePat = InPat ProtoName +type RenamedPat = InPat Name +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type GlobalNameFun = ProtoName -> Labda Name +type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) +type PreludeNameFun = _PackedString -> Labda Name +type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +renameModule :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Module ProtoName (InPat ProtoName) -> SplitUniqSupply -> (Module Name (InPat Name), [_PackedString], (ProtoName -> Labda Name, ProtoName -> Labda Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2121 _N_ _S_ "LU(LL)U(LLSLLLLLLLLAL)U(ALL)" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs new file mode 100644 index 0000000..a2900c7 --- /dev/null +++ b/ghc/compiler/rename/Rename.lhs @@ -0,0 +1,145 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1994 +% +\section[Rename]{Renaming and dependency analysis passes} + +\begin{code} +#include "HsVersions.h" + +module Rename ( + renameModule, + + -- for completeness + Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), Name, + ProtoName, SplitUniqSupply, PreludeNameFun(..), + PreludeNameFuns(..), Maybe, Error(..), Pretty(..), PprStyle, + PrettyRep, GlobalNameFuns(..), GlobalNameFun(..), + GlobalSwitch + ) where + +import AbsSyn +import Bag ( isEmptyBag, unionBags, Bag ) +import CmdLineOpts ( GlobalSwitch(..) ) +import RenameMonad12 +import Rename1 +import Rename2 +import Rename3 +import Rename4 +import RenameAuxFuns ( PreludeNameFuns(..), GlobalNameFuns(..) ) +--import Pretty -- ToDo: rm debugging +import SplitUniq ( splitUniqSupply, SplitUniqSupply ) +import Util +\end{code} + +Here's what the renamer does, basically: +\begin{description} +\item[@Rename1@:] +Flattens out the declarations from the interfaces which this module +imports. The result is a new module with no imports, but with more +declarations. (Obviously, the imported declarations have ``funny +names'' [@ProtoNames@] to indicate their origin.) Handles selective +import, renaming, \& such. + +%-------------------------------------------------------------------- +\item[@Rename2@:] +Removes duplicate declarations. Duplicates can arise when two +imported interface have a signature (or whatever) for the same +thing. We check that the two are consistent and then drop one. +Considerable huff and puff to pick the one with the ``better'' +pragmatic information. + +%-------------------------------------------------------------------- +\item[@Rename3@:] +Find all the top-level-ish (i.e., global) entities, assign them +@Uniques@, and make a \tr{ProtoName -> Name} mapping for them, +in preparation for... + +%-------------------------------------------------------------------- +\item[@Rename4@:] +Actually prepare the ``renamed'' module. In sticking @Names@ on +everything, it will catch out-of-scope errors (and a couple of similar +type-variable-use errors). We also our initial dependency analysis of +the program (required before typechecking). +\end{description} + +\begin{code} +renameModule :: (GlobalSwitch -> Bool) -- to check cmd-line opts + -> PreludeNameFuns -- lookup funs for deeply wired-in names + -> ProtoNameModule -- input + -> SplitUniqSupply + -> (RenamedModule, -- output, after renaming + [FAST_STRING], -- Names of the imported modules + -- (profiling needs to know this) + GlobalNameFuns, -- final name funs; used later + -- to rename generated `deriving' + -- bindings. + Bag Error -- Errors, from passes 1-4 + ) + +-- Very space-leak sensitive + +renameModule sw_chkr gnfs@(val_pnf, tc_pnf) + input@(Module mod_name _ _ _ _ _ _ _ _ _ _ _ _) + uniqs + = let + use_mentioned_vars = sw_chkr UseGetMentionedVars + in + BIND ( + BSCC("Rename1") + initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input) + ESCC + ) _TO_ ((mod1, imported_module_names), errs1) -> + + BIND ( + BSCC("Rename2") + initRn12 mod_name (rnModule2 mod1) + ESCC + ) _TO_ (mod2, errs2) -> + +-- pprTrace "rename2:" (ppr PprDebug mod2) ( + + BIND (splitUniqSupply uniqs) _TO_ (us1, us2) -> + + BIND ( + BSCC("Rename3") + initRn3 (rnModule3 gnfs imported_module_names mod2) us1 + ESCC + ) _TO_ (val_space, tc_space, v_gnf, tc_gnf, errs3) -> + + let + final_name_funs = (v_gnf, tc_gnf) + + errs_so_far = errs1 `unionBags` errs2 `unionBags` errs3 + -- see note below about why we consult errs at this pt + in + if not (isEmptyBag errs_so_far) then -- give up now + ( panic "rename", imported_module_names, final_name_funs, errs_so_far ) + else + BIND ( + BSCC("Rename4") + initRn4 sw_chkr final_name_funs (rnModule4 mod2) us2 + ESCC + ) _TO_ (mod4, errs4) -> + + ( mod4, imported_module_names, final_name_funs, errs4 ) + BEND + BEND +-- ) + BEND + BEND + BEND +\end{code} + +Why stop if errors in the first three passes: Suppose you're compiling +a module with a top-level definition named \tr{scaleFloat}. Sadly, +this is also a Prelude class-method name. \tr{rnModule3} will have +detected this error, but: it will also have picked (arbitrarily) one +of the two definitions for its final ``value'' name-function. If, by +chance, it should have picked the class-method... when it comes to pin +a Unique on the top-level (bogus) \tr{scaleFloat}, it will ask for the +class-method's Unique (!); it doesn't have one, and you will get a +panic. + +Another way to handle this would be for the duplicate detector to +clobber duplicates with some ``safe'' value. Then things would be +fine in \tr{rnModule4}. Maybe some other time... diff --git a/ghc/compiler/rename/Rename1.hi b/ghc/compiler/rename/Rename1.hi new file mode 100644 index 0000000..76ece57 --- /dev/null +++ b/ghc/compiler/rename/Rename1.hi @@ -0,0 +1,37 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Rename1 where +import AbsSyn(Module) +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import HsBinds(Binds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsPat(InPat, ProtoNamePat(..)) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..)) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import Unique(Unique) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type ProtoNamePat = InPat ProtoName +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type PreludeNameFun = _PackedString -> Labda Name +type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) +rnModule1 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Bool -> Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((Module ProtoName (InPat ProtoName), [_PackedString]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "U(LL)LU(LLSLLLLLLLLAL)" {_A_ 4 _U_ 222122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/rename/Rename1.lhs b/ghc/compiler/rename/Rename1.lhs new file mode 100644 index 0000000..b9efb8a --- /dev/null +++ b/ghc/compiler/rename/Rename1.lhs @@ -0,0 +1,894 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Rename1]{@Rename1@: gather up imported information} + +See the @Rename@ module for a basic description of the renamer. + +\begin{code} +#include "HsVersions.h" + +module Rename1 ( + rnModule1, + + -- for completeness + Module, Bag, ProtoNamePat(..), InPat, Maybe, + PprStyle, Pretty(..), PrettyRep, ProtoName, Name, + PreludeNameFun(..), PreludeNameFuns(..) + ) where + +IMPORT_Trace -- ToDo: rm +import Pretty -- these two too +import Outputable + +import AbsSyn +import AbsSynFuns ( getMentionedVars ) -- *** not via AbsSyn *** +import Bag ( Bag, emptyBag, unitBag, snocBag, unionBags, bagToList ) +import Errors +import HsPragmas +import FiniteMap +import Maybes ( maybeToBool, catMaybes, Maybe(..) ) +--OLD: import NameEnv ( mkStringLookupFn ) +import ProtoName ( ProtoName(..), mkPreludeProtoName ) +import RenameAuxFuns +import RenameMonad12 +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection{Types and things used herein} +%* * +%************************************************************************ + +@AllIntDecls@ is the type returned from processing import statement(s) +in the main module. + +\begin{code} +type AllIntDecls = ([ProtoNameFixityDecl], [ProtoNameTyDecl], + [ProtoNameClassDecl], [ProtoNameInstDecl], + [ProtoNameSig], Bag FAST_STRING) +\end{code} + +The selective-import function @SelectiveImporter@ maps a @ProtoName@ +to something which indicates how much of the thing, if anything, is +wanted by the importing module. +\begin{code} +type SelectiveImporter = ProtoName -> Wantedness + +data Wantedness + = Wanted + | NotWanted + | WantedWith IE +\end{code} + +The @ProtoNames@ supplied to these ``name functions'' are always +@Unks@, unless they are fully-qualified names, which occur only in +interface pragmas (and, therefore, never on the {\em definitions} of +things). That doesn't happen in @Rename1@! +\begin{code} +type IntNameFun = ProtoName -> ProtoName +type IntTCNameFun = ProtoName -> (ProtoName, IntNameFun) +\end{code} + +%************************************************************************ +%* * +\subsection{First pass over the entire module} +%* * +%************************************************************************ + +This pass flattens out the declarations embedded within the interfaces +which this module imports. The result is a new module with no +imports, but with more declarations. The declarations which arose +from the imported interfaces will have @ProtoNames@ with @Imp@ +constructors; the declarations in the body of this module are +unaffected, so they will still be @Unk@'s. + +We import only the declarations from interfaces which are actually {\em +used}. This saves time later, because we don't need process the +unused ones. + +\begin{code} +rnModule1 :: PreludeNameFuns + -> Bool -- see use below + -> ProtoNameModule + -> Rn12M (ProtoNameModule, [FAST_STRING]) + +rnModule1 pnf@(v_pnf, tc_pnf) + use_mentioned_vars_heuristic + (Module mod_name exports imports fixes + ty_decls absty_sigs class_decls inst_decls specinst_sigs + defaults binds _ src_loc) + + = -- slurp through the *body* of the module, collecting names of + -- mentioned *variables*, 3+ letters long & not prelude names. + -- Note: we *do* have to pick up top-level binders, + -- so we can check for conflicts with imported guys! + let +{- OLD:MENTIONED-} + (uses_Mdotdot_in_exports, mentioned_vars) + = getMentionedVars v_pnf exports fixes class_decls inst_decls binds + + -- Using the collected "mentioned" variables, create an + -- "is-mentioned" function (:: FAST_STRING -> Bool), which gives + -- True if something is mentioned is in the list collected. + -- For more details, see under @selectAll@, notably the + -- handling of short (< 3 chars) names. + + -- Note: this "is_mentioned" game doesn't work if the export + -- list includes any M.. constructs (because that mentions + -- variables *implicitly*, basically). getMentionedVars tells + -- us this, and we act accordingly. + + is_mentioned_maybe + = lookupFM {-OLD: mkStringLookupFn-} (listToFM + [ (x, panic "is_mentioned_fn") + | x <- mentioned_vars ++ needed_for_deriving ] + ) + -- OLD: False{-not-sorted-} + where + needed_for_deriving -- is this a HACK or what? + = [ SLIT("&&"), + SLIT("."), + SLIT("lex"), + SLIT("map"), + SLIT("not"), + SLIT("readParen"), + SLIT("showParen"), + SLIT("showSpace__"), + SLIT("showString") + ] + + is_mentioned_fn + = if use_mentioned_vars_heuristic + && not (uses_Mdotdot_in_exports) + then \ x -> maybeToBool (is_mentioned_maybe x) + else \ x -> True +{- OLD:MENTIONED-} +--O:M is_mentioned_fn = \ x -> True -- ToDo: delete altogether + in + -- OK, now do the business: + doImportedIfaces pnf is_mentioned_fn imports + `thenRn12` \ (int_fixes, int_ty_decls, + int_class_decls, int_inst_decls, + int_sigs, import_names) -> + let + inst_decls' = doRevoltingInstDecls tc_nf inst_decls + in + returnRn12 + ((Module mod_name + exports imports -- passed along mostly for later checking + (int_fixes ++ fixes) + (int_ty_decls ++ ty_decls) + absty_sigs + (int_class_decls ++ class_decls) + (int_inst_decls ++ inst_decls') + specinst_sigs + defaults + binds + int_sigs + src_loc), + bagToList import_names) + where + -- This function just spots prelude names + tc_nf pname@(Unk s) = case (tc_pnf s) of + Nothing -> pname + Just name -> Prel name + + tc_nf other_pname = panic "In tc_nf passed to doRevoltingInstDecls" + -- The only place where Imps occur is on Ids in unfoldings; + -- this function is only used on type-things. +\end{code} + +Instance declarations in the module itself are treated in a horribly +special way. Because their class name and type constructor will be +compared against imported ones in the second pass (to eliminate +duplicate instance decls) we need to make Prelude classes and tycons +appear as such. (For class and type decls, the module can't be +declaring a prelude class or tycon, so Prel and Unk things can just +compare non-equal.) This is a HACK. + +\begin{code} +doRevoltingInstDecls :: IntNameFun -> [ProtoNameInstDecl] -> [ProtoNameInstDecl] + +doRevoltingInstDecls tc_nf decls + = map revolt_me decls + where + revolt_me (InstDecl context cname ty binds True modname imod uprags pragma src_loc) + = InstDecl + context -- Context unchanged + (tc_nf cname) -- Look up the class + (doIfaceMonoType1 tc_nf ty) -- Ditto the type + binds -- Binds unchanged + True + modname + imod + uprags + pragma + src_loc +\end{code} + +%************************************************************************ +%* * +\subsection{Process a module's imported interfaces} +%* * +%************************************************************************ + +@doImportedIfaces@ processes the entire set of interfaces imported by the +module being renamed. + +\begin{code} +doImportedIfaces :: PreludeNameFuns + -> (FAST_STRING -> Bool) + -> [ProtoNameImportedInterface] + -> Rn12M AllIntDecls + +doImportedIfaces pnfs is_mentioned_fn [] + = returnRn12 ( [{-fixities-}], [{-tydecls-}], [{-clasdecls-}], + [{-instdecls-}], [{-sigs-}], emptyBag ) + +doImportedIfaces pnfs is_mentioned_fn (iface:ifaces) + = doOneIface pnfs is_mentioned_fn iface + `thenRn12` \ (ifixes1, itd1, icd1, iid1, isd1, names1) -> + + doImportedIfaces pnfs is_mentioned_fn ifaces + `thenRn12` \ (ifixes2, itd2, icd2, iid2, isd2, names2) -> + + returnRn12 (ifixes1 ++ ifixes2, + itd1 ++ itd2, + icd1 ++ icd2, + iid1 ++ iid2, + isd1 ++ isd2, + names1 `unionBags` names2) +\end{code} + +\begin{code} +doOneIface pnfs is_mentioned_fn (ImportAll int renamings) + = let + renaming_fn = mkRenamingFun renamings + -- if there are any renamings, then we don't use + -- the "is_mentioned_fn" hack; possibly dangerous (paranoia reigns) + revised_is_mentioned_fn + = if null renamings + then is_mentioned_fn + else (\ x -> True) -- pretend everything is mentioned + in +-- pprTrace "ImportAll:mod_rns:" (ppr PprDebug renamings) ( + doIface1 renaming_fn pnfs (selectAll renaming_fn revised_is_mentioned_fn) int +-- ) + +doOneIface pnfs unused_is_mentioned_fn (ImportSome int ie_list renamings) + = --pprTrace "ImportSome:mod_rns:" (ppr PprDebug renamings) ( + doIface1 (mkRenamingFun renamings) pnfs si_fun int + --) + where + -- the `selective import' function should not be applied + -- to the Imps that occur on Ids in unfoldings. + + si_fun (Unk str) = check_ie str ie_list + si_fun other = panic "si_fun in doOneIface" + + check_ie name [] = NotWanted + check_ie name (ie:ies) + = case ie of + IEVar n | name == n -> Wanted + IEThingAbs n | name == n -> WantedWith ie + IEThingAll n | name == n -> WantedWith ie + IEConWithCons n ns | name == n -> WantedWith ie + IEClsWithOps n ns | name == n -> WantedWith ie + IEModuleContents _ -> panic "Module.. in import list?" + other -> check_ie name ies + +doOneIface pnfs unused_is_mentioned_fn (ImportButHide int ie_list renamings) + = --pprTrace "ImportButHide:mod_rns:" (ppr PprDebug renamings) ( + doIface1 (mkRenamingFun renamings) pnfs si_fun int + --) + where + -- see comment above: + + si_fun (Unk str) | str `elemFM` entity_info = NotWanted + | otherwise = Wanted + + entity_info = fst (getIEStrings ie_list) +\end{code} + +@selectAll@ ``normally'' creates an @SelectiveImporter@ that declares +everything from an interface to be @Wanted@. We may, however, pass +in a more discriminating @is_mentioned_fn@ (returns @True@ if the +named entity is mentioned in the body of the module in question), which +can be used to trim off junk from an interface. + +For @selectAll@ to say something is @NotWanted@, it must be a +variable, it must not be in the collected-up list of mentioned +variables (checked with @is_mentioned_fn@), and it must be three chars +or longer. + +And, of course, we mustn't forget to take account of renaming! + +ADR Question: What's so magical about names longer than 3 characters? +Why would we want to keep long names which aren't mentioned when we're +quite happy to throw away short names that aren't mentioned? + +\begin{code} +selectAll :: (FAST_STRING -> FAST_STRING) -> (FAST_STRING -> Bool) -> SelectiveImporter + +selectAll renaming_fn is_mentioned_fn (Unk str) -- gotta be an Unk + = let + rn_str = renaming_fn str + in + if (isAvarid rn_str) + && (not (is_mentioned_fn rn_str)) + && (_UNPK_ rn_str `lengthExceeds` 2) + then NotWanted + else Wanted +\end{code} + + +%************************************************************************ +%* * +\subsection{First pass over a particular interface} +%* * +%************************************************************************ + + +@doIface1@ handles a specific interface. First it looks at the +interface imports, creating a bag that maps local names back to their +original names, from which it makes a function that does the same. It +then uses this function to create a triple of bags for the interface +type, class and value declarations, in which local names have been +mapped back into original names. + +Notice that @mkLocalNameFun@ makes two different functions. The first +is the name function for the interface. This takes a local name and +provides an original name for any name in the interface by using +either of: +\begin{itemize} +\item +the original name produced by the renaming function; +\item +the local name in the interface and the interface name. +\end{itemize} + +The function @doIfaceImports1@ receives two association lists which will +be described at its definition. + +\begin{code} +doIface1 :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module + -> PreludeNameFuns + -> SelectiveImporter + -> ProtoNameInterface + -> Rn12M AllIntDecls + +doIface1 mod_rn_fn (v_pnf, tc_pnf) sifun + (MkInterface i_name import_decls fix_decls ty_decls class_decls + inst_decls sig_decls anns) + + = doIfaceImports1 mod_rn_fn i_name import_decls `thenRn12` \ (v_bag, tc_bag) -> + do_body (v_bag, tc_bag) + where + do_body (v_bag, tc_bag) + = report_all_errors `thenRn12` \ _ -> + + doIfaceTyDecls1 sifun full_tc_nf ty_decls `thenRn12` \ ty_decls' -> + + doIfaceClassDecls1 sifun full_tc_nf class_decls `thenRn12` \ class_decls' -> + + let sig_decls' = doIfaceSigs1 sifun v_nf tc_nf sig_decls + fix_decls' = doIfaceFixes1 sifun v_nf fix_decls + inst_decls' = doIfaceInstDecls1 sifun tc_nf inst_decls + in + returnRn12 (fix_decls', ty_decls', class_decls', inst_decls', sig_decls', unitBag i_name) + where + v_dups :: [[(FAST_STRING, ProtoName)]] + tc_dups :: [[(FAST_STRING, (ProtoName, IntNameFun))]] + + (imp_v_nf, v_dups) = mkNameFun {-OLD:v_pnf-} v_bag + (imp_tc_nf, tc_dups) = mkNameFun {-OLD:tc_pnf-} tc_bag + + v_nf :: IntNameFun + v_nf (Unk s) = case v_pnf s of + Just n -> mkPreludeProtoName n + Nothing -> case imp_v_nf s of + Just n -> n + Nothing -> Imp i_name s [i_name] (mod_rn_fn s) + + prel_con_or_op_nf :: FAST_STRING{-module name-}-> IntNameFun + -- Used for (..)'d parts of prelude datatype/class decls; + -- OLD:? For `data' types, we happen to know everything; + -- OLD:? For class decls, we *don't* know what the class-ops are. + prel_con_or_op_nf m (Unk s) + = case v_pnf s of + Just n -> mkPreludeProtoName n + Nothing -> Imp m s [m] (mod_rn_fn s) + -- Strictly speaking, should be *no renaming* here, folks + + local_con_or_op_nf :: IntNameFun + -- used for non-prelude constructors/ops + local_con_or_op_nf (Unk s) = Imp i_name s [i_name] (mod_rn_fn s) + + full_tc_nf :: IntTCNameFun + full_tc_nf (Unk s) + = case tc_pnf s of + Just n -> (mkPreludeProtoName n, + let + mod = fst (getOrigName n) + in + prel_con_or_op_nf mod) + + Nothing -> case imp_tc_nf s of + Just pair -> pair + Nothing -> (Imp i_name s [i_name] (mod_rn_fn s), + local_con_or_op_nf) + + tc_nf = fst . full_tc_nf + + -- ADR: commented out next new lines because I don't believe + -- ADR: the check is useful or required by the Standard. (It + -- ADR: also messes up the interpreter.) + + tc_errs = [] -- map (map (fst . snd)) tc_dups + -- Ugh! Just keep the dup'd protonames + v_errs = [] -- map (map snd) v_dups + -- Ditto + + report_all_errors + = mapRn12 (addErrRn12 . duplicateImportsInInterfaceErr (_UNPK_ i_name)) + (tc_errs ++ v_errs) +\end{code} + + +%************************************************************************ +%* * +\subsection{doIfaceImports1} +%* * +%************************************************************************ + +@ImportNameBags@ is a pair of bags (one for values, one for types and +classes) which specify the new names brought into scope by some +import declarations in an interface. + +\begin{code} +type ImportNameBags = (Bag (FAST_STRING, ProtoName), + Bag (FAST_STRING, (ProtoName, IntNameFun)) + ) +\end{code} + +\begin{code} +doIfaceImports1 + :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module + -> FAST_STRING -- name of module whose interface we're doing + -> [IfaceImportDecl] + -> Rn12M ImportNameBags + +doIfaceImports1 _ _ [] = returnRn12 (emptyBag, emptyBag) + +doIfaceImports1 mod_rn_fn int_mod_name (imp_decl1 : rest) + = do_decl imp_decl1 `thenRn12` \ (vb1, tcb1) -> + doIfaceImports1 mod_rn_fn int_mod_name rest `thenRn12` \ (vb2, tcb2) -> +-- pprTrace "vbags/tcbags:" (ppr PprDebug (vb1 `unionBags` vb2, [(s,p) | (s,(p,_)) <- bagToList (tcb1 `unionBags` tcb2)])) ( + returnRn12 (vb1 `unionBags` vb2, tcb1 `unionBags` tcb2) +-- ) + where + do_decl (IfaceImportDecl orig_mod_name imports renamings src_loc) + = -- Look at the renamings to get a suitable renaming function + doRenamings mod_rn_fn int_mod_name orig_mod_name renamings + `thenRn12` \ (orig_to_pn, local_to_pn) -> + + -- Now deal with one import at a time, combining results. + returnRn12 ( + foldl (doIfaceImport1 orig_to_pn local_to_pn) + (emptyBag, emptyBag) + imports + ) +\end{code} + +@doIfaceImport1@ takes a list of imports and the pair of renaming functions, +returning a bag which maps local names to original names. + +\begin{code} +doIfaceImport1 :: ( FAST_STRING -- Original local name + -> (FAST_STRING, -- Local name in this interface + ProtoName) -- Its full protoname + ) + + -> IntNameFun -- Local name to ProtoName; use for + -- constructors and class ops + + -> ImportNameBags -- Accumulator + -> IE -- An item in the import list + -> ImportNameBags + +doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) (IEVar orig_name) + = (v_bag `snocBag` (orig_to_pn orig_name), tc_bag) + +doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAbs orig_name) + = int_import1_help orig_to_pn local_to_pn acc orig_name + +doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name) + = int_import1_help orig_to_pn local_to_pn acc orig_name + +doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other + = panic "Rename1: strange import decl" + +-- Little help guy... + +int_import1_help orig_to_pn local_to_pn (v_bag, tc_bag) orig_name + = case (orig_to_pn orig_name) of { (str, o_name) -> + (v_bag, tc_bag `snocBag` (str, (o_name, local_to_pn))) + } +\end{code} + + +The renaming-processing code. It returns two name-functions. The +first maps the {\em original} name for an entity onto a @ProtoName@ +--- it is used when running over the list of things to be imported. +The second maps the {\em local} name for a constructor or class op +back to its original name --- it is used when scanning the RHS of +a @data@ or @class@ decl. + +It can produce errors, if there is a domain clash on the renamings. + +\begin{code} +--pprTrace +--instance Outputable _PackedString where +-- ppr sty s = ppStr (_UNPK_ s) + +doRenamings :: (FAST_STRING -> FAST_STRING) -- Renamings in import stmt of module + -> FAST_STRING -- Name of the module whose interface we're working on + -> FAST_STRING -- Original-name module for these renamings + -> [Renaming] -- Renamings + -> Rn12M + ((FAST_STRING -- Original local name to... + -> (FAST_STRING, -- ... Local name in this interface + ProtoName) -- ... Its full protoname + ), + IntNameFun) -- Use for constructors, class ops + +doRenamings mod_rn_fn int_mod orig_mod [] + = returnRn12 ( + \ s -> + let + result = (s, Imp orig_mod s [int_mod] (mod_rn_fn s)) + in +-- pprTrace "name1a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( + result +-- ) + , + + \ (Unk s) -> + let + result = Imp orig_mod s [int_mod] (mod_rn_fn s) + in +-- pprTrace "name2a:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( + result +-- ) + ) + +doRenamings mod_rn_fn int_mod orig_mod renamings + = let + local_rn_fn = mkRenamingFun renamings + in + --pprTrace "local_rns:" (ppr PprDebug renamings) ( + returnRn12 ( + \ s -> + let + local_name = local_rn_fn s + result + = (local_name, Imp orig_mod s [int_mod] (mod_rn_fn local_name)) + in +-- pprTrace "name1:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( + result +-- ) + , + + \ (Unk s) -> + let + result + = Imp orig_mod s [int_mod] (mod_rn_fn (local_rn_fn s)) + in +-- pprTrace "name2:" (ppCat [ppr PprDebug s, ppr PprDebug result]) ( + result +-- ) + ) + --) +\end{code} + +\begin{code} +mkRenamingFun :: [Renaming] -> FAST_STRING -> FAST_STRING + +mkRenamingFun [] = \ s -> s +mkRenamingFun renamings + = let + rn_fn = lookupFM (listToFM -- OLD: mkStringLookupFn + [ (old, new) | MkRenaming old new <- renamings ] + ) -- OLD: False {-not-sorted-} + in + \s -> case rn_fn s of + Nothing -> s + Just s' -> s' +\end{code} + + +%************************************************************************ +%* * +\subsection{Type declarations} +%* * +%************************************************************************ + +@doIfaceTyDecls1@ uses the `name function' to map local tycon names into +original names, calling @doConDecls1@ to do the same for the +constructors. @doTyDecls1@ is used to do both module and interface +type declarations. + +\begin{code} +doIfaceTyDecls1 :: SelectiveImporter + -> IntTCNameFun + -> [ProtoNameTyDecl] + -> Rn12M [ProtoNameTyDecl] + +doIfaceTyDecls1 sifun full_tc_nf ty_decls + = mapRn12 do_decl ty_decls `thenRn12` \ decls_maybe -> + returnRn12 (catMaybes decls_maybe) + where + do_decl (TyData context tycon tyvars condecls derivs (DataPragmas hidden_cons specs) src_loc) + = let + full_thing = returnRn12 (Just ty_decl') + in + -- GHC doesn't allow derivings in interfaces + (if null derivs + then returnRn12 () + else addErrRn12 (derivingInIfaceErr tycon derivs src_loc) + ) `thenRn12` \ _ -> + + case (sifun tycon) of + NotWanted -> returnRn12 Nothing + Wanted -> full_thing + WantedWith (IEThingAll _) -> full_thing + WantedWith (IEThingAbs _) -> returnRn12 (Just abs_ty_decl') + WantedWith ie@(IEConWithCons _ _) -> full_thing + + WantedWith really_weird_ie -> -- probably a typo in the pgm + addErrRn12 (weirdImportExportConstraintErr + tycon really_weird_ie src_loc) `thenRn12` \ _ -> + full_thing + where + (tycon_name, constr_nf) = full_tc_nf tycon + tc_nf = fst . full_tc_nf + + condecls' = map (do_condecl constr_nf tc_nf) condecls + hidden_cons' = map (do_condecl constr_nf tc_nf) hidden_cons + + pragmas' invent_hidden + = DataPragmas (if null hidden_cons && invent_hidden + then condecls' -- if importing abstractly but condecls were + -- exported we add them to the data pragma + else hidden_cons') + specs {- ToDo: do_specs -} + + context' = doIfaceContext1 tc_nf context + deriv' = map tc_nf derivs -- rename derived classes + + ty_decl' = TyData context' tycon_name tyvars condecls' deriv' (pragmas' False) src_loc + abs_ty_decl'= TyData context' tycon_name tyvars [] deriv' (pragmas' True) src_loc + + do_decl (TySynonym tycon tyvars monoty pragmas src_loc) + = let + full_thing = returnRn12 (Just ty_decl') + in + case (sifun tycon) of + NotWanted -> returnRn12 Nothing + Wanted -> full_thing + WantedWith (IEThingAll _) -> full_thing + + WantedWith weird_ie -> full_thing + where + (tycon_name,_) = full_tc_nf tycon + tc_nf = fst . full_tc_nf + monoty' = doIfaceMonoType1 tc_nf monoty + ty_decl' = TySynonym tycon_name tyvars monoty' pragmas src_loc + + -- one name fun for the data constructor, another for the type: + + do_condecl c_nf tc_nf (ConDecl name tys src_loc) + = ConDecl (c_nf name) (doIfaceMonoTypes1 tc_nf tys) src_loc +\end{code} + +%************************************************************************ +%* * +\subsection{Class declarations} +%* * +%************************************************************************ + +@doIfaceClassDecls1@ uses the `name function' to map local class names into +original names, calling @doIfaceClassOp1@ to do the same for the +class operations. @doClassDecls1@ is used to process both module and +interface class declarations. + +\begin{code} +doIfaceClassDecls1 :: SelectiveImporter + -> IntTCNameFun + -> [ProtoNameClassDecl] + -> Rn12M [ProtoNameClassDecl] + +doIfaceClassDecls1 sifun full_tc_nf clas_decls + = mapRn12 do_decl clas_decls `thenRn12` \ decls_maybe -> + returnRn12 (catMaybes decls_maybe) + where + do_decl (ClassDecl ctxt cname tyvar sigs bs@EmptyMonoBinds prags locn) + -- No defaults in interface + = let + full_thing = returnRn12 (Just class_decl') + in + case (sifun cname) of + NotWanted -> returnRn12 Nothing + Wanted -> full_thing + WantedWith (IEThingAll _) -> full_thing +--??? WantedWith (IEThingAbs _) -> returnRn12 (Just abs_class_decl') + WantedWith (IEClsWithOps _ _) -> full_thing + -- ToDo: add checking of IEClassWithOps + WantedWith really_weird_ie -> -- probably a typo in the pgm + addErrRn12 (weirdImportExportConstraintErr + cname really_weird_ie locn) `thenRn12` \ _ -> + full_thing + where + (clas, op_nf) = full_tc_nf cname + tc_nf = fst . full_tc_nf + + sigs' = map (doIfaceClassOp1 op_nf tc_nf) sigs + ctxt' = doIfaceContext1 tc_nf ctxt + + class_decl' = ClassDecl ctxt' clas tyvar sigs' bs prags locn + abs_class_decl' = ClassDecl ctxt' clas tyvar [] bs prags locn +\end{code} + +\begin{code} +doIfaceClassOp1 :: IntNameFun -- Use this for the class ops + -> IntNameFun -- Use this for the types + -> ProtoNameClassOpSig + -> ProtoNameClassOpSig + +doIfaceClassOp1 op_nf tc_nf (ClassOpSig v ty pragma src_loc) + = ClassOpSig (op_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc +\end{code} + +%************************************************************************ +%* * +\subsection{Instance declarations} +%* * +%************************************************************************ + +We select the instance decl if either the class or the type constructor +are selected. + +\begin{code} +doIfaceInstDecls1 :: SelectiveImporter + -> IntNameFun + -> [ProtoNameInstDecl] + -> [ProtoNameInstDecl] + +doIfaceInstDecls1 si tc_nf inst_decls + = catMaybes (map do_decl inst_decls) + where + do_decl (InstDecl context cname ty EmptyMonoBinds False modname imod uprags pragmas src_loc) + = case (si cname, tycon_reqd) of + (NotWanted, NotWanted) -> Nothing + _ -> Just inst_decl' + where + context' = doIfaceContext1 tc_nf context + ty' = doIfaceMonoType1 tc_nf ty + + inst_decl' = InstDecl context' (tc_nf cname) ty' EmptyMonoBinds False modname imod uprags pragmas src_loc + + tycon_reqd + = case getNonPrelOuterTyCon ty of + Nothing -> NotWanted -- Type doesn't have a user-defined tycon + -- at its outermost level + Just tycon -> si tycon -- It does, so look up in the si-fun +\end{code} + +%************************************************************************ +%* * +\subsection{Signature declarations} +%* * +%************************************************************************ + +@doIfaceSigs1@ uses the name function to create a bag that +maps local names into original names. + +NB: Can't have user-pragmas & other weird things in interfaces. + +\begin{code} +doIfaceSigs1 :: SelectiveImporter -> IntNameFun -> IntNameFun + -> [ProtoNameSig] + -> [ProtoNameSig] + +doIfaceSigs1 si v_nf tc_nf sigs + = catMaybes (map do_sig sigs) + where + do_sig (Sig v ty pragma src_loc) + = case (si v) of + NotWanted -> Nothing + Wanted -> Just (Sig (v_nf v) (doIfacePolyType1 tc_nf ty) pragma src_loc) + -- WantedWith doesn't make sense +\end{code} + + +%************************************************************************ +%* * +\subsection{Fixity declarations} +%* * +%************************************************************************ + +\begin{code} +doIfaceFixes1 :: SelectiveImporter -> IntNameFun + -> [ProtoNameFixityDecl] + -> [ProtoNameFixityDecl] + +doIfaceFixes1 si vnf fixities + = catMaybes (map do_fixity fixities) + where + do_fixity (InfixL name i) = do_one InfixL name i + do_fixity (InfixR name i) = do_one InfixR name i + do_fixity (InfixN name i) = do_one InfixN name i + + do_one con name i + = case si name of + Wanted -> Just (con (vnf name) i) + NotWanted -> Nothing +\end{code} + + +%************************************************************************ +%* * +\subsection{doContext, MonoTypes, MonoType, Polytype} +%* * +%************************************************************************ + +\begin{code} +doIfacePolyType1 :: IntNameFun -> ProtoNamePolyType -> ProtoNamePolyType + +doIfacePolyType1 tc_nf (UnoverloadedTy ty) + = UnoverloadedTy (doIfaceMonoType1 tc_nf ty) + +doIfacePolyType1 tc_nf (OverloadedTy ctxt ty) + = OverloadedTy (doIfaceContext1 tc_nf ctxt) (doIfaceMonoType1 tc_nf ty) +\end{code} + +\begin{code} +doIfaceContext1 :: IntNameFun -> ProtoNameContext -> ProtoNameContext +doIfaceContext1 tc_nf context = [(tc_nf clas, tyvar) | (clas,tyvar) <- context] +\end{code} + + +\begin{code} +doIfaceMonoTypes1 :: IntNameFun -> [ProtoNameMonoType] -> [ProtoNameMonoType] +doIfaceMonoTypes1 tc_nf tys = map (doIfaceMonoType1 tc_nf) tys +\end{code} + + +\begin{code} +doIfaceMonoType1 :: IntNameFun -> ProtoNameMonoType -> ProtoNameMonoType + +doIfaceMonoType1 tc_nf (MonoTyVar tyvar) = MonoTyVar tyvar + +doIfaceMonoType1 tc_nf (ListMonoTy ty) + = ListMonoTy (doIfaceMonoType1 tc_nf ty) + +doIfaceMonoType1 tc_nf (FunMonoTy ty1 ty2) + = FunMonoTy (doIfaceMonoType1 tc_nf ty1) (doIfaceMonoType1 tc_nf ty2) + +doIfaceMonoType1 tc_nf (TupleMonoTy tys) + = TupleMonoTy (map (doIfacePolyType1 tc_nf) tys) + +doIfaceMonoType1 tc_nf (MonoTyCon name tys) + = MonoTyCon (tc_nf name) (doIfaceMonoTypes1 tc_nf tys) + +#ifdef DPH +doIfaceMonoType1 tc_nf (MonoTyProc tys ty) + = MonoTyProc (doIfaceMonoTypes1 tc_nf tys) (doIfaceMonoType1 tc_nf ty) + +doIfaceMonoType1 tc_nf (MonoTyPod ty) + = MonoTyPod (doIfaceMonoType1 tc_nf ty) +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/rename/Rename2.hi b/ghc/compiler/rename/Rename2.hi new file mode 100644 index 0000000..787f628 --- /dev/null +++ b/ghc/compiler/rename/Rename2.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Rename2 where +import AbsSyn(Module) +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import HsBinds(Binds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsPat(InPat, ProtoNamePat(..)) +import Name(Name) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type ProtoNamePat = InPat ProtoName +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +rnModule2 :: Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (Module ProtoName (InPat ProtoName), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLSSSSSSLLSL)" _N_ _N_ #-} + diff --git a/ghc/compiler/rename/Rename2.lhs b/ghc/compiler/rename/Rename2.lhs new file mode 100644 index 0000000..2495389 --- /dev/null +++ b/ghc/compiler/rename/Rename2.lhs @@ -0,0 +1,816 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1995 +% +\section[Rename2]{Second renaming pass: boil down to non-duplicated info} + +\begin{code} +#include "HsVersions.h" + +module Rename2 ( + rnModule2, + + -- for completeness + Module, Bag, ProtoNamePat(..), InPat, + PprStyle, Pretty(..), PrettyRep, ProtoName + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty +import Outputable + +import AbsSyn +import Errors ( dupNamesErr, Error(..) ) +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsTypes ( pprParendMonoType ) +import IdInfo ( DeforestInfo(..) ) +import Maybes ( Maybe(..) ) +import ProtoName +import RenameMonad12 +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} + +This pass removes duplicate declarations. Duplicates can arise when +two imported interface have a signature (or whatever) for the same +thing. We check that the two are consistent and then drop one. + +For preference, if one is declared in this module and the other is +imported, we keep the former; in the case of an instance decl or type +decl, the local version has a lot more information which we must not +lose! + +Similarly, if one has interesting pragmas and one has not, we keep the +former. + +The notion of ``duplicate'' includes an imported signature and a +binding in this module. In this case, the signature is discarded. +See note below about how this should be improved. + +ToDo: There are still known cases in which we blithely consider two +declarations to be ``duplicates'' and we then select one of them, {\em +without} actually checking that they contain the same information! +[WDP 93/8/16] [Improved, at least WDP 93/08/26] + +\begin{code} +rnModule2 :: ProtoNameModule -> Rn12M ProtoNameModule + +rnModule2 (Module mod_name exports imports fixes + ty_decls absty_sigs class_decls inst_decls specinst_sigs + defaults binds int_sigs src_loc) + + = uniquefy mod_name cmpFix selFix fixes + `thenRn12` \ fixes -> + + uniquefy mod_name cmpTys selTys ty_decls + `thenRn12` \ ty_decls -> + + uniquefy mod_name cmpTySigs selTySigs absty_sigs + `thenRn12` \ absty_sigs -> + + uniquefy mod_name cmpClassDecl selClass class_decls + `thenRn12` \ class_decls -> + + uniquefy mod_name cmpInst selInst inst_decls + `thenRn12` \ inst_decls -> + + uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs + `thenRn12` \ specinst_sigs -> + + -- From the imported signatures discard any which are for + -- variables bound in this module. + -- But, be wary of those that *clash* with those for this + -- module... + -- Note that we want to do this properly later (ToDo) because imported + -- signatures may differ from those declared in the module itself. + + rm_sigs_for_here mod_name int_sigs + `thenRn12` \ non_here_int_sigs -> + + uniquefy mod_name cmpSig selSig non_here_int_sigs + `thenRn12` \ int_sigs -> + returnRn12 + (Module mod_name + exports -- export and import lists are passed along + imports -- for checking in Rename3; no other reason + fixes + ty_decls + absty_sigs + class_decls + inst_decls + specinst_sigs + defaults + binds + int_sigs + src_loc) + where + top_level_binders = collectTopLevelBinders binds + + rm_sigs_for_here :: FAST_STRING -> [ProtoNameSig] -> Rn12M [ProtoNameSig] + -- NB: operates only on interface signatures, so don't + -- need to worry about user-pragmas, etc. + + rm_sigs_for_here mod_name [] = returnRn12 [] + + rm_sigs_for_here mod_name (sig@(Sig name _ _ src_loc) : more_sigs) + = rm_sigs_for_here mod_name more_sigs `thenRn12` \ rest_sigs -> + + if not (name `elemByLocalNames` top_level_binders) then -- no name clash... + returnRn12 (sig : rest_sigs) + + else -- name clash... + if name `elemProtoNames` top_level_binders + && name_for_this_module name then + -- the very same thing; just drop it + returnRn12 rest_sigs + else + -- a different thing with the same name (due to renaming?) + -- ToDo: locations need improving + report_dup "(renamed?) variable" + name src_loc name mkUnknownSrcLoc + rest_sigs + where + name_for_this_module (Imp m _ _ _) = m == mod_name + name_for_this_module other = True +\end{code} + +%************************************************************************ +%* * +\subsection[FixityDecls-Rename2]{Functions for @FixityDecls@} +%* * +%************************************************************************ + +\begin{code} +cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_ + +cmpFix (InfixL n1 i1) (InfixL n2 i2) = n1 `cmpProtoName` n2 +cmpFix (InfixL n1 i1) other = LT_ +cmpFix (InfixR n1 i1) (InfixR n2 i2) = n1 `cmpProtoName` n2 +cmpFix (InfixR n1 i1) (InfixN n2 i2) = LT_ +cmpFix (InfixN n1 i1) (InfixN n2 i2) = n1 `cmpProtoName` n2 +cmpFix a b = GT_ +\end{code} + +We are pretty un-fussy about which FixityDecl we keep. + +\begin{code} +selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl +selFix f1 f2 = returnRn12 f1 +\end{code} + +%************************************************************************ +%* * +\subsection[TyDecls-Rename2]{Functions for @TyDecls@} +%* * +%************************************************************************ + +\begin{code} +cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_ + +cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2 +cmpTys (TyData _ n1 _ _ _ _ _) other = LT_ +cmpTys (TySynonym n1 _ _ _ _) (TySynonym n2 _ _ _ _) = cmpProtoName n1 n2 +cmpTys a b = GT_ +\end{code} + +\begin{code} +selTys :: ProtoNameTyDecl -> ProtoNameTyDecl + -> Rn12M ProtoNameTyDecl + +-- Note: we could check these more closely. +-- NB: It would be a mistake to cross-check derivings, +-- because we don't preserve those in interfaces. + +selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1) + td2@(TyData _ name2 _ cons2 _ pragmas2 locn2) + = selByBetterName "algebraic datatype" + name1 pragmas1 locn1 td1 + name2 pragmas2 locn2 td2 + (\ p -> TyData c name1 tvs cons1 ds p locn1) + chooser_TyData + +selTys ts1@(TySynonym name1 tvs expand1 pragmas1 locn1) + ts2@(TySynonym name2 _ expand2 pragmas2 locn2) + = selByBetterName "type synonym" + name1 pragmas1 locn1 ts1 + name2 pragmas2 locn2 ts2 + (\ p -> TySynonym name1 tvs expand1 p locn1) + chooser_TySynonym +\end{code} + +If only one is ``abstract'' (no condecls), we take the other. + +Next, we check that they don't have differing lists of data +constructors (what a disaster if those get through...); then we do a +similar thing using pragmatic info. + +\begin{code} +chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _) + pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _) + = let + td1_abstract = null cons1 + td2_abstract = null cons2 + + choose_by_pragmas = sub_chooser pragmas1 pragmas2 + in + if td1_abstract && td2_abstract then + choose_by_pragmas + + else if td1_abstract then + returnRn12 td2 + + else if td2_abstract then + returnRn12 td1 + + else if not (eqConDecls cons1 cons2) then + report_dup "algebraic datatype (mismatched data constuctors)" + name1 locn1 name2 locn2 td1 + else + sub_chooser pragmas1 pragmas2 + where + sub_chooser (DataPragmas [] []) b = returnRn12 (wout b) + sub_chooser a (DataPragmas [] []) = returnRn12 (wout a) + sub_chooser a@(DataPragmas cons1 specs1) (DataPragmas cons2 specs2) + = if not (eqConDecls cons1 cons2) then + pprTrace "Mismatched info in DATA pragmas:\n" + (ppAbove (ppr PprDebug cons1) (ppr PprDebug cons2)) ( + returnRn12 (wout (DataPragmas [] [])) + ) + else if not (eq_data_specs specs1 specs2) then + pprTrace "Mismatched specialisation info in DATA pragmas:\n" + (ppAbove (ppr_data_specs specs1) (ppr_data_specs specs2)) ( + returnRn12 (wout (DataPragmas [] [])) + ) + else + returnRn12 (wout a) -- same, pick one + + -- ToDo: Should we use selByBetterName ??? + -- ToDo: Report errors properly and recover quietly ??? + + eq_data_specs [] [] = True + eq_data_specs (spec1:specs1) (spec2:specs2) + = eq_spec spec1 spec2 && eq_data_specs specs1 specs2 + eq_data_specs _ _ = False + + ppr_data_specs specs + = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [ + ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack] + | ty_maybes <- specs ]] + + pp_the_list [p] = p + pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps) + + pp_maybe Nothing = pp_NONE + pp_maybe (Just ty) = pprParendMonoType PprDebug ty + + pp_NONE = ppStr "_N_" +\end{code} + +Sort of similar deal on synonyms: this is the time to check that the +expansions are really the same; otherwise, we use the pragmas. + +\begin{code} +chooser_TySynonym wout pragmas1 locn1 ts1@(TySynonym name1 _ expand1 _ _) + pragmas2 locn2 ts2@(TySynonym name2 _ expand2 _ _) + = if not (eqMonoType expand1 expand2) then + report_dup "type synonym" name1 locn1 name2 locn2 ts1 + else + sub_chooser pragmas1 pragmas2 + where + sub_chooser NoTypePragmas b = returnRn12 (wout b) + sub_chooser a NoTypePragmas = returnRn12 (wout a) + sub_chooser a _ = returnRn12 (wout a) -- same, just pick one +\end{code} + +%************************************************************************ +%* * +\subsection[DataTypeSigs-Rename2]{Functions for @DataTypeSigs@} +%* * +%************************************************************************ + +\begin{code} +cmpTySigs :: ProtoNameDataTypeSig -> ProtoNameDataTypeSig -> TAG_ + +cmpTySigs (AbstractTypeSig n1 _) (AbstractTypeSig n2 _) + = cmpProtoName n1 n2 +cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _) + = case cmpProtoName n1 n2 of + EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed + other -> other +cmpTySigs (AbstractTypeSig n1 _) (SpecDataSig n2 _ _) + = LT_ +cmpTySigs (SpecDataSig n1 _ _) (AbstractTypeSig n2 _) + = GT_ + +selTySigs :: ProtoNameDataTypeSig + -> ProtoNameDataTypeSig + -> Rn12M ProtoNameDataTypeSig + +selTySigs s1@(AbstractTypeSig n1 locn1) s2@(AbstractTypeSig n2 locn2) + = selByBetterName "ABSTRACT user-pragma" + n1 bottom locn1 s1 + n2 bottom locn2 s2 + bottom bottom + where + bottom = panic "Rename2:selTySigs:AbstractTypeSig" + +selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2) + = selByBetterName "ABSTRACT user-pragma" + n1 bottom locn1 s1 + n2 bottom locn2 s2 + bottom bottom + where + bottom = panic "Rename2:selTySigs:SpecDataSig" +\end{code} + +%************************************************************************ +%* * +\subsection[ClassDecl-Rename2]{Functions for @ClassDecls@} +%* * +%************************************************************************ + +\begin{code} +cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_ + +cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _) + = cmpProtoName n1 n2 + +selClass :: ProtoNameClassDecl -> ProtoNameClassDecl + -> Rn12M ProtoNameClassDecl + +selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1) + cd2@(ClassDecl _ n2 _ _ _ pragmas2 locn2) + = selByBetterName "class" + n1 pragmas1 locn1 cd1 + n2 pragmas2 locn2 cd2 + (\ p -> ClassDecl ctxt n1 tv sigs bs p locn1) + chooser_Class +\end{code} + +\begin{code} +chooser_Class wout NoClassPragmas _ _ b _ _ = returnRn12 (wout b) +chooser_Class wout a _ _ NoClassPragmas _ _ = returnRn12 (wout a) + +chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _ + = if length gs1 /= length gs2 then -- urgh + returnRn12 (wout NoClassPragmas) + else + recoverQuietlyRn12 [{-no gen prags-}] ( + zipWithRn12 choose_prag gs1 gs2 + ) `thenRn12` \ new_gprags -> + returnRn12 (wout ( + if null new_gprags then + pprTrace "tossed all SuperDictPragmas (rename2):" + (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2)) + NoClassPragmas + else + SuperDictPragmas new_gprags + )) + where + choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2 +\end{code} + +%************************************************************************ +%* * +\subsection[InstDecls-Rename2]{Functions for @InstDecls@} +%* * +%************************************************************************ + +\begin{code} +cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_ + +cmpInst (InstDecl _ c1 ty1 _ _ _ _ _ _ _) (InstDecl _ c2 ty2 _ _ _ _ _ _ _) + = case cmpProtoName c1 c2 of + EQ_ -> cmpInstanceTypes ty1 ty2 + other -> other +\end{code} + +Select the instance declaration from the module (rather than an +interface), if it exists. + +\begin{code} +selInst :: ProtoNameInstDecl -> ProtoNameInstDecl + -> Rn12M ProtoNameInstDecl + +selInst i1@(InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 uprags pragmas1 locn1) + i2@(InstDecl _ _ _ _ from_here2 orig_mod2 infor_mod2 _ pragmas2 locn2) + = let + have_orig_mod1 = not (_NULL_ orig_mod1) + have_orig_mod2 = not (_NULL_ orig_mod2) + + choose_no1 = returnRn12 i1 + choose_no2 = returnRn12 i2 + in + -- generally: try to keep the locally-defined instance decl + + if from_here1 && from_here2 then + -- If they are both from this module, don't throw either away, + -- otherwise we silently discard erroneous duplicates + trace ("selInst: duplicate instance in this module (ToDo: msg!)") + choose_no1 + + else if from_here1 then + if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then + trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)") + choose_no1 + else + choose_no1 + + else if from_here2 then + if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then + trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)") + choose_no2 + else + choose_no2 + + else -- it's definitely an imported instance; + -- first, a quick sanity check... + if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then + trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)") + choose_no2 -- arbitrary + else + -- now we *cheat*: so we can use the "informing module" stuff + -- in "selByBetterName", we *make up* some ProtoNames for + -- these instance decls + let + ii = SLIT("!*INSTANCE*!") + n1 = Imp orig_mod1 ii [infor_mod1] ii + n2 = Imp orig_mod2 ii [infor_mod2] ii + in + selByBetterName "instance" + n1 pragmas1 locn1 i1 + n2 pragmas2 locn2 i2 + (\ p -> InstDecl ctxt c ty bs from_here1 orig_mod1 infor_mod1 + [{-none-}] p locn1) + chooser_Inst +\end{code} + +\begin{code} +chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2 + = chk_pragmas iprags1 iprags2 + where + -- easy cases: + chk_pragmas NoInstancePragmas b = returnRn12 (wout b) + chk_pragmas a NoInstancePragmas = returnRn12 (wout a) + + -- SimpleInstance pragmas meet: choose by GenPragmas + chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2) + = recoverQuietlyRn12 NoGenPragmas ( + selGenPragmas gprags1 loc1 gprags2 loc2 + ) `thenRn12` \ new_prags -> + returnRn12 (wout ( + case new_prags of + NoGenPragmas -> NoInstancePragmas -- bottled out + _ -> SimpleInstancePragma new_prags + )) + + -- SimpleInstance pragma meets anything else... take the "else" + chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b) + chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a) + + chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2) + = recoverQuietlyRn12 NoGenPragmas ( + selGenPragmas gp1 loc1 gp2 loc2 + ) `thenRn12` \ dfun_prags -> + + recoverQuietlyRn12 [] ( + selNamePragmaPairs prs1 loc1 prs2 loc2 + ) `thenRn12` \ new_pairs -> + + returnRn12 (wout ( + if null new_pairs then -- bottled out + case dfun_prags of + NoGenPragmas -> NoInstancePragmas -- doubly bottled out + _ -> SimpleInstancePragma dfun_prags + else + ConstantInstancePragma dfun_prags new_pairs + )) + + -- SpecialisedInstancePragmas: choose by gens, then specialisations + chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _) + = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a)) + + chk_pragmas other1 other2 -- oops, bad mismatch + = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg +\end{code} + +%************************************************************************ +%* * +\subsection[SpecInstSigs-Rename2]{Functions for @AbstractTypeSigs@} +%* * +%************************************************************************ + +We don't make any effort to look for duplicate ``SPECIALIZE instance'' +pragmas. (Later??) + +We do this by make \tr{cmp*} always return \tr{LT_}---then there's +nothing for \tr{sel*} to do! + +\begin{code} +cmpSpecInstSigs + :: ProtoNameSpecialisedInstanceSig -> ProtoNameSpecialisedInstanceSig -> TAG_ +selSpecInstSigs :: ProtoNameSpecialisedInstanceSig + -> ProtoNameSpecialisedInstanceSig + -> Rn12M ProtoNameSpecialisedInstanceSig + +cmpSpecInstSigs a b = LT_ +selSpecInstSigs a b = panic "Rename2:selSpecInstSigs" +\end{code} + +%************************************************************************ +%* * +\subsection{Functions for SigDecls} +%* * +%************************************************************************ + +These \tr{*Sig} functions only operate on things from interfaces, so +we don't have to worry about user-pragmas and other such junk. + +\begin{code} +cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_ + +cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2 + +-- avoid BUG (ToDo) +cmpSig _ _ = case (panic "cmpSig (rename2)") of { s -> -- should never happen + cmpSig s s } + +selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig + +selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2) + = selByBetterName "type signature" + n1 pragmas1 locn1 s1 + n2 pragmas2 locn2 s2 + (\ p -> Sig n1 ty p locn1) -- w/out its pragmas + chooser_Sig +\end{code} + +\begin{code} +chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _) + = case (cmpPolyType cmpProtoName ty1 ty2) of + EQ_ -> + recoverQuietlyRn12 NoGenPragmas ( + selGenPragmas g1 l1 g2 l2 + ) `thenRn12` \ new_prags -> + returnRn12 (wout_prags new_prags) + _ -> report_dup "signature" n1 l1 n2 l2 s1 +\end{code} + +%************************************************************************ +%* * +\subsection{Help functions: selecting based on pragmas} +%* * +%************************************************************************ + +\begin{code} +selGenPragmas + :: ProtoNameGenPragmas -> SrcLoc + -> ProtoNameGenPragmas -> SrcLoc + -> Rn12M ProtoNameGenPragmas + +selGenPragmas NoGenPragmas _ b _ = returnRn12 b +selGenPragmas a _ NoGenPragmas _ = returnRn12 a + +selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1 + g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2 + + = sel_arity arity1 arity2 `thenRn12` \ arity -> + sel_upd upd1 upd2 `thenRn12` \ upd -> + sel_def def1 def2 `thenRn12` \ def -> + sel_strict strict1 strict2 `thenRn12` \ strict -> + sel_unfold unfold1 unfold2 `thenRn12` \ unfold -> + sel_specs specs1 specs2 `thenRn12` \ specs -> + returnRn12 (GenPragmas arity upd def strict unfold specs) + where + sel_arity Nothing Nothing = returnRn12 Nothing + sel_arity a@(Just a1) (Just a2) = if a1 == a2 + then returnRn12 a + else pRAGMA_ERROR "arity pragmas" a + sel_arity a _ = pRAGMA_ERROR "arity pragmas" a + + ------- + sel_upd Nothing Nothing = returnRn12 Nothing + sel_upd a@(Just u1) (Just u2) = if u1 == u2 + then returnRn12 a + else pRAGMA_ERROR "update pragmas" a + sel_upd a _ = pRAGMA_ERROR "update pragmas" a + + ------- + sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest + sel_def DoDeforest DoDeforest = returnRn12 DoDeforest + sel_def a _ = pRAGMA_ERROR "deforest pragmas" a + + ---------- + sel_unfold NoImpUnfolding b = returnRn12 b + sel_unfold a NoImpUnfolding = returnRn12 a + + sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2) + = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so) + then returnRn12 a + else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) ( + returnRn12 NoImpUnfolding + ) + + sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c) + = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a + + sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a + + ---------- + sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness + + sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2) + = if b1 /= b2 || i1 /= i2 + then pRAGMA_ERROR "strictness pragmas" a + else recoverQuietlyRn12 NoGenPragmas ( + selGenPragmas g1 locn1 g2 locn2 + ) `thenRn12` \ wrkr_prags -> + returnRn12 (ImpStrictness b1 i1 wrkr_prags) + + sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a + + --------- + sel_specs specs1 specs2 + = selSpecialisations specs1 locn1 specs2 locn2 +\end{code} + +\begin{code} +selNamePragmaPairs + :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc + -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc + -> Rn12M [(ProtoName, ProtoNameGenPragmas)] + +selNamePragmaPairs [] _ [] _ = returnRn12 [] +selNamePragmaPairs [] _ bs _ = returnRn12 bs +selNamePragmaPairs as _ [] _ = returnRn12 as + +selNamePragmaPairs ((name1, prags1) : pairs1) loc1 + ((name2, prags2) : pairs2) loc2 + + = if not (name1 `eqProtoName` name2) then + -- msg of any kind??? ToDo + pRAGMA_ERROR "named pragmas" pairs1 + else + selGenPragmas prags1 loc1 prags2 loc2 `thenRn12` \ new_prags -> + selNamePragmaPairs pairs1 loc1 pairs2 loc2 `thenRn12` \ rest -> + returnRn12 ( (name1, new_prags) : rest ) +\end{code} + +\begin{code} +selSpecialisations + :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc + -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc + -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] + +selSpecialisations [] _ [] _ = returnRn12 [] +selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo? +selSpecialisations as _ [] _ = returnRn12 as -- ditto + +selSpecialisations ((spec1, dicts1, prags1) : specs1) loc1 + ((spec2, dicts2, prags2) : specs2) loc2 + + = if not (eq_spec spec1 spec2) || dicts1 /= dicts2 then + -- msg of any kind??? ToDo + pRAGMA_ERROR "specialisation pragmas" specs1 + else + recoverQuietlyRn12 NoGenPragmas ( + selGenPragmas prags1 loc1 prags2 loc2 + ) `thenRn12` \ new_prags -> + selSpecialisations specs1 loc1 specs2 loc2 + `thenRn12` \ rest -> + returnRn12 ( (spec1, dicts1, new_prags) : rest ) + +eq_spec [] [] = True +eq_spec (Nothing:xs) (Nothing:ys) = eq_spec xs ys +eq_spec (Just t1:xs) (Just t2:ys) = eqMonoType t1 t2 && eq_spec xs ys +eq_spec _ _ = False +\end{code} + +%************************************************************************ +%* * +\subsection{Help functions: @uniquefy@ and @selByBetterName@} +%* * +%************************************************************************ + +\begin{code} +uniquefy :: FAST_STRING -- Module name + -> (a -> a -> TAG_) -- Comparison function + -> (a -> a -> Rn12M a) -- Selection function + -> [a] -- Things to be processed + -> Rn12M [a] -- Processed things + +uniquefy mod cmp sel things + = mapRn12 (check_group_consistency sel) grouped_things + where + grouped_things = equivClasses cmp things + + check_group_consistency :: (a -> a -> Rn12M a) -- Selection function + -> [a] -- things to be compared + -> Rn12M a + + check_group_consistency sel [] = panic "Rename2: runs produced an empty list" + check_group_consistency sel (thing:things) = foldrRn12 sel thing things +\end{code} + +@selByBetterName@: There are two ways one thing can have a ``better +name'' than another. + +First: Something with an @Unk@ name is declared in this module, so we +keep that, rather than something from an interface (with an @Imp@ +name, probably). + +Second: If we have two non-@Unk@ names, but one ``informant module'' +is also the {\em original} module for the entity, then we choose that +one. I.e., if one interface says, ``I am the module that created this +thing'' then we believe it and take that one. + +If we can't figure out which one to choose by the names, we use the +info provided to select based on the pragmas. + +LATER: but surely we have to worry about different-by-original-name +things which are same-by-local-name things---these should be reported +as errors. + +\begin{code} +selByBetterName :: String -- class/datatype/synonym (for error msg) + + -- 1st/2nd comparee name/pragmas + their things + -> ProtoName -> pragmas -> SrcLoc -> thing + -> ProtoName -> pragmas -> SrcLoc -> thing + + -- a thing without its pragmas + -> (pragmas -> thing) + + -- choose-by-pragma function + -> ((pragmas -> thing) -- thing minus its pragmas + -> pragmas -> SrcLoc -> thing -- comparee 1 + -> pragmas -> SrcLoc -> thing -- comparee 2 + -> Rn12M thing ) -- thing w/ its new pragmas + + -> Rn12M thing -- selected thing + +selByBetterName dup_msg + pn1 pragmas1 locn1 thing1 + pn2 pragmas2 locn2 thing2 + thing_wout_pragmas + chooser + = getModuleNameRn12 `thenRn12` \ mod_name -> + let + choose_thing1 = chk_eq (returnRn12 thing1) + choose_thing2 = chk_eq (returnRn12 thing2) + check_n_choose = chk_eq (chooser thing_wout_pragmas + pragmas1 locn1 thing1 + pragmas2 locn2 thing2) + + dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1 + in + case pn1 of + Unk _ -> case pn2 of + Unk _ -> dup_error + _ -> if orig_modules_clash mod_name pn2 + then dup_error + else choose_thing1 + + Prel _ -> case pn2 of + Unk _ -> if orig_modules_clash mod_name pn1 + then dup_error + else choose_thing2 + _ -> check_n_choose + + Imp om1 _ im1 _ -> -- we're gonna check `informant module' info... + case pn2 of + Unk _ -> if orig_modules_clash mod_name pn1 + then dup_error + else choose_thing2 + Prel _ -> check_n_choose + Imp om2 _ im2 _ + -> let + is_elem = isIn "selByBetterName" + + name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1) + name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2) + in + if name1_claims_orig + then if name2_claims_orig then check_n_choose else choose_thing1 + else if name2_claims_orig then choose_thing2 else check_n_choose + where + chk_eq if_OK + = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2 + then report_dup dup_msg pn1 locn1 pn2 locn2 thing1 + else if_OK + + orig_modules_clash this_module pn + = case (getOrigName pn) of { (that_module, _) -> + not (this_module == that_module) } + +report_dup dup_msg pn1 locn1 pn2 locn2 thing + = addErrRn12 err_msg `thenRn12` \ _ -> + returnRn12 thing + where + err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)] + +pRAGMA_ERROR :: String -> a -> Rn12M a +pRAGMA_ERROR msg x + = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ -> + returnRn12 x +\end{code} diff --git a/ghc/compiler/rename/Rename3.hi b/ghc/compiler/rename/Rename3.hi new file mode 100644 index 0000000..a89d682 --- /dev/null +++ b/ghc/compiler/rename/Rename3.hi @@ -0,0 +1,46 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Rename3 where +import AbsSyn(Module) +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import FiniteMap(FiniteMap) +import HsBinds(Binds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsPat(InPat, ProtoNamePat(..)) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(ExportFlag) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..)) +import RenameMonad3(Rn3M(..), initRn3) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import Unique(Unique) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type ProtoNamePat = InPat ProtoName +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type PreludeNameFun = _PackedString -> Labda Name +type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) +type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +rnModule3 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> [_PackedString] -> Module ProtoName (InPat ProtoName) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> ([(ProtoName, Name)], [(ProtoName, Name)], ProtoName -> Labda Name, ProtoName -> Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 121001 _N_ _S_ "U(LL)LU(LLLASASAAALLA)AAU(ALS)" {_A_ 5 _U_ 22211 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/rename/Rename3.lhs b/ghc/compiler/rename/Rename3.lhs new file mode 100644 index 0000000..845a214 --- /dev/null +++ b/ghc/compiler/rename/Rename3.lhs @@ -0,0 +1,559 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Rename-three]{Third of the renaming passes} + +The business of this pass is to: +\begin{itemize} +\item find all the things declared at top level, +\item assign uniques to them +\item return an association list mapping their @ProtoName@s to + freshly-minted @Names@ for them. +\end{itemize} + +No attempt is made to discover whether the same thing is declared +twice: that is up to the caller to sort out. + +\begin{code} +#include "HsVersions.h" + +module Rename3 ( + rnModule3, + initRn3, Rn3M(..), -- re-exported from monad + + -- for completeness + Module, Bag, ProtoNamePat(..), InPat, Maybe, Name, + ExportFlag, PprStyle, Pretty(..), PrettyRep, ProtoName, + PreludeNameFun(..), PreludeNameFuns(..), SplitUniqSupply + ) where + +import AbsSyn +import Bag -- lots of stuff +import Errors ( dupNamesErr, dupPreludeNameErr, + badExportNameErr, badImportNameErr, + Error(..) + ) +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import FiniteMap +import Maybes ( Maybe(..) ) +import Name ( Name(..) ) +import NameTypes ( fromPrelude, FullName ) +import ProtoName +import RenameAuxFuns ( mkGlobalNameFun, + GlobalNameFuns(..), GlobalNameFun(..), + PreludeNameFuns(..), PreludeNameFun(..) + ) +import RenameMonad3 +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} + +********************************************************* +* * +\subsection{Type declarations} +* * +********************************************************* + +\begin{code} +type BagAssoc = Bag (ProtoName, Name) -- Bag version +type NameSpaceAssoc = [(ProtoName, Name)] -- List version +\end{code} + + +********************************************************* +* * +\subsection{Main function: @rnModule3@} +* * +********************************************************* + +\begin{code} +rnModule3 :: PreludeNameFuns + -> [FAST_STRING] -- list of imported module names + -> ProtoNameModule + -> Rn3M ( NameSpaceAssoc, NameSpaceAssoc, + GlobalNameFun, GlobalNameFun, + Bag Error ) + +rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names + (Module mod_name exports imports _ ty_decls _ class_decls + inst_decls _ _ binds sigs _) + + = putInfoDownM3 {- ???pnfs -} mod_name exports ( + + doTyDecls3 ty_decls `thenRn3` \ (constrs, tycons) -> + doClassDecls3 class_decls `thenRn3` \ (ops, classes) -> + doBinds3 binds `thenRn3` \ val_binds -> + doIntSigs3 sigs `thenRn3` \ val_sigs -> + + let val_namespace = constrs `unionBags` ops `unionBags` val_binds + `unionBags` val_sigs + tc_namespace = tycons `unionBags` classes + + (var_alist, var_dup_errs) = deal_with_dups "variable" val_pnf (bagToList val_namespace) + (tc_alist, tc_dup_errs) = deal_with_dups "type or class" tc_pnf (bagToList tc_namespace) + v_gnf = mkGlobalNameFun mod_name val_pnf var_alist + tc_gnf = mkGlobalNameFun mod_name tc_pnf tc_alist + in + + verifyExports v_gnf tc_gnf (mod_name : imported_mod_names) exports + `thenRn3` \ export_errs -> + verifyImports v_gnf tc_gnf imports `thenRn3` \ import_errs -> + + returnRn3 ( var_alist, tc_alist, + v_gnf, tc_gnf, + var_dup_errs `unionBags` tc_dup_errs `unionBags` + export_errs `unionBags` import_errs + )) + where + deal_with_dups :: String -> PreludeNameFun -> NameSpaceAssoc + -> (NameSpaceAssoc, Bag Error) + + deal_with_dups kind_str pnf alist + = (goodies, + listToBag (map mk_dup_err dup_lists) `unionBags` + listToBag (map mk_prel_dup_err prel_dups) + ) + where + goodies :: [(ProtoName,Name)] --NameSpaceAssoc + dup_lists :: [[(ProtoName, Name)]] + + -- Find all the names which are defined twice. + -- By "name" here, we mean "string"; that is, we are looking + -- for places where two strings are bound to different Names + -- in the top-level scope of this module. + + (singles, dup_lists) = removeDups cmp alist + -- We want to compare their *local* names; the removeDups thing + -- is checking for whether two objects have the same local name. + cmp (a, _) (b, _) = cmpByLocalName a b + + -- Anything in alist with a Unk name is defined right here in + -- this module; hence, it should not be a prelude name. We + -- need to check this separately, because the prelude is + -- imported only implicitly, via the PrelNameFuns argument + + (goodies, prel_dups) = if fromPrelude mod_name then + (singles, []) -- Compiling the prelude, so ignore this check + else + partition local_def_of_prelude_thing singles + + local_def_of_prelude_thing (Unk s, _) + = case pnf s of + Just _ -> False -- Eek! It's a prelude name + Nothing -> True -- It isn't; all is ok + local_def_of_prelude_thing other = True + + mk_dup_err :: [(ProtoName, Name)] -> Error + mk_dup_err dups_of_name + = let + dup_pnames_w_src_loc = [ (pn, getSrcLoc name) | (pn,name) <- dups_of_name ] + in + dupNamesErr kind_str dup_pnames_w_src_loc + + -- This module defines a prelude thing + mk_prel_dup_err :: (ProtoName, Name) -> Error + mk_prel_dup_err (pn, name) + = dupPreludeNameErr kind_str (pn, getSrcLoc name) +\end{code} + +********************************************************* +* * +\subsection{Type and class declarations} +* * +********************************************************* + +\begin{code} +doTyDecls3 :: [ProtoNameTyDecl] -> Rn3M (BagAssoc, BagAssoc) + +doTyDecls3 [] = returnRn3 (emptyBag, emptyBag) + +doTyDecls3 (tyd:tyds) + = andRn3 combiner (do_decl tyd) (doTyDecls3 tyds) + where + combiner (cons1, tycons1) (cons2, tycons2) + = (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2) + + do_decl (TyData context tycon tyvars condecls deriv pragmas src_loc) + = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing + `thenRn3` \ (uniq, tycon_name) -> + let + exp_flag = getExportFlag tycon_name + -- we want to force all data cons to have the very + -- same export flag as their type constructor + in + doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons -> + do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_cons -> + returnRn3 (data_cons `unionBags` pragma_data_cons, + unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars) + True -- indicates @data@ tycon + [ c | (_,c) <- bagToList data_cons ])) + + + do_decl (TySynonym tycon tyvars monoty pragmas src_loc) + = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing + `thenRn3` \ (uniq, tycon_name) -> + returnRn3 (emptyBag, + unitBag (tycon, OtherTyCon uniq tycon_name (length tyvars) False bottom)) + -- False indicates @type@ tycon + where + bottom = panic "do_decl: data cons on synonym?" + + do_data_pragmas exp_flag (DataPragmas con_decls specs) + = doConDecls3 True{-invisibles-} exp_flag con_decls +\end{code} + +\begin{code} +doConDecls3 :: Bool -- True <=> mk invisible FullNames + -> ExportFlag -- Export flag of the TyCon; we want + -- to force its use. + -> [ProtoNameConDecl] + -> Rn3M BagAssoc + +doConDecls3 _ _ [] = returnRn3 emptyBag + +doConDecls3 want_invisibles exp_flag (cd:cds) + = andRn3 unionBags (do_decl cd) (doConDecls3 want_invisibles exp_flag cds) + where + mk_name = if want_invisibles then newInvisibleNameM3 else newFullNameM3 + + do_decl (ConDecl con tys src_loc) + = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) -> + returnRn3 (unitBag (con, OtherTopId uniq con_name)) +\end{code} + + +@doClassDecls3@ uses the `name function' to map local class names into +original names, calling @doClassOps3@ to do the same for the +class operations. @doClassDecls3@ is used to process module +class declarations. + +\begin{code} +doClassDecls3 :: [ProtoNameClassDecl] -> Rn3M (BagAssoc, BagAssoc) + +doClassDecls3 [] = returnRn3 (emptyBag, emptyBag) + +doClassDecls3 (cd:cds) + = andRn3 combiner (do_decl cd) (doClassDecls3 cds) + where + combiner (ops1, classes1) (ops2, classes2) + = (ops1 `unionBags` ops2, classes1 `unionBags` classes2) + + do_decl (ClassDecl context cname@(Prel c) tyvar sigs defaults pragmas src_loc) + = doClassOps3 c 1 sigs `thenRn3` \ (_, ops) -> + returnRn3 (ops, unitBag (cname, c)) + + do_decl (ClassDecl context cname tyvar sigs defaults pragmas src_loc) + = newFullNameM3 cname src_loc True{-tycon-ish-} Nothing + `thenRn3` \ (uniq, class_name) -> + fixRn3 ( \ ~(clas_ops,_) -> + let + class_Name = OtherClass uniq class_name + [ o | (_,o) <- bagToList clas_ops ] + in + doClassOps3 class_Name 1 sigs `thenRn3` \ (_, ops) -> + returnRn3 (ops, class_Name) + ) `thenRn3` \ (ops, class_Name) -> + + returnRn3 (ops, unitBag (cname, class_Name)) +\end{code} + +We stitch on a class-op tag to each class operation. They are guaranteed +to be done in left-to-right order. + +\begin{code} +doClassOps3 :: Name{-class-} -> Int -> [ProtoNameSig] -> Rn3M (Int, BagAssoc) + +doClassOps3 clas tag [] = returnRn3 (tag, emptyBag) + +doClassOps3 clas tag (sig:rest) + = do_op sig `thenRn3` \ (tag1, bag1) -> + doClassOps3 clas tag1 rest `thenRn3` \ (tagr, bagr) -> + returnRn3 (tagr, bag1 `unionBags` bagr) + where + do_op (ClassOpSig op ty pragma src_loc) + = newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) -> + let + op_name = ClassOpName uniq clas (get_str op) tag + in + returnRn3 (tag+1, unitBag (op, op_name)) + where + -- A rather yukky function to get the original name out of a class operation. + get_str :: ProtoName -> FAST_STRING + get_str (Unk s) = s + get_str (Imp _ d _ _) = d +\end{code} + +Remember, interface signatures don't have user-pragmas, etc., in them. +\begin{code} +doIntSigs3 :: [ProtoNameSig] -> Rn3M BagAssoc + +doIntSigs3 [] = returnRn3 emptyBag + +doIntSigs3 (s:ss) + = andRn3 unionBags (do_sig s) (doIntSigs3 ss) + where + do_sig (Sig v ty pragma src_loc) + = newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing + `thenRn3` \ (uniq, v_fname) -> + returnRn3 (unitBag (v, OtherTopId uniq v_fname)) +\end{code} + +********************************************************* +* * +\subsection{Bindings} +* * +********************************************************* + +\begin{code} +doBinds3 :: ProtoNameBinds -> Rn3M BagAssoc + +doBinds3 EmptyBinds = returnRn3 emptyBag + +doBinds3 (ThenBinds binds1 binds2) + = andRn3 unionBags (doBinds3 binds1) (doBinds3 binds2) + +doBinds3 (SingleBind bind) = doBind3 bind + +doBinds3 (BindWith bind sigs) = doBind3 bind +\end{code} + +\begin{code} +doBind3 :: ProtoNameBind -> Rn3M BagAssoc +doBind3 EmptyBind = returnRn3 emptyBag +doBind3 (NonRecBind mbind) = doMBinds3 mbind +doBind3 (RecBind mbind) = doMBinds3 mbind + +doMBinds3 :: ProtoNameMonoBinds -> Rn3M BagAssoc + +doMBinds3 EmptyMonoBinds = returnRn3 emptyBag +doMBinds3 (PatMonoBind pat grhss_and_binds locn) = doPat3 locn pat +doMBinds3 (FunMonoBind p_name _ locn) = doTopLevName locn p_name + +doMBinds3 (AndMonoBinds mbinds1 mbinds2) + = andRn3 unionBags (doMBinds3 mbinds1) (doMBinds3 mbinds2) +\end{code} + +Fold over a list of patterns: +\begin{code} +doPats3 locn [] = returnRn3 emptyBag +doPats3 locn (pat:pats) + = andRn3 unionBags (doPat3 locn pat) (doPats3 locn pats) +\end{code} + +\begin{code} +doPat3 :: SrcLoc -> ProtoNamePat -> Rn3M BagAssoc + +doPat3 locn WildPatIn = returnRn3 emptyBag +doPat3 locn (LitPatIn _) = returnRn3 emptyBag +doPat3 locn (LazyPatIn pat) = doPat3 locn pat +doPat3 locn (VarPatIn n) = doTopLevName locn n +doPat3 locn (ListPatIn pats) = doPats3 locn pats +doPat3 locn (TuplePatIn pats) = doPats3 locn pats +doPat3 locn (NPlusKPatIn n _) = doTopLevName locn n + +doPat3 locn (AsPatIn p_name pat) + = andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat) + +doPat3 locn (ConPatIn name pats) = doPats3 locn pats + +doPat3 locn (ConOpPatIn pat1 name pat2) + = andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2) + +#ifdef DPH +doPat3 locn (ProcessorPatIn pats pat) + = andRn3 unionBags (doPats3 locn pats) (doPat3 locn pat) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +doTopLevName :: SrcLoc -> ProtoName -> Rn3M BagAssoc + +doTopLevName locn pn + = newFullNameM3 pn locn False{-un-tycon-ish-} Nothing `thenRn3` \ (uniq, name) -> + returnRn3 (unitBag (pn, OtherTopId uniq name)) +\end{code} + +Have to check that export/imports lists aren't too drug-crazed. + +\begin{code} +verifyExports :: GlobalNameFun -> GlobalNameFun + -> [FAST_STRING] -- module names that might appear + -- in an export list; includes the + -- name of this module + -> [IE] -- export list + -> Rn3M (Bag Error) + +verifyExports v_gnf tc_gnf imported_mod_names exports + = mapRn3 verify exports `thenRn3` \ errs -> + chk_exp_dups exports `thenRn3` \ dup_errs -> + returnRn3 (unionManyBags (errs ++ dup_errs)) + where + present nf str = nf (Unk str) + + ok = returnRn3 emptyBag + naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg)) + undef_name nm = naughty nm "is not defined." + dup_name (nm:_)= naughty nm "occurs more than once." + + ---------------- + chk_exp_dups exports + = let + export_strs = [ nm | (nm, _) <- fst (getRawIEStrings exports) ] + (_, dup_lists) = removeDups _CMP_STRING_ export_strs + in + mapRn3 dup_name dup_lists + + ---------------- the more serious checking + verify (IEVar v) + = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok } + + verify (IEModuleContents mod) + = if not (mod `is_elem` imported_mod_names) then undef_name mod else ok + where + is_elem = isIn "verifyExports" + + verify (IEThingAbs tc) + = case (present tc_gnf tc) of + Nothing -> undef_name tc + Just nm -> case nm of + PreludeTyCon _ _ _ False{-syn-} + -> naughty tc "must be exported with a `(..)' -- it's a Prelude synonym." + OtherTyCon _ _ _ False{-syn-} _ + -> naughty tc "must be exported with a `(..)' -- it's a synonym." + + PreludeClass _ _ + -> naughty tc "cannot be exported \"abstractly\" (it's a Prelude class)." + OtherClass _ _ _ + -> naughty tc "cannot be exported \"abstractly\" (it's a class)." + _ -> ok + + verify (IEThingAll tc) + = case (present tc_gnf tc) of + Nothing -> undef_name tc + Just nm -> case nm of + OtherTyCon _ _ _ True{-data-} [{-no cons-}] + -> naughty tc "can't be exported with a `(..)' -- it was imported abstractly." + _ -> ok + + verify (IEConWithCons tc cs) + = case (present tc_gnf tc) of + Nothing -> undef_name tc + Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs -> + returnRn3 (unionManyBags errs) + -- ToDo: turgid checking which we don't care about (WDP 94/10) + + verify (IEClsWithOps c ms) + = case (present tc_gnf c) of + Nothing -> undef_name c + Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs -> + returnRn3 (unionManyBags errs) + -- ToDo: turgid checking which we don't care about (WDP 94/10) +\end{code} + +Note: we're not too particular about whether something mentioned in an +import list is in {\em that} interface... (ToDo? Probably not.) + +\begin{code} +verifyImports :: GlobalNameFun -> GlobalNameFun + -> [ProtoNameImportedInterface] + -> Rn3M (Bag Error) + +verifyImports v_gnf tc_gnf imports + = mapRn3 chk_one (map collect imports) `thenRn3` \ errs -> + returnRn3 (unionManyBags errs) + where + -- collect: name/locn, import list, renamings list + + collect (ImportAll iff renamings) + = (iface iff, [], [], renamings) + collect (ImportSome iff imp_list renamings) + = (iface iff, imp_list, [], renamings) + collect (ImportButHide iff hide_list renamings) + = (iface iff, [], hide_list, renamings) + + ------------ + iface (MkInterface name _ _ _ _ _ _ locn) = (name, locn) + + ------------ + chk_one :: ((FAST_STRING, SrcLoc), [IE], [IE], [Renaming]) + -> Rn3M (Bag Error) + + chk_one ((mod_name, locn), import_list, hide_list, renamings) + = mapRn3 verify import_list `thenRn3` \ errs1 -> + chk_imp_dups import_list `thenRn3` \ dup_errs -> + -- ToDo: we could check the hiding list more carefully + chk_imp_dups hide_list `thenRn3` \ dup_errs2 -> + mapRn3 chk_rn renamings `thenRn3` \ errs2 -> + returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2 ++ errs2)) + where + present nf str = nf (Unk (rename_it str)) + + rename_it str + = case [ too | (MkRenaming from too) <- renamings, str == from ] of + [] -> str + (x:_) -> x + + ok = returnRn3 emptyBag + naughty nm msg = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn)) + undef_name nm = naughty nm "is not defined." + undef_rn_name n r = naughty n ("is not defined (renamed to `"++ _UNPK_ r ++"').") + dup_name (nm:_) = naughty nm "occurs more than once." + + ---------------- + chk_imp_dups imports + = let + import_strs = [ nm | (nm, _) <- fst (getRawIEStrings imports) ] + (_, dup_lists) = removeDups _CMP_STRING_ import_strs + in + mapRn3 dup_name dup_lists + + ---------------- + chk_rn (MkRenaming from too) -- Note: "present" will rename + = case (present v_gnf from) of -- the "from" to the "too"... + Just _ -> ok + Nothing -> case (present tc_gnf from) of + Just _ -> ok + Nothing -> undef_rn_name from too + + ---------------- + verify (IEVar v) + = case (present v_gnf v) of { Nothing -> undef_name v; _ -> ok } + + verify (IEThingAbs tc) + = case (present tc_gnf tc) of + Nothing -> undef_name tc + Just nm -> case nm of + PreludeTyCon _ _ _ False{-syn-} + -> naughty tc "must be imported with a `(..)' -- it's a Prelude synonym." + OtherTyCon _ _ _ False{-syn-} _ + -> naughty tc "must be imported with a `(..)' -- it's a synonym." + PreludeClass _ _ + -> naughty tc "cannot be imported \"abstractly\" (it's a Prelude class)." + OtherClass _ _ _ + -> naughty tc "cannot be imported \"abstractly\" (it's a class)." + _ -> ok + + verify (IEThingAll tc) + = case (present tc_gnf tc) of + Nothing -> undef_name tc + Just nm -> case nm of + OtherTyCon _ _ _ True{-data-} [{-no cons-}] + -> naughty tc "can't be imported with a `(..)' -- the interface says it's abstract." + _ -> ok + + verify (IEConWithCons tc cs) + = case (present tc_gnf tc) of + Nothing -> undef_name tc + Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs -> + returnRn3 (unionManyBags errs) + -- One could add a great wad of tedious checking + -- here, but I am too lazy to do so. WDP 94/10 + + verify (IEClsWithOps c ms) + = case (present tc_gnf c) of + Nothing -> undef_name c + Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs -> + returnRn3 (unionManyBags errs) + -- Ditto about tedious checking. WDP 94/10 +\end{code} diff --git a/ghc/compiler/rename/Rename4.hi b/ghc/compiler/rename/Rename4.hi new file mode 100644 index 0000000..b456e57 --- /dev/null +++ b/ghc/compiler/rename/Rename4.hi @@ -0,0 +1,55 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Rename4 where +import AbsSyn(Module) +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import FiniteMap(FiniteMap) +import HsBinds(Binds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsPat(InPat, ProtoNamePat(..), RenamedPat(..)) +import HsPragmas(GenPragmas) +import HsTypes(MonoType, PolyType) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(GlobalNameFun(..)) +import RenameMonad4(Rn4M(..), TyVarNamesEnv(..), initRn4) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import Unique(Unique) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type ProtoNamePat = InPat ProtoName +type RenamedPat = InPat Name +data PolyType a {-# GHC_PRAGMA UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type GlobalNameFun = ProtoName -> Labda Name +type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) +type TyVarNamesEnv = [(ProtoName, Name)] +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLSL" _N_ _N_ #-} +rnGenPragmas4 :: GenPragmas ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GenPragmas Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} +rnModule4 :: Module ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Module Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1222210 _N_ _S_ "U(LLASSSSSSSSSL)LLLLU(ALS)A" {_A_ 6 _U_ 122221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rnPolyType4 :: Bool -> Bool -> [(ProtoName, Name)] -> PolyType ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (PolyType Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2221222222 _N_ _S_ "LLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/rename/Rename4.lhs b/ghc/compiler/rename/Rename4.lhs new file mode 100644 index 0000000..746078b --- /dev/null +++ b/ghc/compiler/rename/Rename4.lhs @@ -0,0 +1,829 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Rename4]{Fourth of the renaming passes} + +\begin{code} +#include "HsVersions.h" + +module Rename4 ( + rnModule4, rnPolyType4, rnGenPragmas4, + + initRn4, Rn4M(..), TyVarNamesEnv(..), -- re-exported from the monad + + -- for completeness + + Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), + PolyType, Maybe, Name, ProtoName, GlobalNameFun(..), + SrcLoc, SplitUniqSupply, Error(..), PprStyle, + Pretty(..), PrettyRep + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import AbsSyn +import AbsUniType ( derivableClassKeys ) +import Errors +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Maybes ( catMaybes, Maybe(..) ) +import ProtoName ( eqProtoName, elemProtoNames ) +import RenameBinds4 ( rnTopBinds4, rnMethodBinds4 ) +import RenameMonad4 +import Util +\end{code} + +This pass `renames' the module+imported info, simultaneously +performing dependency analysis. It also does the following error +checks: +\begin{enumerate} +\item +Checks that tyvars are used properly. This includes checking +for undefined tyvars, and tyvars in contexts that are ambiguous. +\item +Checks that local variables are defined. +\end{enumerate} + +\begin{code} +rnModule4 :: ProtoNameModule -> Rn4M RenamedModule + +rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs + class_decls inst_decls specinst_sigs defaults + binds int_sigs src_loc) + + = pushSrcLocRn4 src_loc ( + + mapRn4 rnTyDecl4 ty_decls `thenRn4` \ new_ty_decls -> + + mapRn4 rnTySig4 absty_sigs `thenRn4` \ new_absty_sigs -> + + mapRn4 rnClassDecl4 class_decls `thenRn4` \ new_class_decls -> + + mapRn4 rnInstDecl4 inst_decls `thenRn4` \ new_inst_decls -> + + mapRn4 rnInstSpecSig4 specinst_sigs `thenRn4` \ new_specinst_sigs -> + + mapRn4 rnDefaultDecl4 defaults `thenRn4` \ new_defaults -> + + rnTopBinds4 binds `thenRn4` \ new_binds -> + + mapRn4 rnIntSig4 int_sigs `thenRn4` \ new_int_sigs -> + + rnFixes4 fixes `thenRn4` \ new_fixes -> + + returnRn4 (Module mod_name + exports [{-imports finally clobbered-}] new_fixes + new_ty_decls new_absty_sigs new_class_decls + new_inst_decls new_specinst_sigs new_defaults + new_binds new_int_sigs src_loc) + ) +\end{code} + + +%********************************************************* +%* * +\subsection{Type declarations} +%* * +%********************************************************* + +@rnTyDecl4@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its Name representation. In some cases (type signatures of +values), it is even necessary to go over the type first in order to +get the set of tyvars used by it, make an assoc list, and then go over +it again to rename the tyvars! However, we can also do some scoping +checks at the same time. + +\begin{code} +rnTyDecl4 :: ProtoNameTyDecl -> Rn4M RenamedTyDecl + +rnTyDecl4 (TyData context tycon tyvars condecls derivings pragmas src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon tycon `thenRn4` \ tycon' -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> + rnContext4 tv_env context `thenRn4` \ context' -> + rnConDecls4 tv_env False condecls `thenRn4` \ condecls' -> + mapRn4 (rn_deriv tycon' src_loc) derivings `thenRn4` \ derivings' -> + recoverQuietlyRn4 (DataPragmas [] []) ( + rnDataPragmas4 tv_env pragmas + ) `thenRn4` \ pragmas' -> + returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc) + ) + where + rn_deriv tycon2 locn deriv + = lookupClass deriv `thenRn4` \ clas_name -> + case clas_name of + PreludeClass key _ | key `is_elem` derivableClassKeys + -> returnRn4 clas_name + _ -> addErrRn4 (derivingNonStdClassErr tycon2 deriv locn) `thenRn4_` + returnRn4 clas_name + where + is_elem = isIn "rn_deriv" + +rnTyDecl4 (TySynonym name tyvars ty pragmas src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon name `thenRn4` \ name' -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> + rnMonoType4 False{-no invisible types-} tv_env ty + `thenRn4` \ ty' -> + returnRn4 (TySynonym name' tyvars' ty' pragmas src_loc) + ) +\end{code} + +@rnConDecls4@ uses the `global name function' to create a new +constructor in which local names have been replaced by their original +names, reporting any unknown names. + +\begin{code} +rnConDecls4 :: TyVarNamesEnv + -> Bool -- True <=> allowed to see invisible data-cons + -> [ProtoNameConDecl] + -> Rn4M [RenamedConDecl] + +rnConDecls4 tv_env invisibles_allowed con_decls + = mapRn4 rn_decl con_decls + where + lookup_fn + = if invisibles_allowed + then lookupValueEvenIfInvisible + else lookupValue + + rn_decl (ConDecl name tys src_loc) + = pushSrcLocRn4 src_loc ( + lookup_fn name `thenRn4` \ new_name -> + mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys + `thenRn4` \ new_tys -> + + returnRn4 (ConDecl new_name new_tys src_loc) + ) +\end{code} + +%********************************************************* +%* * +\subsection{ABSTRACT type-synonym pragmas} +%* * +%********************************************************* + +\begin{code} +rnTySig4 :: ProtoNameDataTypeSig + -> Rn4M RenamedDataTypeSig + +rnTySig4 (AbstractTypeSig tycon src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon tycon `thenRn4` \ tycon' -> + returnRn4 (AbstractTypeSig tycon' src_loc) + ) + +rnTySig4 (SpecDataSig tycon ty src_loc) + = pushSrcLocRn4 src_loc ( + let + tyvars = extractMonoTyNames eqProtoName ty + in + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> + lookupTyCon tycon `thenRn4` \ tycon' -> + rnMonoType4 False tv_env ty `thenRn4` \ ty' -> + returnRn4 (SpecDataSig tycon' ty' src_loc) + ) +\end{code} + +%********************************************************* +%* * +\subsection{Class declarations} +%* * +%********************************************************* + +@rnClassDecl4@ uses the `global name function' to create a new +class declaration in which local names have been replaced by their +original names, reporting any unknown names. + +\begin{code} +rnClassDecl4 :: ProtoNameClassDecl -> Rn4M RenamedClassDecl + +rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) + = pushSrcLocRn4 src_loc ( + mkTyVarNamesEnv src_loc [tyvar] `thenRn4` \ (tv_env, [tyvar']) -> + rnContext4 tv_env context `thenRn4` \ context' -> + lookupClass cname `thenRn4` \ cname' -> + mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' -> + rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' -> + recoverQuietlyRn4 NoClassPragmas ( + rnClassPragmas4 pragmas + ) `thenRn4` \ pragmas' -> + returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc) + ) + where + rn_op clas tv_env (ClassOpSig op ty pragma locn) + = pushSrcLocRn4 locn ( + lookupClassOp clas op `thenRn4` \ op_name -> + rnPolyType4 False True tv_env ty `thenRn4` \ new_ty -> + recoverQuietlyRn4 NoClassOpPragmas ( + rnClassOpPragmas4 pragma + ) `thenRn4` \ new_pragma -> + returnRn4 (ClassOpSig op_name new_ty new_pragma locn) + ) +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations} +%* * +%********************************************************* + + +@rnInstDecl4@ uses the `global name function' to create a new of +instance declaration in which local names have been replaced by their +original names, reporting any unknown names. + +\begin{code} +rnInstDecl4 :: ProtoNameInstDecl -> Rn4M RenamedInstDecl + +rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags pragmas src_loc) + = pushSrcLocRn4 src_loc ( + let tyvars = extractMonoTyNames eqProtoName ty in + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> + rnContext4 tv_env context `thenRn4` \ context' -> + lookupClass cname `thenRn4` \ cname' -> + rnMonoType4 False{-no invisibles-} tv_env ty + `thenRn4` \ ty' -> + rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' -> + mapRn4 rn_uprag uprags `thenRn4` \ new_uprags -> + recoverQuietlyRn4 NoInstancePragmas ( + rnInstancePragmas4 cname' tv_env pragmas + ) `thenRn4` \ new_pragmas -> + returnRn4 (InstDecl context' cname' ty' mbinds' + from_here modname imod new_uprags new_pragmas src_loc) + ) + where + rn_uprag (InlineSig var guide locn) + = pushSrcLocRn4 locn ( + lookupValue var `thenRn4` \ new_var -> + returnRn4 (InlineSig new_var guide locn) + ) + rn_uprag (DeforestSig var locn) + = pushSrcLocRn4 locn ( + lookupValue var `thenRn4` \ new_var -> + returnRn4 (DeforestSig new_var locn) + ) + rn_uprag (MagicUnfoldingSig var str locn) + = pushSrcLocRn4 locn ( + lookupValue var `thenRn4` \ new_var -> + returnRn4 (MagicUnfoldingSig new_var str locn) + ) +\end{code} + +%********************************************************* +%* * +\subsection{@SPECIALIZE instance@ user-pragmas} +%* * +%********************************************************* + +\begin{code} +rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig + -> Rn4M RenamedSpecialisedInstanceSig + +rnInstSpecSig4 (InstSpecSig clas ty src_loc) + = pushSrcLocRn4 src_loc ( + let tyvars = extractMonoTyNames eqProtoName ty in + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> + lookupClass clas `thenRn4` \ new_clas -> + rnMonoType4 False tv_env ty `thenRn4` \ new_ty -> + returnRn4 (InstSpecSig new_clas new_ty src_loc) + ) +\end{code} + +%********************************************************* +%* * +\subsection{Default declarations} +%* * +%********************************************************* + +@rnDefaultDecl4@ uses the `global name function' to create a new set +of default declarations in which local names have been replaced by +their original names, reporting any unknown names. + +\begin{code} +rnDefaultDecl4 :: ProtoNameDefaultDecl -> Rn4M RenamedDefaultDecl + +rnDefaultDecl4 (DefaultDecl tys src_loc) + = pushSrcLocRn4 src_loc ( + mapRn4 (rnMonoType4 False nullTyVarNamesEnv) tys `thenRn4` \ tys' -> + returnRn4 (DefaultDecl tys' src_loc) + ) +\end{code} + +%************************************************************************* +%* * +\subsection{Type signatures from interfaces} +%* * +%************************************************************************* + +Non-interface type signatures (which may include user-pragmas) are +handled with @Binds@. + +@ClassOpSigs@ are dealt with in class declarations. + +\begin{code} +rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig + +rnIntSig4 (Sig name ty pragma src_loc) + = pushSrcLocRn4 src_loc ( + lookupValue name `thenRn4` \ new_name -> + rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 pragma + ) `thenRn4` \ new_pragma -> + returnRn4 (Sig new_name new_ty new_pragma src_loc) + ) +\end{code} + +%************************************************************************* +%* * +\subsection{Fixity declarations} +%* * +%************************************************************************* + +\begin{code} +rnFixes4 :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl] + +rnFixes4 fixities + = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe -> + returnRn4 (catMaybes fixes_maybe) + where + rn_fixity (InfixL name i) + = lookupFixityOp name `thenRn4` \ res -> + returnRn4 ( + case res of + Just name2 -> Just (InfixL name2 i) + Nothing -> Nothing + ) + + rn_fixity (InfixR name i) + = lookupFixityOp name `thenRn4` \ res -> + returnRn4 ( + case res of + Just name2 -> Just (InfixR name2 i) + Nothing -> Nothing + ) + + rn_fixity (InfixN name i) + = lookupFixityOp name `thenRn4` \ res -> + returnRn4 ( + case res of + Just name2 -> Just (InfixN name2 i) + Nothing -> Nothing + ) +\end{code} + +%********************************************************* +%* * +\subsection{Support code to rename types} +%* * +%********************************************************* + +\begin{code} +rnPolyType4 :: Bool -- True <=> "invisible" tycons (in pragmas) allowed + -> Bool -- True <=> snaffle tyvars from ty and + -- stuff them in tyvar env; True for + -- signatures and things; False for type + -- synonym defns and things. + -> TyVarNamesEnv + -> ProtoNamePolyType + -> Rn4M RenamedPolyType + +rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (UnoverloadedTy ty) + = rn_poly_help invisibles_allowed snaffle_tyvars tv_env [] ty `thenRn4` \ (_, new_ty) -> + returnRn4 (UnoverloadedTy new_ty) + +rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (OverloadedTy ctxt ty) + = rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty `thenRn4` \ (new_ctxt, new_ty) -> + returnRn4 (OverloadedTy new_ctxt new_ty) + +rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (ForAllTy tvs ty) + = getSrcLocRn4 `thenRn4` \ src_loc -> + mkTyVarNamesEnv src_loc tvs `thenRn4` \ (tvenv2, new_tvs) -> + let + new_tvenv = catTyVarNamesEnvs tvenv2 tv_env + in + rnMonoType4 invisibles_allowed new_tvenv ty `thenRn4` \ new_ty -> + returnRn4 (ForAllTy new_tvs new_ty) + +------------ +rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty + = getSrcLocRn4 `thenRn4` \ src_loc -> + let + -- ToDo: this randomly-grabbing-tyvar names out + -- of the type seems a little weird to me + -- (WDP 94/11) + + new_tyvars + = extractMonoTyNames eqProtoName ty + `minus_list` domTyVarNamesEnv tv_env + in + mkTyVarNamesEnv src_loc new_tyvars `thenRn4` \ (tv_env2, _) -> + let + tv_env3 = if snaffle_tyvars + then catTyVarNamesEnvs tv_env2 tv_env + else tv_env -- leave it alone + in + rnContext4 tv_env3 ctxt `thenRn4` \ new_ctxt -> + rnMonoType4 invisibles_allowed tv_env3 ty + `thenRn4` \ new_ty -> + returnRn4 (new_ctxt, new_ty) + where + minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)] +\end{code} + +\begin{code} +rnMonoType4 :: Bool -- allowed to look at invisible tycons + -> TyVarNamesEnv + -> ProtoNameMonoType + -> Rn4M RenamedMonoType + +rnMonoType4 invisibles_allowed tv_env (MonoTyVar tyvar) + = lookupTyVarName tv_env tyvar `thenRn4` \ tyvar' -> + returnRn4 (MonoTyVar tyvar') + +rnMonoType4 invisibles_allowed tv_env (ListMonoTy ty) + = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (ListMonoTy ty') + +rnMonoType4 invisibles_allowed tv_env (FunMonoTy ty1 ty2) + = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1) + (rnMonoType4 invisibles_allowed tv_env ty2) + +rnMonoType4 invisibles_allowed tv_env (TupleMonoTy tys) + = mapRn4 (rnPolyType4 invisibles_allowed False tv_env) tys `thenRn4` \ tys' -> + returnRn4 (TupleMonoTy tys') + +rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys) + = let + lookup_fn = if invisibles_allowed + then lookupTyConEvenIfInvisible + else lookupTyCon + in + lookup_fn name `thenRn4` \ tycon_name' -> + mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' -> + returnRn4 (MonoTyCon tycon_name' tys') + +-- for unfoldings only: + +rnMonoType4 invisibles_allowed tv_env (MonoTyVarTemplate name) + = --pprTrace "rnMonoType4:MonoTyVarTemplate:" (ppAbove (ppr PprDebug name) (ppr PprDebug tv_env)) ( + lookupTyVarName tv_env name `thenRn4` \ new_name -> + returnRn4 (MonoTyVarTemplate new_name) + --) + +rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty) + = lookupClass clas `thenRn4` \ new_clas -> + rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ new_ty -> + returnRn4 (MonoDict new_clas new_ty) + +#ifdef DPH +rnMonoType4 invisibles_allowed tv_env (MonoTyProc tys ty) + = mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' -> + rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (MonoTyProc tys' ty') + +rnMonoType4 invisibles_allowed tv_env (MonoTyPod ty) + = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (MonoTyPod ty') +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext + +rnContext4 tv_env ctxt + = mapRn4 rn_ctxt ctxt + where + rn_ctxt (clas, tyvar) + = lookupClass clas `thenRn4` \ clas_name -> + lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name -> + returnRn4 (clas_name, tyvar_name) +\end{code} + +%********************************************************* +%* * +\subsection{Support code to rename various pragmas} +%* * +%********************************************************* + +\begin{code} +rnDataPragmas4 tv_env (DataPragmas cons specs) + = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons -> + mapRn4 types_n_spec specs `thenRn4` \ new_specs -> + returnRn4 (DataPragmas new_cons new_specs) + where + types_n_spec ty_maybes + = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes +\end{code} + +\begin{code} +rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas + +rnClassOpPragmas4 (ClassOpPragmas dsel defm) + = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel -> + recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm -> + returnRn4 (ClassOpPragmas new_dsel new_defm) +\end{code} + +\begin{code} +rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas + +rnClassPragmas4 (SuperDictPragmas sds) + = mapRn4 rnGenPragmas4 sds `thenRn4` \ new_sds -> + returnRn4 (SuperDictPragmas new_sds) +\end{code} + +NB: In various cases around here, we don't @recoverQuietlyRn4@ around +calls to @rnGenPragmas4@; not really worth it. + +\begin{code} +rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas + +rnInstancePragmas4 _ _ (SimpleInstancePragma dfun) + = rnGenPragmas4 dfun `thenRn4` \ new_dfun -> + returnRn4 (SimpleInstancePragma new_dfun) + +rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms) + = recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 dfun + ) `thenRn4` \ new_dfun -> + mapRn4 name_n_gen constms `thenRn4` \ new_constms -> + returnRn4 (ConstantInstancePragma new_dfun new_constms) + where + name_n_gen (op, gen) + = lookupClassOp clas op `thenRn4` \ new_op -> + rnGenPragmas4 gen `thenRn4` \ new_gen -> + returnRn4 (new_op, new_gen) + +rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs) + = recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 dfun + ) `thenRn4` \ new_dfun -> + mapRn4 types_n_spec specs `thenRn4` \ new_specs -> + returnRn4 (SpecialisedInstancePragma new_dfun new_specs) + where + types_n_spec (ty_maybes, dicts_to_ignore, inst) + = mapRn4 (rn_ty_maybe tv_env) ty_maybes `thenRn4` \ new_tys -> + rnInstancePragmas4 clas tv_env inst `thenRn4` \ new_inst -> + returnRn4 (new_tys, dicts_to_ignore, new_inst) +\end{code} + +And some general pragma stuff: (Not sure what, if any, of this would +benefit from a TyVarNamesEnv passed in.... [ToDo]) +\begin{code} +rnGenPragmas4 NoGenPragmas = returnRn4 NoGenPragmas + +rnGenPragmas4 (GenPragmas arity upd def strict unfold specs) + = recoverQuietlyRn4 NoImpUnfolding ( + rn_unfolding unfold + ) `thenRn4` \ new_unfold -> + rn_strictness strict `thenRn4` \ new_strict -> + recoverQuietlyRn4 [] ( + mapRn4 types_n_gen specs + ) `thenRn4` \ new_specs -> + returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs) + where + rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding + + rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str) + + rn_unfolding (ImpUnfolding guidance core) + = rn_core nullTyVarNamesEnv core `thenRn4` \ new_core -> + returnRn4 (ImpUnfolding guidance new_core) + + ------------ + rn_strictness NoImpStrictness = returnRn4 NoImpStrictness + + rn_strictness (ImpStrictness is_bot ww_info wrkr_info) + = recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 wrkr_info + ) `thenRn4` \ new_wrkr_info -> + returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info) + + ------------- + types_n_gen (ty_maybes, dicts_to_ignore, gen) + = mapRn4 (rn_ty_maybe no_env) ty_maybes `thenRn4` \ new_tys -> + recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 gen + ) `thenRn4` \ new_gen -> + returnRn4 (new_tys, dicts_to_ignore, new_gen) + where + no_env = nullTyVarNamesEnv + +------------ +rn_ty_maybe tv_env Nothing = returnRn4 Nothing + +rn_ty_maybe tv_env (Just ty) + = rnMonoType4 True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty -> + returnRn4 (Just new_ty) + +------------ +rn_core tvenv (UfCoVar v) + = rn_uf_id tvenv v `thenRn4` \ vname -> + returnRn4 (UfCoVar vname) + +rn_core tvenv (UfCoLit lit) + = returnRn4 (UfCoLit lit) + +rn_core tvenv (UfCoCon con tys as) + = lookupValueEvenIfInvisible con `thenRn4` \ new_con -> + mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys -> + mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as -> + returnRn4 (UfCoCon new_con new_tys new_as) + +rn_core tvenv (UfCoPrim op tys as) + = rn_core_primop tvenv op `thenRn4` \ new_op -> + mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys -> + mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as -> + returnRn4 (UfCoPrim new_op new_tys new_as) + +rn_core tvenv (UfCoLam binders body) + = mapRn4 (rn_binder tvenv) binders `thenRn4` \ new_binders -> + let + bs = [ b | (b, ty) <- new_binders ] + in + extendSS bs (rn_core tvenv body) `thenRn4` \ new_body -> + returnRn4 (UfCoLam new_binders new_body) + +rn_core tvenv (UfCoTyLam tv body) + = getSrcLocRn4 `thenRn4` \ src_loc -> + mkTyVarNamesEnv src_loc [tv] `thenRn4` \ (tvenv2, [new_tv]) -> + let + new_tvenv = catTyVarNamesEnvs tvenv2 tvenv + in + rn_core new_tvenv body `thenRn4` \ new_body -> + returnRn4 (UfCoTyLam new_tv new_body) + +rn_core tvenv (UfCoApp fun arg) + = rn_core tvenv fun `thenRn4` \ new_fun -> + rn_atom tvenv arg `thenRn4` \ new_arg -> + returnRn4 (UfCoApp new_fun new_arg) + +rn_core tvenv (UfCoTyApp expr ty) + = rn_core tvenv expr `thenRn4` \ new_expr -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (UfCoTyApp new_expr new_ty) + +rn_core tvenv (UfCoCase expr alts) + = rn_core tvenv expr `thenRn4` \ new_expr -> + rn_alts alts `thenRn4` \ new_alts -> + returnRn4 (UfCoCase new_expr new_alts) + where + rn_alts (UfCoAlgAlts alg_alts deflt) + = mapRn4 rn_alg_alt alg_alts `thenRn4` \ new_alts -> + rn_deflt deflt `thenRn4` \ new_deflt -> + returnRn4 (UfCoAlgAlts new_alts new_deflt) + where + rn_alg_alt (con, params, rhs) + = lookupValueEvenIfInvisible con `thenRn4` \ new_con -> + mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params -> + let + bs = [ b | (b, ty) <- new_params ] + in + extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs -> + returnRn4 (new_con, new_params, new_rhs) + + rn_alts (UfCoPrimAlts prim_alts deflt) + = mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts -> + rn_deflt deflt `thenRn4` \ new_deflt -> + returnRn4 (UfCoPrimAlts new_alts new_deflt) + where + rn_prim_alt (lit, rhs) + = rn_core tvenv rhs `thenRn4` \ new_rhs -> + returnRn4 (lit, new_rhs) + + rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault + rn_deflt (UfCoBindDefault b rhs) + = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) -> + extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs -> + returnRn4 (UfCoBindDefault new_b new_rhs) + +rn_core tvenv (UfCoLet bind body) + = rn_bind bind `thenRn4` \ (new_bind, new_binders) -> + extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body -> + returnRn4 (UfCoLet new_bind new_body) + where + rn_bind (UfCoNonRec b rhs) + = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) -> + rn_core tvenv rhs `thenRn4` \ new_rhs -> + returnRn4 (UfCoNonRec new_b new_rhs, [binder]) + + rn_bind (UfCoRec pairs) + = -- conjure up Names; we do this differently than + -- elsewhere for Core, because of the recursion here; + -- no deep issue. + -- [BEFORE IT WAS "FIXED"... 94/05...] + -- [Andy -- It *was* a 'deep' issue to me...] + -- [Will -- Poor wee soul.] + + getSrcLocRn4 `thenRn4` \ locn -> + namesFromProtoNames "core variable" + [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders -> + + extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs -> + returnRn4 (UfCoRec new_pairs, binders) + where + rn_pair (((b, ty), rhs), new_b) + = rn_core_type tvenv ty `thenRn4` \ new_ty -> + rn_core tvenv rhs `thenRn4` \ new_rhs -> + returnRn4 ((new_b, new_ty), new_rhs) + +rn_core tvenv (UfCoSCC uf_cc body) + = rn_cc uf_cc `thenRn4` \ new_cc -> + rn_core tvenv body `thenRn4` \ new_body -> + returnRn4 (UfCoSCC new_cc new_body) + where + rn_cc (UfAutoCC id m g is_dupd is_caf) + = rn_uf_id tvenv id `thenRn4` \ new_id -> + returnRn4 (UfAutoCC new_id m g is_dupd is_caf) + + rn_cc (UfDictCC id m g is_caf is_dupd) + = rn_uf_id tvenv id `thenRn4` \ new_id -> + returnRn4 (UfDictCC new_id m g is_dupd is_caf) + + -- the rest are boring: + rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d) + rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d) + rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c) + +------------ +rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty) + = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys -> + rn_core_type tvenv res_ty `thenRn4` \ new_res_ty -> + returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty) +rn_core_primop tvenv (UfOtherOp op) + = returnRn4 (UfOtherOp op) + +------------ +rn_uf_id tvenv (BoringUfId v) + = lookupValueEvenIfInvisible v `thenRn4` \ vname -> + returnRn4 (BoringUfId vname) + +rn_uf_id tvenv (SuperDictSelUfId c sc) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClass{-EvenIfInvisible-} sc `thenRn4` \ new_sc -> + returnRn4 (SuperDictSelUfId new_c new_sc) + +rn_uf_id tvenv (ClassOpUfId c op) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op -> + returnRn4 (ClassOpUfId new_c new_op) + +rn_uf_id tvenv (DictFunUfId c ty) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (DictFunUfId new_c new_ty) + +rn_uf_id tvenv (ConstMethodUfId c op ty) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (ConstMethodUfId new_c new_op new_ty) + +rn_uf_id tvenv (DefaultMethodUfId c op) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op -> + returnRn4 (DefaultMethodUfId new_c new_op) + +rn_uf_id tvenv (SpecUfId unspec ty_maybes) + = rn_uf_id tvenv unspec `thenRn4` \ new_unspec -> + mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes -> + returnRn4 (SpecUfId new_unspec new_ty_maybes) + +rn_uf_id tvenv (WorkerUfId unwrkr) + = rn_uf_id tvenv unwrkr `thenRn4` \ new_unwrkr -> + returnRn4 (WorkerUfId new_unwrkr) + +------------ +rn_binder tvenv (b, ty) + = getSrcLocRn4 `thenRn4` \ src_loc -> + namesFromProtoNames "binder in core unfolding" [(b, src_loc)] + `thenRn4` \ [new_b] -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (new_b, new_ty) + +------------ +rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l) +rn_atom tvenv (UfCoVarAtom v) + = rn_uf_id tvenv v `thenRn4` \ vname -> + returnRn4 (UfCoVarAtom vname) + +------------ +rn_core_type_maybe tvenv Nothing = returnRn4 Nothing +rn_core_type_maybe tvenv (Just ty) + = rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (Just new_ty) + +------------ +rn_core_type tvenv ty + = rnPolyType4 True{-invisible tycons OK-} False tvenv ty +\end{code} diff --git a/ghc/compiler/rename/RenameAuxFuns.hi b/ghc/compiler/rename/RenameAuxFuns.hi new file mode 100644 index 0000000..708da6d --- /dev/null +++ b/ghc/compiler/rename/RenameAuxFuns.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface RenameAuxFuns where +import Bag(Bag) +import Maybes(Labda) +import Name(Name) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type GlobalNameFun = ProtoName -> Labda Name +type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type PreludeNameFun = _PackedString -> Labda Name +type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name) +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +mkGlobalNameFun :: _PackedString -> (_PackedString -> Labda Name) -> [(ProtoName, Name)] -> ProtoName -> Labda Name + {-# GHC_PRAGMA _A_ 3 _U_ 2111 _N_ _N_ _N_ _N_ #-} +mkNameFun :: Bag (_PackedString, a) -> (_PackedString -> Labda a, [[(_PackedString, a)]]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/rename/RenameAuxFuns.lhs b/ghc/compiler/rename/RenameAuxFuns.lhs new file mode 100644 index 0000000..68106c1 --- /dev/null +++ b/ghc/compiler/rename/RenameAuxFuns.lhs @@ -0,0 +1,132 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Rename-aux-funs]{Functions used by both renaming passes} + +\begin{code} +#include "HsVersions.h" + +module RenameAuxFuns ( + mkGlobalNameFun, mkNameFun, + GlobalNameFun(..), GlobalNameFuns(..), + PreludeNameFun(..), PreludeNameFuns(..), + + -- and for self-containedness... + Bag, ProtoName, Maybe + ) where + +IMPORT_Trace -- ToDo: rm (for debugging) +import Outputable +import Pretty + +import Bag ( Bag, bagToList ) +import FiniteMap +import Maybes +import Name ( Name ) -- for instances +--OLD: import NameEnv +import ProtoName +import Util +\end{code} + +\begin{code} +type GlobalNameFun = ProtoName -> Maybe Name +type GlobalNameFuns = (GlobalNameFun, GlobalNameFun) + +type PreludeNameFun = FAST_STRING -> Maybe Name +type PreludeNameFuns = (PreludeNameFun, -- Values + PreludeNameFun -- Types and classes + ) +\end{code} + +\begin{code} +mkGlobalNameFun :: FAST_STRING -- The module name + -> PreludeNameFun -- The prelude things + -> [(ProtoName, Name)] -- The local and imported things + -> GlobalNameFun -- The global name function + +mkGlobalNameFun this_module prel_nf alist + = the_fun + where + the_fun (Prel n) = Just n + the_fun (Unk s) = case (unk_fun s) of + Just n -> Just n + Nothing -> prel_nf s + the_fun (Imp m d _ _) = imp_fun (d, m) -- NB: module-name 2nd! + + -- Things in the domain of the prelude function shouldn't be put + -- in the unk_fun; because the prel_nf will catch them. + -- This can arise if, for example, an interface gives a signature + -- for a prelude thing. + -- + -- Neither should they be in the domain of the imp_fun, because + -- prelude things will have been converted to Prel x rather than + -- Imp p q r s. + -- + -- So we strip out prelude things from the alist; this is not just + -- desirable, it's essential because get_orig and get_local don't handle + -- prelude things. + + non_prel_alist = filter non_prel alist + + non_prel (Prel _, _) = False + non_prel other = True + + -- unk_fun looks up local names (just strings), + -- imp_fun looks up original names: (string,string) pairs + unk_fun = lookupFM (listToFM [(get_local pn,n) | (pn,n) <- non_prel_alist]) + imp_fun = lookupFM (listToFM [(get_orig pn,n) | (pn,n) <- non_prel_alist]) + +{- OLD: + unk_fun = mkStringLookupFn [(get_local pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-} + imp_fun = mk2StringLookupFn [(get_orig pn,n) | (pn,n) <- non_prel_alist] False{-not sorted-} +-} + -- the lists *are* sorted by *some* ordering (by local + -- names), but not generally, and not in some way we + -- are going to rely on. + + get_local :: ProtoName -> FAST_STRING + get_local (Unk s) = s + get_local (Imp _ _ _ l) = l + get_local (Prel n) = pprPanic "get_local: " (ppr PprShowAll n) + + get_orig :: ProtoName -> (FAST_STRING, FAST_STRING) -- **NB**! module-name 2nd! + get_orig (Unk s) = (s, this_module) + get_orig (Imp m d _ _) = (d, m) + get_orig (Prel n) = pprPanic "get_orig: " (ppr PprShowAll n) +\end{code} + + +@mkNameFun@ builds a function from @ProtoName@s to things, where a +``thing'' is either a @ProtoName@ (in the case of values), or a +@(ProtoName, ProtoName -> ProtoName)@ pair in the case of types and +classes. It takes: + +\begin{itemize} +\item The name of the interface +\item A bag of new string-to-thing bindings to add, + +\item An extractor function, to get a @ProtoName@ out of a thing, + for use in error messages. +\end{itemize} +The function it returns only expects to see @Unk@ things. + +@mkNameFun@ checks for clashes in the domain of the new bindings. + +ToDo: it should check for clashes with the prelude bindings too. + +\begin{code} +mkNameFun :: Bag (FAST_STRING, thing) -- Value bindings + -> (FAST_STRING -> Maybe thing, -- The function to use + [[(FAST_STRING,thing)]]) -- Duplicates, if any + +mkNameFun the_bag + = case (removeDups cmp (bagToList the_bag)) of { (no_dup_list, dups) -> + case (lookupFM (listToFM no_dup_list)) of { the_fun -> + --OLD :case (mkStringLookupFn no_dup_list True{-list is pre-sorted-}) of the_fun -> + (the_fun, dups) + }} + where + cmp :: (FAST_STRING, a) -> (FAST_STRING, a) -> TAG_ + + cmp (s1,_) (s2,_) = _CMP_STRING_ s1 s2 +\end{code} diff --git a/ghc/compiler/rename/RenameBinds4.hi b/ghc/compiler/rename/RenameBinds4.hi new file mode 100644 index 0000000..b806693 --- /dev/null +++ b/ghc/compiler/rename/RenameBinds4.hi @@ -0,0 +1,54 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface RenameBinds4 where +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import FiniteMap(FiniteMap) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsExpr(Expr) +import HsLit(Literal) +import HsMatches(GRHSsAndBinds, Match) +import HsPat(InPat) +import Id(Id) +import Inst(Inst) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(GlobalNameFun(..)) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +type DefinedVars = UniqFM Name +type FreeVars = UniqFM Name +data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type GlobalNameFun = ProtoName -> Labda Name +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +rnBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Binds Name (InPat Name), UniqFM Name, [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} +rnMethodBinds4 :: Name -> MonoBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (MonoBinds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-} +rnTopBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Binds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/rename/RenameBinds4.lhs b/ghc/compiler/rename/RenameBinds4.lhs new file mode 100644 index 0000000..fe41495 --- /dev/null +++ b/ghc/compiler/rename/RenameBinds4.lhs @@ -0,0 +1,652 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[RenameBinds4]{Renaming and dependency analysis of bindings} + +This module does renaming and dependency analysis on value bindings in +@AbsSyntax@ programs. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). + +\begin{code} +#include "HsVersions.h" + +module RenameBinds4 ( + rnTopBinds4, rnMethodBinds4, + rnBinds4, + FreeVars(..), DefinedVars(..), + + -- and to make the interface self-sufficient... + Bag, Binds, MonoBinds, InPat, Name, ProtoName, + GlobalNameFun(..), Maybe, UniqSet(..), UniqFM, SrcLoc, Unique, + SplitUniqSupply, Error(..), Pretty(..), PprStyle, + PrettyRep + ) where + +import AbsSyn +import CmdLineOpts ( GlobalSwitch(..) ) +import Digraph ( stronglyConnComp {- MOVED HERE: , isCyclic -} ) +import Errors -- ( unknownSigDeclErr, dupSigDeclErr, methodBindErr ) +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Maybes ( catMaybes, Maybe(..) ) +import Name ( eqName, cmpName, isUnboundName ) +import ProtoName ( elemByLocalNames, eqByLocalName ) +import Rename4 ( rnPolyType4, rnGenPragmas4 ) +import RenameAuxFuns ( GlobalNameFuns(..) ) +import RenameMonad4 +import RenameExpr4 ( rnMatch4, rnGRHSsAndBinds4, rnPat4 ) +import UniqSet +import Util +\end{code} + +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds4@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds4@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +Sets of variable names are represented as sets explicitly, rather than lists. + +\begin{code} +type DefinedVars = UniqSet Name +type FreeVars = UniqSet Name +\end{code} + +i.e., binders. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + +\begin{code} +type VertexTag = Int +type Cycle = [VertexTag] +type Edge = (VertexTag, VertexTag) +\end{code} + +%************************************************************************ +%* * +%* naming conventions * +%* * +%************************************************************************ +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (Binds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +%************************************************************************ +%* * +%* analysing polymorphic bindings (Binds, Bind, MonoBinds) * +%* * +%************************************************************************ +\subsubsection[dep-Binds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBindsInfo@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds4@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +\begin{code} +rnTopBinds4 :: ProtoNameBinds -> Rn4M RenamedBinds +rnMethodBinds4 :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds +rnBinds4 :: ProtoNameBinds -> Rn4M (RenamedBinds, FreeVars, [Name]) + +rnTopBinds4 EmptyBinds = returnRn4 EmptyBinds +rnTopBinds4 (SingleBind (RecBind bind)) = rnTopMonoBinds4 bind [] +rnTopBinds4 (BindWith (RecBind bind) sigs) = rnTopMonoBinds4 bind sigs + -- the parser doesn't produce other forms + +-- ******************************************************************** + +rnMethodBinds4 class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds + +rnMethodBinds4 class_name (AndMonoBinds mb1 mb2) + = andRn4 AndMonoBinds (rnMethodBinds4 class_name mb1) + (rnMethodBinds4 class_name mb2) + +rnMethodBinds4 class_name (FunMonoBind pname matches locn) + = pushSrcLocRn4 locn ( + lookupClassOp class_name pname `thenRn4` \ op_name -> + mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, _) -> + returnRn4 (FunMonoBind op_name new_matches locn) + ) + +rnMethodBinds4 class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn) + = pushSrcLocRn4 locn ( + lookupClassOp class_name pname `thenRn4` \ op_name -> + rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', _) -> + returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn) + ) + +-- Can't handle method pattern-bindings which bind multiple methods. +rnMethodBinds4 _ mbind@(PatMonoBind other_pat _ locn) + = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn) + +-- ******************************************************************** + +rnBinds4 EmptyBinds = returnRn4 (EmptyBinds,emptyUniqSet,[]) +rnBinds4 (SingleBind (RecBind bind)) = rnNestedMonoBinds4 bind [] +rnBinds4 (BindWith (RecBind bind) sigs) = rnNestedMonoBinds4 bind sigs + -- the parser doesn't produce other forms +\end{code} + +@rnNestedMonoBinds4@ + - collects up the binders for this declaration group, + - checkes that they form a set + - extends the environment to bind them to new local names + - calls @rnMonoBinds4@ to do the real work + +In contrast, @rnTopMonoBinds4@ doesn't extend the environment, because that's +already done in pass3. All it does is call @rnMonoBinds4@ and discards +the free var info. + +\begin{code} +rnTopMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedBinds + +rnTopMonoBinds4 EmptyMonoBinds sigs = returnRn4 EmptyBinds + +rnTopMonoBinds4 mbs sigs + = rnBindSigs4 True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist -> + rnMonoBinds4 mbs siglist `thenRn4` \ (new_binds, fv_set) -> + returnRn4 new_binds + + +rnNestedMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] + -> Rn4M (RenamedBinds, FreeVars, [Name]) + +rnNestedMonoBinds4 EmptyMonoBinds sigs + = returnRn4 (EmptyBinds, emptyUniqSet, []) + +rnNestedMonoBinds4 mbinds sigs -- Non-empty monobinds + = + -- Extract all the binders in this group, + -- and extend current scope, inventing new names for the new binders + -- This also checks that the names form a set + let + mbinders_w_srclocs = collectMonoBindersAndLocs mbinds + mbinders = map fst mbinders_w_srclocs + in + namesFromProtoNames + "variable" -- in binding group + mbinders_w_srclocs `thenRn4` \ new_mbinders -> + + extendSS2 new_mbinders ( + rnBindSigs4 False{-not top- level-} mbinders sigs `thenRn4` \ siglist -> + rnMonoBinds4 mbinds siglist + ) `thenRn4` \ (new_binds, fv_set) -> + returnRn4 (new_binds, fv_set, new_mbinders) +\end{code} + +@rnMonoBinds4@ is used by *both* top-level and nested bindings. It +assumes that all variables bound in this group are already in scope. +This is done *either* by pass 3 (for the top-level bindings), +*or* by @rnNestedMonoBinds4@ (for the nested ones). + +\begin{code} +rnMonoBinds4 :: ProtoNameMonoBinds + -> [RenamedSig] -- Signatures attached to this group + -> Rn4M (RenamedBinds, FreeVars) + +rnMonoBinds4 mbinds siglist + = + -- Rename the bindings, returning a MonoBindsInfo + -- which is a list of indivisible vertices so far as + -- the SCC analysis is concerned + flattenMonoBinds 0 siglist mbinds `thenRn4` \ (_, mbinds_info) -> + + -- Do the SCC analysis + let vertices = mkVertices mbinds_info + edges = mkEdges vertices mbinds_info + + scc_result = stronglyConnComp (==) edges vertices + + -- Deal with bound and free-var calculation + rhs_free_vars = foldr f emptyUniqSet mbinds_info + + final_binds = reconstructRec scc_result edges mbinds_info + + happy_answer = returnRn4 (final_binds, rhs_free_vars) + in + case (inline_sigs_in_recursive_binds final_binds) of + Nothing -> happy_answer + Just names_n_locns -> + addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_` + {-not so-}happy_answer + where + f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars + + f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body + + inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs) + = case [(n, locn) | (InlineSig n _ locn) <- sigs ] of + [] -> Nothing + sigh -> +#if OMIT_DEFORESTER + Just sigh +#else + -- Allow INLINEd recursive functions if they are + -- designated DEFORESTable too. + case [(n, locn) | (DeforestSig n locn) <- sigs ] of + [] -> Just sigh + sigh -> Nothing +#endif + + inline_sigs_in_recursive_binds (ThenBinds b1 b2) + = case (inline_sigs_in_recursive_binds b1) of + Nothing -> inline_sigs_in_recursive_binds b2 + Just x -> Just x -- NB: won't report error(s) in b2 + + inline_sigs_in_recursive_binds anything_else = Nothing +\end{code} + +@flattenMonoBinds@ is ever-so-slightly magical in that it sticks +unique ``vertex tags'' on its output; minor plumbing required. + +\begin{code} +flattenMonoBinds :: Int -- Next free vertex tag + -> [RenamedSig] -- Signatures + -> ProtoNameMonoBinds + -> Rn4M (Int, FlatMonoBindsInfo) + +flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, []) + +flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2) + = flattenMonoBinds uniq sigs mB1 `thenRn4` \ (uniq1, flat1) -> + flattenMonoBinds uniq1 sigs mB2 `thenRn4` \ (uniq2, flat2) -> + returnRn4 (uniq2, flat1 ++ flat2) + +flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn) + = pushSrcLocRn4 locn ( + rnPat4 pat `thenRn4` \ pat' -> + rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) -> + + -- Find which things are bound in this group + let + names_bound_here = collectPatBinders pat' + + sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here)) + [] sigs + + sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here + + is_elem = isIn "flattenMonoBinds" + in + returnRn4 ( + uniq + 1, + [(uniq, + mkUniqSet names_bound_here, + fvs `unionUniqSets` sigs_fvs, + PatMonoBind pat' grhss_and_binds' locn, + sigs_etc_for_here + )] + )) + +flattenMonoBinds uniq sigs (FunMonoBind name matches locn) + = pushSrcLocRn4 locn ( + lookupValue name `thenRn4` \ name' -> + mapAndUnzipRn4 rnMatch4 matches `thenRn4` \ (new_matches, fv_lists) -> + let + fvs = unionManyUniqSets fv_lists + + sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs + + sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me + in + returnRn4 ( + uniq + 1, + [(uniq, + singletonUniqSet name', + fvs `unionUniqSets` sigs_fvs, + FunMonoBind name' new_matches locn, + sigs_for_me + )] + )) +\end{code} + +Grab type-signatures/user-pragmas of interest: +\begin{code} +sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc +sig_for_here want_me acc s@(InlineSig n _ _) | want_me n = s:acc +sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc +sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc +sig_for_here want_me acc s@(MagicUnfoldingSig n _ _) + | want_me n = s:acc +sig_for_here want_me acc other_wise = acc + +-- If a SPECIALIZE pragma is of the "... = blah" form, +-- then we'd better make sure "blah" is taken into +-- 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 _ acc = acc +\end{code} + +%************************************************************************ +%* * +\subsection[reconstruct-deps]{Reconstructing dependencies} +%* * +%************************************************************************ + +This @MonoBinds@- and @ClassDecls@-specific code is segregated here, +as the two cases are similar. + +\begin{code} +reconstructRec :: [Cycle] -- Result of SCC analysis; at least one + -> [Edge] -- Original edges + -> FlatMonoBindsInfo + -> RenamedBinds + +reconstructRec cycles edges mbi + = foldr1 ThenBinds (map (reconstructCycle mbi) cycles) + where + reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds + + reconstructCycle mbi2 cycle + = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle] + _TO_ relevant_binds_and_sigs -> + + BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) -> + + BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds -> + let + this_gp_sigs = foldr1 (++) sig_lists + have_sigs = not (null sig_lists) + -- ToDo: this might not be the right + -- thing to call this predicate; + -- e.g. "have_sigs [[], [], []]" ??????????? + in + mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs + BEND BEND BEND + where + is_elem = isIn "reconstructRec" + + mk_binds :: RenamedMonoBinds -> [RenamedSig] + -> Bool -> Bool -> RenamedBinds + + mk_binds bs ss True False = SingleBind (RecBind bs) + mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss + mk_binds bs ss False False = SingleBind (NonRecBind bs) + mk_binds bs ss False True{-have sigs-} = BindWith (NonRecBind bs) ss + + -- moved from Digraph, as this is the only use here + -- (avoid overloading cost). We have to use elem + -- (not FiniteMaps or whatever), because there may be + -- many edges out of one vertex. We give it its own + -- "elem" just for speed. + + isCyclic es [] = panic "isCyclic: empty component" + isCyclic es [v] = (v,v) `elem` es + isCyclic es vs = True + + elem _ [] = False + elem x (y:ys) = x==y || elem x ys +\end{code} + +%************************************************************************ +%* * +%* Manipulating FlatMonoBindInfo * +%* * +%************************************************************************ + +During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@. +The @RenamedMonoBinds@ is always an empty bind, a pattern binding or +a function binding, and has itself been dependency-analysed and +renamed. + +\begin{code} +type FlatMonoBindsInfo + = [(VertexTag, -- Identifies the vertex + UniqSet Name, -- Set of names defined in this vertex + UniqSet Name, -- Set of names used in this vertex + RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat) + [RenamedSig]) -- Signatures, if any, for this vertex + ] + +mkVertices :: FlatMonoBindsInfo -> [VertexTag] +mkVertices info = [ vertex | (vertex,_,_,_,_) <- info] + +mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge] + +mkEdges vertices flat_info + -- An edge (v,v') indicates that v depends on v' + = [ (source_vertex, target_vertex) + | (source_vertex, _, used_names, _, _) <- flat_info, + target_name <- uniqSetToList used_names, + target_vertex <- vertices_defining target_name flat_info + ] + where + -- If each name only has one binding in this group, then + -- vertices_defining will always return the empty list, or a + -- singleton. The case when there is more than one binding (an + -- error) needs more thought. + + vertices_defining name flat_info2 + = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2, + name `elementOfUniqSet` names_defined + ] +\end{code} + + +%************************************************************************ +%* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +%* * +%************************************************************************ + +@rnBindSigs4@ checks for: (a)~more than one sig for one thing; +(b)~signatures given for things not bound here; (c)~with suitably +flaggery, that all top-level things have type signatures. + +\begin{code} +rnBindSigs4 :: Bool -- True <=> top-level binders + -> [ProtoName] -- Binders for this decl group + -> [ProtoNameSig] + -> Rn4M [RenamedSig] -- List of Sig constructors + +rnBindSigs4 is_toplev binder_pnames sigs + = + -- Rename the signatures + -- Will complain about sigs for variables not in this group + mapRn4 rename_sig sigs `thenRn4` \ sigs_maybe -> + let + sigs' = catMaybes sigs_maybe + + -- Discard unbound ones we've already complained about, so we + -- complain about duplicate ones. + + (goodies, dups) = removeDups cmp (filter not_unbound sigs') + in + mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_` + + getSwitchCheckerRn4 `thenRn4` \ sw_chkr -> + getSrcLocRn4 `thenRn4` \ locn -> + + (if (is_toplev && sw_chkr SigsRequired) then + let + sig_frees = catMaybes (map (sig_free sigs) binder_pnames) + in + mapRn4 (addErrRn4 . missingSigErr locn) sig_frees + else + returnRn4 [] + ) `thenRn4_` + + returnRn4 sigs' -- bad ones and all: + -- we need bindings of *some* sort for every name + where + rename_sig (Sig v ty pragma src_loc) + = pushSrcLocRn4 src_loc ( + + if not (v `elemByLocalNames` binder_pnames) then + addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_` + returnRn4 Nothing + else + lookupValue v `thenRn4` \ new_v -> + rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 pragma + ) `thenRn4` \ new_pragma -> + returnRn4 (Just (Sig new_v new_ty new_pragma src_loc)) + ) + + -- and now, the various flavours of value-modifying user-pragmas: + + rename_sig (SpecSig v ty using src_loc) + = pushSrcLocRn4 src_loc ( + + if not (v `elemByLocalNames` binder_pnames) then + addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_` + returnRn4 Nothing + else + lookupValue v `thenRn4` \ new_v -> + rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + rn_using using `thenRn4` \ new_using -> + returnRn4 (Just (SpecSig new_v new_ty new_using src_loc)) + ) + where + rn_using Nothing = returnRn4 Nothing + rn_using (Just x) = lookupValue x `thenRn4` \ new_x -> + returnRn4 (Just new_x) + + rename_sig (InlineSig v howto src_loc) + = pushSrcLocRn4 src_loc ( + + if not (v `elemByLocalNames` binder_pnames) then + addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_` + returnRn4 Nothing + else + lookupValue v `thenRn4` \ new_v -> + returnRn4 (Just (InlineSig new_v howto src_loc)) + ) + + rename_sig (DeforestSig v src_loc) + = pushSrcLocRn4 src_loc ( + + if not (v `elemByLocalNames` binder_pnames) then + addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_` + returnRn4 Nothing + else + lookupValue v `thenRn4` \ new_v -> + returnRn4 (Just (DeforestSig new_v src_loc)) + ) + + rename_sig (MagicUnfoldingSig v str src_loc) + = pushSrcLocRn4 src_loc ( + + if not (v `elemByLocalNames` binder_pnames) then + addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_` + returnRn4 Nothing + else + lookupValue v `thenRn4` \ new_v -> + returnRn4 (Just (MagicUnfoldingSig new_v str src_loc)) + ) + + not_unbound :: RenamedSig -> Bool + + not_unbound (Sig n _ _ _) = not (isUnboundName n) + not_unbound (SpecSig n _ _ _) = not (isUnboundName n) + not_unbound (InlineSig n _ _) = not (isUnboundName n) + not_unbound (DeforestSig n _) = not (isUnboundName n) + not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n) + + ------------------------------------- + sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName + -- Return "Just x" if "x" has no type signature in + -- sigs. Nothing, otherwise. + + sig_free [] ny = Just ny + sig_free (Sig nx _ _ _ : rest) ny + = if (nx `eqByLocalName` ny) then Nothing else sig_free rest ny + sig_free (_ : rest) ny = sig_free rest ny + + ------------------------------------- + cmp :: RenamedSig -> RenamedSig -> TAG_ + + cmp (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmpName` n2 + cmp (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `cmpName` n2 + cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2 + cmp (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _) + = -- may have many specialisations for one value; + -- but not ones that are exactly the same... + case (n1 `cmpName` n2) of + EQ_ -> cmpPolyType cmpName ty1 ty2 + other -> other + + cmp other_1 other_2 -- tags *must* be different + = let tag1 = tag other_1 + tag2 = tag other_2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + + tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT) + tag (SpecSig n1 _ _ _) = ILIT(2) + tag (InlineSig n1 _ _) = ILIT(3) + tag (MagicUnfoldingSig n1 _ _) = ILIT(4) + tag (DeforestSig n1 _) = ILIT(5) + tag _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance +\end{code} diff --git a/ghc/compiler/rename/RenameExpr4.hi b/ghc/compiler/rename/RenameExpr4.hi new file mode 100644 index 0000000..45efb1b --- /dev/null +++ b/ghc/compiler/rename/RenameExpr4.hi @@ -0,0 +1,47 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface RenameExpr4 where +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import FiniteMap(FiniteMap) +import HsBinds(Binds) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(GlobalNameFun(..)) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type GlobalNameFun = ProtoName -> Labda Name +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +rnGRHSsAndBinds4 :: GRHSsAndBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((GRHSsAndBinds Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} +rnMatch4 :: Match ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Match Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-} +rnPat4 :: InPat ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (InPat Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/rename/RenameExpr4.lhs b/ghc/compiler/rename/RenameExpr4.lhs new file mode 100644 index 0000000..34c702e --- /dev/null +++ b/ghc/compiler/rename/RenameExpr4.lhs @@ -0,0 +1,431 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[RenameExpr]{Renaming of expressions} + +Basically dependency analysis. + +Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. + +\begin{code} +#include "HsVersions.h" + +module RenameExpr4 ( + rnMatch4, rnGRHSsAndBinds4, rnPat4, + + -- and to make the interface self-sufficient... + Bag, GRHSsAndBinds, InPat, Name, Maybe, + ProtoName, GlobalNameFun(..), UniqSet(..), UniqFM, SrcLoc, + Unique, SplitUniqSupply, + Pretty(..), PprStyle, PrettyRep + ) where + +import AbsSyn +import NameTypes ( FullName ) +import Outputable +import ProtoName ( ProtoName(..) ) +import Rename4 ( rnPolyType4 ) +import RenameAuxFuns ( GlobalNameFuns(..) ) -- ToDo: rm this line +import RenameBinds4 ( rnBinds4, FreeVars(..) ) +import RenameMonad4 +import UniqSet +import Util +\end{code} + + +********************************************************* +* * +\subsection{Patterns} +* * +********************************************************* + +\begin{code} +rnPat4 :: ProtoNamePat -> Rn4M RenamedPat + +rnPat4 WildPatIn = returnRn4 WildPatIn + +rnPat4 (VarPatIn name) + = lookupValue name `thenRn4` \ vname -> + returnRn4 (VarPatIn vname) + +rnPat4 (LitPatIn n) = returnRn4 (LitPatIn n) + +rnPat4 (LazyPatIn pat) + = rnPat4 pat `thenRn4` \ pat' -> + returnRn4 (LazyPatIn pat') + +rnPat4 (AsPatIn name pat) + = rnPat4 pat `thenRn4` \ pat' -> + lookupValue name `thenRn4` \ vname -> + returnRn4 (AsPatIn vname pat') + +rnPat4 (ConPatIn name pats) + = lookupValue name `thenRn4` \ name' -> + mapRn4 rnPat4 pats `thenRn4` \ patslist -> + returnRn4 (ConPatIn name' patslist) + +rnPat4 (ConOpPatIn pat1 name pat2) + = lookupValue name `thenRn4` \ name' -> + rnPat4 pat1 `thenRn4` \ pat1' -> + rnPat4 pat2 `thenRn4` \ pat2' -> + returnRn4 (ConOpPatIn pat1' name' pat2') + +rnPat4 (ListPatIn pats) + = mapRn4 rnPat4 pats `thenRn4` \ patslist -> + returnRn4 (ListPatIn patslist) + +rnPat4 (TuplePatIn pats) + = mapRn4 rnPat4 pats `thenRn4` \ patslist -> + returnRn4 (TuplePatIn patslist) + +rnPat4 (NPlusKPatIn name lit) + = lookupValue name `thenRn4` \ vname -> + returnRn4 (NPlusKPatIn vname lit) + +#ifdef DPH +rnPat4 (ProcessorPatIn pats pat) + = mapRn4 rnPat4 pats `thenRn4` \ pats' -> + rnPat4 pat `thenRn4` \ pat' -> + returnRn4 (ProcessorPatIn pats' pat') +#endif {- Data Parallel Haskell -} +\end{code} + +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ + +\begin{code} +rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars) + +rnMatch4 match + = getSrcLocRn4 `thenRn4` \ src_loc -> + namesFromProtoNames "variable in pattern" + (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> + extendSS2 new_binders (rnMatch4_aux match) + where + binders = collect_binders match + + collect_binders :: ProtoNameMatch -> [ProtoName] + + collect_binders (GRHSMatch _) = [] + collect_binders (PatMatch pat match) + = collectPatBinders pat ++ collect_binders match + +rnMatch4_aux (PatMatch pat match) + = rnPat4 pat `thenRn4` \ pat' -> + rnMatch4_aux match `thenRn4` \ (match', fvMatch) -> + returnRn4 (PatMatch pat' match', fvMatch) + +rnMatch4_aux (GRHSMatch grhss_and_binds) + = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) -> + returnRn4 (GRHSMatch grhss_and_binds', fvs) +\end{code} + +%************************************************************************ +%* * +\subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)} +%* * +%************************************************************************ + +\begin{code} +rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars) + +rnGRHSsAndBinds4 (GRHSsAndBindsIn grhss binds) + = rnBinds4 binds `thenRn4` \ (binds', fvBinds, scope) -> + extendSS2 scope (rnGRHSs4 grhss) `thenRn4` \ (grhss', fvGRHS) -> + returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS) + where + rnGRHSs4 [] = returnRn4 ([], emptyUniqSet) + + rnGRHSs4 (grhs:grhss) + = rnGRHS4 grhs `thenRn4` \ (grhs', fvs) -> + rnGRHSs4 grhss `thenRn4` \ (grhss', fvss) -> + returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss) + + rnGRHS4 (GRHS guard expr locn) + = pushSrcLocRn4 locn ( + rnExpr4 guard `thenRn4` \ (guard', fvsg) -> + rnExpr4 expr `thenRn4` \ (expr', fvse) -> + returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse) + ) + + rnGRHS4 (OtherwiseGRHS expr locn) + = pushSrcLocRn4 locn ( + rnExpr4 expr `thenRn4` \ (expr', fvs) -> + returnRn4 (OtherwiseGRHS expr' locn, fvs) + ) +\end{code} + +%************************************************************************ +%* * +\subsubsection[dep-Expr]{Expressions} +%* * +%************************************************************************ + +\begin{code} +rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars) + +rnExprs4 [] = returnRn4 ([], emptyUniqSet) + +rnExprs4 (expr:exprs) + = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> + rnExprs4 exprs `thenRn4` \ (exprs', fvExprs) -> + returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs) +\end{code} + +Variables. We look up the variable and return the resulting name. The +interesting question is what the free-variable set should be. We +don't want to return imported or prelude things as free vars. So we +look at the Name returned from the lookup, and make it part of the +free-var set iff: +\begin{itemize} +\item +if it's a @Short@, +\item +or it's an @OtherTopId@ and it's defined in this module +(this includes locally-defined constructrs, but that's too bad) +\end{itemize} + +\begin{code} +rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars) + +rnExpr4 (Var v) + = lookupValue v `thenRn4` \ vname -> + returnRn4 (Var vname, fv_set vname) + where + fv_set n@(Short uniq sname) = singletonUniqSet n + fv_set n@(OtherTopId uniq fname) + | isLocallyDefined fname + && not (isConop (getOccurrenceName fname)) + = singletonUniqSet n + fv_set other = emptyUniqSet + +rnExpr4 (Lit lit) = returnRn4 (Lit lit, emptyUniqSet) + +rnExpr4 (Lam match) + = rnMatch4 match `thenRn4` \ (match', fvMatch) -> + returnRn4 (Lam match', fvMatch) + +rnExpr4 (App fun arg) + = rnExpr4 fun `thenRn4` \ (fun',fvFun) -> + rnExpr4 arg `thenRn4` \ (arg',fvArg) -> + returnRn4 (App fun' arg', fvFun `unionUniqSets` fvArg) + +rnExpr4 (OpApp e1 op e2) + = rnExpr4 e1 `thenRn4` \ (e1', fvs_e1) -> + rnExpr4 op `thenRn4` \ (op', fvs_op) -> + rnExpr4 e2 `thenRn4` \ (e2', fvs_e2) -> + returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2) + +rnExpr4 (SectionL expr op) + = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) -> + rnExpr4 op `thenRn4` \ (op', fvs_op) -> + returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr) + +rnExpr4 (SectionR op expr) + = rnExpr4 op `thenRn4` \ (op', fvs_op) -> + rnExpr4 expr `thenRn4` \ (expr', fvs_expr) -> + returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr) + +rnExpr4 (CCall fun args may_gc is_casm fake_result_ty) + = rnExprs4 args `thenRn4` \ (args', fvs_args) -> + returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) + +rnExpr4 (SCC label expr) + = rnExpr4 expr `thenRn4` \ (expr', fvs_expr) -> + returnRn4 (SCC label expr', fvs_expr) + +rnExpr4 (Case expr ms) + = rnExpr4 expr `thenRn4` \ (new_expr, e_fvs) -> + mapAndUnzipRn4 rnMatch4 ms `thenRn4` \ (new_ms, ms_fvs) -> + returnRn4 (Case new_expr new_ms, unionManyUniqSets (e_fvs : ms_fvs)) + +rnExpr4 (ListComp expr quals) + = rnQuals4 quals `thenRn4` \ ((quals', qual_binders), fvQuals) -> + extendSS2 qual_binders (rnExpr4 expr) `thenRn4` \ (expr', fvExpr) -> + returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals) + +rnExpr4 (Let binds expr) + = rnBinds4 binds `thenRn4` \ (binds', fvBinds, new_binders) -> + extendSS2 new_binders (rnExpr4 expr) `thenRn4` \ (expr',fvExpr) -> + returnRn4 (Let binds' expr', fvBinds `unionUniqSets` fvExpr) + +rnExpr4 (ExplicitList exps) + = rnExprs4 exps `thenRn4` \ (exps', fvs) -> + returnRn4 (ExplicitList exps', fvs) + +rnExpr4 (ExplicitTuple exps) + = rnExprs4 exps `thenRn4` \ (exps', fvExps) -> + returnRn4 (ExplicitTuple exps', fvExps) + +rnExpr4 (ExprWithTySig expr pty) + = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> + rnPolyType4 False True nullTyVarNamesEnv pty `thenRn4` \ pty' -> + returnRn4 (ExprWithTySig expr' pty', fvExpr) + +rnExpr4 (If p b1 b2) + = rnExpr4 p `thenRn4` \ (p', fvP) -> + rnExpr4 b1 `thenRn4` \ (b1', fvB1) -> + rnExpr4 b2 `thenRn4` \ (b2', fvB2) -> + returnRn4 (If p' b1' b2', unionManyUniqSets [fvP, fvB1, fvB2]) + +rnExpr4 (ArithSeqIn seq) + = rn_seq seq `thenRn4` \ (new_seq, fvs) -> + returnRn4 (ArithSeqIn new_seq, fvs) + where + rn_seq (From expr) + = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> + returnRn4 (From expr', fvExpr) + + rn_seq (FromThen expr1 expr2) + = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) -> + rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) -> + returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) + + rn_seq (FromTo expr1 expr2) + = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) -> + rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) -> + returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2) + + rn_seq (FromThenTo expr1 expr2 expr3) + = rnExpr4 expr1 `thenRn4` \ (expr1', fvExpr1) -> + rnExpr4 expr2 `thenRn4` \ (expr2', fvExpr2) -> + rnExpr4 expr3 `thenRn4` \ (expr3', fvExpr3) -> + returnRn4 (FromThenTo expr1' expr2' expr3', + unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3]) + +#ifdef DPH +rnExpr4 (ParallelZF expr quals) + = rnParQuals4 quals `thenRn4` \ ((quals',binds),fvQuals)-> + extendSS2 binds + (rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) -> + returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals) + +rnExpr4 (ExplicitProcessor exprs expr) + = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) -> + rnExpr4 expr `thenRn4` \ (expr' ,fvExpr) -> + returnRn4 (ExplicitProcessor exprs' expr',fvExprs `unionUniqSets` fvExpr) + +rnExpr4 (ExplicitPodIn exprs) + = rnExprs4 exprs `thenRn4` \ (exprs',fvExprs) -> + returnRn4 (ExplicitPodIn exprs',fvExprs) + +-- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-) + +#endif {- Data Parallel Haskell -} + +-- ArithSeqOut: not in ProtoNameExprs +\end{code} + +%************************************************************************ +%* * +\subsubsection[dep-Quals]{@Qual@s: in list comprehensions} +%* * +%************************************************************************ + +Note that although some bound vars may appear in the free var set for +the first qual, these will eventually be removed by the caller. For +example, if we have @[p | r <- s, q <- r, p <- q]@, when doing +@(AndQuals (q <- r) (p <- q))@, the free var set for @(q <- r)@ will +be @[r]@, and the free var set for the entire Quals will be @[r]@. This +@r@ will be removed only when we finally return from examining all the +Quals. + +\begin{code} +rnQuals4 :: [ProtoNameQual] -> Rn4M (([RenamedQual], [Name]), FreeVars) + +rnQuals4 [qual] + = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) -> + returnRn4 (([new_qual], bs), fvs) + +rnQuals4 (qual: quals) + = rnQual4 qual `thenRn4` \ ((qual', bs1), fvQuals1) -> + extendSS2 bs1 (rnQuals4 quals) `thenRn4` \ ((quals', bs2), fvQuals2) -> + returnRn4 + ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the + -- ones on the left (bs1) + fvQuals1 `unionUniqSets` fvQuals2) + +rnQual4 (GeneratorQual pat expr) + = rnExpr4 expr `thenRn4` \ (expr', fvExpr) -> + let + binders = collectPatBinders pat + in + getSrcLocRn4 `thenRn4` \ src_loc -> + namesFromProtoNames "variable in list-comprehension-generator pattern" + (binders `zip` repeat src_loc) `thenRn4` \ new_binders -> + extendSS new_binders (rnPat4 pat) `thenRn4` \ pat' -> + + returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr) + +rnQual4 (FilterQual expr) + = rnExpr4 expr `thenRn4` \ (expr', fvs) -> + returnRn4 ((FilterQual expr', []), fvs) +\end{code} + +%************************************************************************ +%* * +%* Parallel Quals (in Parallel Zf expressions) * +%* * +%************************************************************************ +\subsubsection[dep-ParQuals]{ParQuals} + +\begin{code} +#ifdef DPH +rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat] +rnPats4 [] = returnRn4 [] +rnPats4 (pat:pats) + = (rnPat4 pat) `thenRn4` (\ pat' -> + (rnPats4 pats) `thenRn4` (\ pats' -> + returnRn4 (pat':pats') )) + +rnParQuals4 :: ProtoNameParQuals -> Rn4M ((RenamedParQuals, [Name]), FreeVars) + +rnParQuals4 (AndParQuals q1 q2) + = rnParQuals4 q1 `thenRn4` (\ ((quals1', bs1), fvQuals1) -> + extendSS2 bs1 (rnParQuals4 q2) + `thenRn4` (\ ((quals2', bs2), fvQuals2) -> + returnRn4 ((AndParQuals quals1' quals2', bs2 ++ bs1), + fvQuals1 `unionUniqSets` fvQuals2) )) + + +rnParQuals4 (DrawnGenIn pats pat expr) + = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) -> + let_1_0 (concat (map collectPatBinders pats)) (\ binders1 -> + getSrcLocRn4 `thenRn4` (\ src_loc -> + namesFromProtoNames "variable in pattern" + (binders1 `zip` repeat src_loc) + `thenRn4` (\ binders1' -> + extendSS binders1' (rnPats4 pats) + `thenRn4` (\ pats' -> + let_1_0 (collectPatBinders pat) (\ binders2 -> + namesFromProtoNames "variable in pattern" + (binders2 `zip` repeat src_loc) + `thenRn4` (\ binders2' -> + extendSS binders2' (rnPat4 pat) + `thenRn4` (\ pat' -> + returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'), + fvExpr) )))))))) + +rnParQuals4 (IndexGen exprs pat expr) + = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) -> + rnExprs4 exprs `thenRn4` (\ (exprs', fvExprs) -> + let_1_0 (collectPatBinders pat) (\ binders -> + getSrcLocRn4 `thenRn4` (\ src_loc -> + namesFromProtoNames "variable in pattern" + (binders `zip` repeat src_loc) + `thenRn4` (\ binders' -> + extendSS binders' (rnPat4 pat) + `thenRn4` (\ pat' -> + returnRn4 ((IndexGen exprs' pat' expr' , binders'), + fvExpr `unionUniqSets` fvExprs) )))))) + +rnParQuals4 (ParFilter expr) + = rnExpr4 expr `thenRn4` (\ (expr', fvExpr) -> + returnRn4 ((ParFilter expr', []), fvExpr) ) +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/rename/RenameMonad12.hi b/ghc/compiler/rename/RenameMonad12.hi new file mode 100644 index 0000000..23bb01b --- /dev/null +++ b/ghc/compiler/rename/RenameMonad12.hi @@ -0,0 +1,32 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface RenameMonad12 where +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +infixr 9 `thenRn12` +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +type Rn12M a = _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) +addErrRn12 :: (PprStyle -> Int -> Bool -> PrettyRep) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LAL" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +foldrRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> b -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-} +getModuleNameRn12 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (_PackedString, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_2 [_PackedString, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1] _N_ #-} +initRn12 :: _PackedString -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 5 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> let {(u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _!_ _ORIG_ Bag EmptyBag [(PprStyle -> Int -> Bool -> PrettyRep)] []} in _APP_ u2 [ u1, u3 ] _N_ #-} +mapRn12 :: (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +recoverQuietlyRn12 :: a -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _N_ _N_ _N_ #-} +returnRn12 :: a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _PackedString) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u3] _N_ #-} +thenRn12 :: (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "SSLL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: u0 -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (u1, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: _PackedString) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> case _APP_ u2 [ u4, u5 ] of { _ALG_ _TUP_2 (u6 :: u0) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ u6, u4, u7 ]; _NO_DEFLT_ } _N_ #-} +zipWithRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (c, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> [b] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([c], Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LSS" _N_ _N_ #-} + diff --git a/ghc/compiler/rename/RenameMonad12.lhs b/ghc/compiler/rename/RenameMonad12.lhs new file mode 100644 index 0000000..b60f293 --- /dev/null +++ b/ghc/compiler/rename/RenameMonad12.lhs @@ -0,0 +1,98 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[RenameMonad12]{The monad used by the renamer passes 1 and 2} + +\begin{code} +#include "HsVersions.h" + +module RenameMonad12 ( + Rn12M(..), + initRn12, thenRn12, returnRn12, + mapRn12, zipWithRn12, foldrRn12, + addErrRn12, getModuleNameRn12, recoverQuietlyRn12, + + -- and to make the interface self-sufficient... + Bag, Pretty(..), PprStyle, PrettyRep + ) where + +import Bag +import Errors +import Outputable +import Pretty -- for type Pretty +import Util -- for pragmas only + +infixr 9 `thenRn12` +\end{code} + +In this monad, we pass down the name of the module we are working on, +and we thread the collected errors. + +\begin{code} +type Rn12M result + = FAST_STRING{-module name-} + -> Bag Error + -> (result, Bag Error) + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenRn12 #-} +{-# INLINE returnRn12 #-} +#endif + +initRn12 :: FAST_STRING{-module name-} -> Rn12M a -> (a, Bag Error) +initRn12 mod action = action mod emptyBag + +thenRn12 :: Rn12M a -> (a -> Rn12M b) -> Rn12M b +thenRn12 expr continuation mod errs_so_far + = case (expr mod errs_so_far) of + (res1, errs1) -> continuation res1 mod errs1 + +returnRn12 :: a -> Rn12M a +returnRn12 x mod errs_so_far = (x, errs_so_far) + +mapRn12 :: (a -> Rn12M b) -> [a] -> Rn12M [b] + +mapRn12 f [] = returnRn12 [] +mapRn12 f (x:xs) + = f x `thenRn12` \ r -> + mapRn12 f xs `thenRn12` \ rs -> + returnRn12 (r:rs) + +zipWithRn12 :: (a -> b -> Rn12M c) -> [a] -> [b] -> Rn12M [c] + +zipWithRn12 f [] [] = returnRn12 [] +zipWithRn12 f (x:xs) (y:ys) + = f x y `thenRn12` \ r -> + zipWithRn12 f xs ys `thenRn12` \ rs -> + returnRn12 (r:rs) + +foldrRn12 :: (a -> b -> Rn12M b) -> b -> [a] -> Rn12M b + +foldrRn12 f z [] = returnRn12 z +foldrRn12 f z (x:xs) + = foldrRn12 f z xs `thenRn12` \ rest -> + f x rest + +addErrRn12 :: Error -> Rn12M () +addErrRn12 err mod errs_so_far + = ( (), errs_so_far `snocBag` err ) + +getModuleNameRn12 :: Rn12M FAST_STRING +getModuleNameRn12 mod errs_so_far = (mod, errs_so_far) +\end{code} + +\begin{code} +recoverQuietlyRn12 :: a -> Rn12M a -> Rn12M a + +recoverQuietlyRn12 use_this_if_err action mod errs_so_far + = let + (result, errs_out) + = case (action mod emptyBag{-no errors-}) of { (res, errs) -> + if isEmptyBag errs then + (res, errs_so_far) -- retain incoming errs + else + (use_this_if_err, errs_so_far) + } + in + (result, errs_out) +\end{code} diff --git a/ghc/compiler/rename/RenameMonad3.hi b/ghc/compiler/rename/RenameMonad3.hi new file mode 100644 index 0000000..75a899f --- /dev/null +++ b/ghc/compiler/rename/RenameMonad3.hi @@ -0,0 +1,42 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface RenameMonad3 where +import FiniteMap(FiniteMap) +import HsImpExp(IE) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, Provenance) +import Outputable(ExportFlag) +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import SplitUniq(SplitUniqSupply, splitUniqSupply) +import SrcLoc(SrcLoc) +import Unique(Unique) +infixr 9 `thenRn3` +data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +andRn3 :: (a -> a -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 6 _U_ 111221 _N_ _S_ "SLLLLU(ALL)" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0 -> u0 -> u0) (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u3 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u4 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u5 :: _PackedString) (u6 :: SplitUniqSupply) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u7 :: Int) (u8 :: SplitUniqSupply) (u9 :: SplitUniqSupply) -> let {(ua :: u0) = _APP_ u2 [ u4, u5, u8 ]} in let {(ub :: u0) = _APP_ u3 [ u4, u5, u9 ]} in _APP_ u1 [ ua, ub ]; _NO_DEFLT_ } _N_ #-} +fixRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "SLLL" _F_ _IF_ARGS_ 1 4 XXXX 7 _/\_ u0 -> \ (u1 :: u0 -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u3 :: _PackedString) (u4 :: SplitUniqSupply) -> _LETREC_ {(u5 :: u0) = _APP_ u1 [ u5, u2, u3, u4 ]} in u5 _N_ #-} +initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mapRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> [a] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> [b] + {-# GHC_PRAGMA _A_ 2 _U_ 21222 _N_ _S_ "LS" _N_ _N_ #-} +newFullNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName) + {-# GHC_PRAGMA _A_ 7 _U_ 1211121 _N_ _N_ _N_ _N_ #-} +newInvisibleNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName) + {-# GHC_PRAGMA _A_ 7 _U_ 1211121 _N_ _N_ _N_ _N_ #-} +putInfoDownM3 :: _PackedString -> [IE] -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 6 _U_ 221002 _N_ _S_ "LLSAAL" {_A_ 4 _U_ 2212 _N_ _N_ _F_ _IF_ARGS_ 1 4 XXXX 7 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: [IE]) (u3 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u4 :: SplitUniqSupply) -> let {(u5 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) = _APP_ _ORIG_ HsImpExp getIEStrings [ u2 ]} in _APP_ u3 [ u5, u1, u4 ] _N_} _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: [IE]) (u3 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u4 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u5 :: _PackedString) (u6 :: SplitUniqSupply) -> let {(u7 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) = _APP_ _ORIG_ HsImpExp getIEStrings [ u2 ]} in _APP_ u3 [ u7, u1, u6 ] _N_ #-} +returnRn3 :: a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 4 _U_ 1000 _N_ _S_ "SLLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u3 :: _PackedString) (u4 :: SplitUniqSupply) -> u1 _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +thenRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b + {-# GHC_PRAGMA _A_ 5 _U_ 11221 _N_ _S_ "LSLLU(ALL)" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u3 :: u0 -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u1) (u4 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u5 :: _PackedString) (u6 :: SplitUniqSupply) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u7 :: Int) (u8 :: SplitUniqSupply) (u9 :: SplitUniqSupply) -> let {(ua :: u0) = _APP_ u2 [ u4, u5, u8 ]} in _APP_ u3 [ ua, u4, u5, u9 ]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/rename/RenameMonad3.lhs b/ghc/compiler/rename/RenameMonad3.lhs new file mode 100644 index 0000000..b9eddf9 --- /dev/null +++ b/ghc/compiler/rename/RenameMonad3.lhs @@ -0,0 +1,200 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[RenameMonad3]{The monad used by the third renamer pass} + +\begin{code} +#include "HsVersions.h" + +module RenameMonad3 ( + Rn3M(..), + initRn3, thenRn3, andRn3, returnRn3, mapRn3, fixRn3, + + putInfoDownM3, + + newFullNameM3, newInvisibleNameM3, + + -- for completeness + IE, FullName, ExportFlag, ProtoName, Unique, + SplitUniqSupply + IF_ATTACK_PRAGMAS(COMMA splitUniqSupply) + ) where + +import AbsSyn -- including, IE, getIEStrings, ... +import FiniteMap +import Maybes ( Maybe(..), assocMaybe ) +import NameTypes +import Outputable +import ProtoName +import RenameMonad4 ( GlobalNameFun(..) ) +import SplitUniq +import Unique +import Util + +infixr 9 `thenRn3` +\end{code} + +%************************************************************************ +%* * +\subsection{Plain @Rename3@ monadery} +%* * +%************************************************************************ + +\begin{code} +type Rn3M result + = ImExportListInfo -> FAST_STRING{-ModuleName-} -> SplitUniqSupply + -> result + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE andRn3 #-} +{-# INLINE thenRn3 #-} +{-# INLINE returnRn3 #-} +#endif + +initRn3 :: Rn3M a -> SplitUniqSupply -> a + +initRn3 m us = m (emptyFM,emptySet) (panic "initRn3: uninitialised module name") us + +thenRn3 :: Rn3M a -> (a -> Rn3M b) -> Rn3M b +andRn3 :: (a -> a -> a) -> Rn3M a -> Rn3M a -> Rn3M a + +thenRn3 expr continuation exps mod_name uniqs + = case splitUniqSupply uniqs of { (s1, s2) -> + case (expr exps mod_name s1) of { res1 -> + continuation res1 exps mod_name s2 }} + +andRn3 combiner m1 m2 exps mod_name uniqs + = case splitUniqSupply uniqs of { (s1, s2) -> + case (m1 exps mod_name s1) of { res1 -> + case (m2 exps mod_name s2) of { res2 -> + combiner res1 res2 }}} + +returnRn3 :: a -> Rn3M a +returnRn3 result exps mod_name uniqs = result + +mapRn3 :: (a -> Rn3M b) -> [a] -> Rn3M [b] + +mapRn3 f [] = returnRn3 [] +mapRn3 f (x:xs) + = f x `thenRn3` \ r -> + mapRn3 f xs `thenRn3` \ rs -> + returnRn3 (r:rs) + +fixRn3 :: (a -> Rn3M a) -> Rn3M a + +fixRn3 m exps mod_name us + = result + where + result = m result exps mod_name us + +putInfoDownM3 :: FAST_STRING{-ModuleName-} -> [IE] -> Rn3M a -> Rn3M a + +putInfoDownM3 mod_name exports cont _ _ uniqs + = cont (getIEStrings exports) mod_name uniqs +\end{code} + +%************************************************************************ +%* * +\subsection[RenameMonad3-new-names]{Making new names} +%* * +%************************************************************************ + +@newFullNameM3@ makes a new user-visible FullName (the usual); +@newInvisibleNameM3@ is the odd case. @new_name@ does all the work. + +\begin{code} +newFullNameM3, newInvisibleNameM3 + :: ProtoName -- input + -> SrcLoc -- where it started life + -> Bool -- if it is "TyCon"ish (rather than "val"ish) + -> Maybe ExportFlag -- Just flag => force the use of that exportness + -> Rn3M (Unique, FullName) + +newFullNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs + = new_name pn src_loc is_tycon_ish frcd_exp False{-visible-} exps mod_name uniqs + +newInvisibleNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs + = new_name pn src_loc is_tycon_ish frcd_exp True{-invisible-} exps mod_name uniqs +\end{code} + +\begin{code} +new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name uniqs + = (uniq, name) + where + uniq = getSUnique uniqs + + mk_name = if want_invisible then mkPrivateFullName else mkFullName + + name = case pn of + + Unk s -> mk_name mod_name s + (if fromPrelude mod_name + && is_tycon_ish then -- & tycon/clas/datacon => Core + HereInPreludeCore + else + ThisModule + ) + (case frcd_export_flag of + Just fl -> fl + Nothing -> mk_export_flag True [mod_name] s exps) + src_loc + + -- note: the assigning of prelude-ness is most dubious (ToDo) + + Imp m d informant_mods l + -> mk_name m d + (if fromPrelude m then -- as above + if is_tycon_ish then + ExportedByPreludeCore + else + OtherPrelude l + else if m == mod_name then -- pretty dang weird... (ToDo: anything?) + ThisModule + else + OtherModule l informant_mods -- for Other*, we save its occurrence name + ) + (case frcd_export_flag of + Just fl -> fl + Nothing -> mk_export_flag (m==mod_name) informant_mods l exps) + src_loc + + Prel n -> panic "RenameMonad3.new_name: prelude name" +\end{code} + +In deciding the ``exportness'' of something, there are these cases to +consider: +\begin{description} +\item[No explicit export list:] +Everything defined in this module goes out. + +\item[Matches a non-\tr{M..} item in the export list:] +Then it's exported as its @name_pr@ item suggests. + +\item[Matches a \tr{M..} item in the export list:] + +(Note: the module \tr{M} may be {\em this} module!) It's exported if +we got it from \tr{M}'s interface; {\em most emphatically not} the +same thing as ``it originally came from \tr{M}''. + +\item[Otherwise:] +It isn't exported. +\end{description} + +\begin{code} +mk_export_flag :: Bool -- True <=> originally from the module we're compiling + -> [FAST_STRING] -- modules that told us about this thing + -> FAST_STRING -- name of the thing we're looking at + -> ImExportListInfo + -> ExportFlag -- result + +mk_export_flag this_module informant_mods thing (exports_alist, dotdot_modules) + | isEmptyFM exports_alist && isEmptySet dotdot_modules + = if this_module then ExportAll else NotExported + + | otherwise + = case (lookupFM exports_alist thing) of + Just how_to_export -> how_to_export + Nothing -> if (or [ im `elementOf` dotdot_modules | im <- informant_mods ]) + then ExportAll + else NotExported +\end{code} diff --git a/ghc/compiler/rename/RenameMonad4.hi b/ghc/compiler/rename/RenameMonad4.hi new file mode 100644 index 0000000..a91e72f --- /dev/null +++ b/ghc/compiler/rename/RenameMonad4.hi @@ -0,0 +1,110 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface RenameMonad4 where +import AbsSyn(Module) +import Bag(Bag) +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import FiniteMap(FiniteMap) +import HsBinds(Binds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsPat(InPat, RenamedPat(..)) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..)) +import SplitUniq(SplitUniqSupply, splitUniqSupply) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +infixr 9 `thenRn4` +infixr 9 `thenRn4_` +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type RenamedPat = InPat Name +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type GlobalNameFun = ProtoName -> Labda Name +type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) +type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +type TyVarNamesEnv = [(ProtoName, Name)] +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +addErrRn4 :: (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2000200 _N_ _S_ "LAAALAA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 9 \ (u0 :: PprStyle -> Int -> Bool -> PrettyRep) (u1 :: GlobalSwitch -> Bool) (u2 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u3 :: FiniteMap _PackedString Name) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SplitUniqSupply) (u6 :: SrcLoc) -> let {(u7 :: ()) = _!_ _TUP_0 [] []} in let {(u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ u4, u0 ]} in _!_ _TUP_2 [(), (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u7, u8] _N_ #-} +andRn4 :: (a -> a -> a) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 9 _U_ 111222212 _N_ _S_ "LSSLLLLU(ALL)L" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0 -> u0 -> u0) (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: GlobalSwitch -> Bool) (u5 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u6 :: FiniteMap _PackedString Name) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SplitUniqSupply) (u9 :: SrcLoc) -> case u8 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, u7, ub, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> case _APP_ u3 [ u4, u5, u6, ue, uc, u9 ] of { _ALG_ _TUP_2 (uf :: u0) (ug :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> let {(uh :: u0) = _APP_ u1 [ ud, uf ]} in _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [uh, ug]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +catTyVarNamesEnvs :: [(ProtoName, Name)] -> [(ProtoName, Name)] -> [(ProtoName, Name)] + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ PreludeList (++) { (ProtoName, Name) } _N_ #-} +domTyVarNamesEnv :: [(ProtoName, Name)] -> [ProtoName] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extendSS :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 11222222 _N_ _S_ "LSSLLLLL" _N_ _N_ #-} +extendSS2 :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 21222222 _N_ _S_ "LSSLLLLL" _N_ _N_ #-} +failButContinueRn4 :: a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22000200 _N_ _S_ "LLAAALAA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: u0) (u2 :: PprStyle -> Int -> Bool -> PrettyRep) (u3 :: GlobalSwitch -> Bool) (u4 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u5 :: FiniteMap _PackedString Name) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SplitUniqSupply) (u8 :: SrcLoc) -> let {(u9 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ u6, u2 ]} in _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u9] _N_ #-} +getSrcLocRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (SrcLoc, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 000202 _N_ _S_ "AAALAL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u1 :: SrcLoc) -> _!_ _TUP_2 [SrcLoc, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u0] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u2 :: FiniteMap _PackedString Name) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) -> _!_ _TUP_2 [SrcLoc, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u5, u3] _N_ #-} +getSwitchCheckerRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> Bool, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 200200 _N_ _S_ "LAALAA" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_2 [(GlobalSwitch -> Bool), (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u2 :: FiniteMap _PackedString Name) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) -> _!_ _TUP_2 [(GlobalSwitch -> Bool), (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u3] _N_ #-} +initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLSL" _N_ _N_ #-} +lookupClass :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2010202 _N_ _S_ "LAU(AS)ALAL" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupClassOp :: Name -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22010202 _N_ _S_ "LLAU(SA)ALAL" {_A_ 5 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupFixityOp :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 2012222 _N_ _S_ "SAU(LA)" {_A_ 2 _U_ 212222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupTyCon :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2010212 _N_ _S_ "SALALU(AAA)L" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupTyConEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2010202 _N_ _S_ "SALALAL" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupTyVarName :: [(ProtoName, Name)] -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 12000212 _N_ _S_ "SLAAALLL" {_A_ 5 _U_ 12212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupValue :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2012212 _N_ _S_ "SAU(LA)LLU(AAA)L" {_A_ 5 _U_ 21222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupValueEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2012202 _N_ _S_ "SAU(LA)LLAL" {_A_ 5 _U_ 21222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mapAndUnzipRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((b, c), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([b], [c]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +mapRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +mkTyVarNamesEnv :: SrcLoc -> [ProtoName] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([(ProtoName, Name)], [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22222212 _N_ _S_ "LSLLLLU(ASA)L" _N_ _N_ #-} +namesFromProtoNames :: [Char] -> [(ProtoName, SrcLoc)] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([Name], Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22222212 _N_ _S_ "LSLLLLU(ALS)L" _N_ _N_ #-} +nullTyVarNamesEnv :: [(ProtoName, Name)] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(ProtoName, Name)] [] _N_ #-} +pushSrcLocRn4 :: SrcLoc -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 21222220 _N_ _S_ "LSLLLLLA" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: GlobalSwitch -> Bool) (u4 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u5 :: FiniteMap _PackedString Name) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SplitUniqSupply) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: GlobalSwitch -> Bool) (u4 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u5 :: FiniteMap _PackedString Name) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SplitUniqSupply) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_ #-} +recoverQuietlyRn4 :: a -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 21222222 _N_ _N_ _N_ _N_ #-} +returnRn4 :: a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2000200 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u4 :: FiniteMap _PackedString Name) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SplitUniqSupply) (u7 :: SrcLoc) -> _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u5] _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +thenRn4 :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 11222212 _N_ _S_ "SSLLLLU(ALL)L" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: u0 -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u1, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: GlobalSwitch -> Bool) (u5 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u6 :: FiniteMap _PackedString Name) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SplitUniqSupply) (u9 :: SrcLoc) -> case u8 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, u7, ub, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ ud, u4, u5, u6, ue, uc, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +thenRn4_ :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 11222212 _N_ _S_ "SSLLLLU(ALL)L" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u1, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: GlobalSwitch -> Bool) (u5 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u6 :: FiniteMap _PackedString Name) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SplitUniqSupply) (u9 :: SrcLoc) -> case u8 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, u7, ub, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ u4, u5, u6, ue, uc, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/rename/RenameMonad4.lhs b/ghc/compiler/rename/RenameMonad4.lhs new file mode 100644 index 0000000..7252397 --- /dev/null +++ b/ghc/compiler/rename/RenameMonad4.lhs @@ -0,0 +1,480 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[RenameMonad4]{The monad used by the fourth renamer pass} + +\begin{code} +#include "HsVersions.h" + +module RenameMonad4 ( + Rn4M(..), + initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4, + addErrRn4, failButContinueRn4, recoverQuietlyRn4, + pushSrcLocRn4, + getSrcLocRn4, + getSwitchCheckerRn4, + lookupValue, lookupValueEvenIfInvisible, + lookupClassOp, lookupFixityOp, + lookupTyCon, lookupTyConEvenIfInvisible, + lookupClass, + extendSS2, extendSS, + namesFromProtoNames, + + TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, + lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, + + -- for completeness + Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..), + Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch, + GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc, + Unique, SplitUniqSupply + IF_ATTACK_PRAGMAS(COMMA splitUniqSupply) + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty +import Outputable + +import AbsSyn +import Bag +import CmdLineOpts ( GlobalSwitch(..) ) +import Errors ( dupNamesErr, unknownNameErr, shadowedNameErr, + badClassOpErr, Error(..) + ) +import FiniteMap ( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap ) +import Maybes ( Maybe(..), assocMaybe ) +import Name ( isTyConName, isClassName, isClassOpName, + isUnboundName, invisibleName + ) +import NameTypes ( mkShortName, ShortName ) +import ProtoName -- lots of stuff +import RenameAuxFuns -- oh, why not ... all of it +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import SplitUniq +import UniqSet +import Unique +import Util + +infixr 9 `thenRn4`, `thenRn4_` +\end{code} + +%************************************************************************ +%* * +\subsection[RenameMonad]{Plain @Rename@ monadery} +%* * +%************************************************************************ + +\begin{code} +type ScopeStack = FiniteMap FAST_STRING Name + +type Rn4M result + = (GlobalSwitch -> Bool) + -> GlobalNameFuns + -> ScopeStack + -> Bag Error + -> SplitUniqSupply + -> SrcLoc + -> (result, Bag Error) + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE andRn4 #-} +{-# INLINE thenRn4 #-} +{-# INLINE thenRn4_ #-} +{-# INLINE returnRn4 #-} +#endif + +initRn4 :: (GlobalSwitch -> Bool) + -> GlobalNameFuns + -> Rn4M result + -> SplitUniqSupply + -> (result, Bag Error) + +initRn4 sw_chkr gnfs renamer init_us + = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc + +thenRn4 :: Rn4M a -> (a -> Rn4M b) -> Rn4M b +thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b +andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a + +thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn + = case (splitUniqSupply uniqs) of { (s1, s2) -> + case (expr sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) -> + case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) -> + (res2, errs2) }}} + +thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn + = case (splitUniqSupply uniqs) of { (s1, s2) -> + case (expr sw_chkr gnfs ss errs s1 locn) of { (_, errs1) -> + case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) -> + (res2, errs2) }}} + +andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn + = case (splitUniqSupply us) of { (s1, s2) -> + case (m1 sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) -> + case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) -> + (combiner res1 res2, errs2) }}} + +returnRn4 :: a -> Rn4M a +returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn + = (result, errs_so_far) + +failButContinueRn4 :: a -> Error -> Rn4M a +failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn + = (res, errs_so_far `snocBag` err) + +addErrRn4 :: Error -> Rn4M () +addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn + = ((), errs_so_far `snocBag` err) +\end{code} + +When we're looking at interface pragmas, we want to be able to recover +back to a ``I don't know anything pragmatic'' state if we encounter +some problem. @recoverQuietlyRn4@ is given a ``use-this-instead'' value, +as well as the action to perform. This code is intentionally very lazy, +returning a triple immediately, no matter what. +\begin{code} +recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a + +recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn + = let + (result, errs_out) + = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of + (result1, errs1) -> + if isEmptyBag errs1 then -- all's well! (but retain incoming errs) + (result1, errs_so_far) + else -- give up; return *incoming* UniqueSupply... + (use_this_if_err, + if sw_chkr ShowPragmaNameErrs + then errs_so_far `unionBags` errs1 + else errs_so_far) -- toss errs, otherwise + in + (result, errs_out) +\end{code} + +\begin{code} +mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b] + +mapRn4 f [] = returnRn4 [] +mapRn4 f (x:xs) + = f x `thenRn4` \ r -> + mapRn4 f xs `thenRn4` \ rs -> + returnRn4 (r:rs) + +mapAndUnzipRn4 :: (a -> Rn4M (b,c)) -> [a] -> Rn4M ([b],[c]) + +mapAndUnzipRn4 f [] = returnRn4 ([],[]) +mapAndUnzipRn4 f (x:xs) + = f x `thenRn4` \ (r1, r2) -> + mapAndUnzipRn4 f xs `thenRn4` \ (rs1, rs2) -> + returnRn4 (r1:rs1, r2:rs2) +\end{code} + +\begin{code} +pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a +pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn + = exp sw_chkr gnfs ss errs_so_far uniq_supply locn + +getSrcLocRn4 :: Rn4M SrcLoc + +getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn + = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn + +getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool) + +getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn + = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn +\end{code} + +\begin{code} +getNextUniquesFromRn4 :: Int -> Rn4M [Unique] +getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn + = case (getSUniques n us) of { next_uniques -> + (next_uniques, errs_so_far) } +\end{code} + +********************************************************* +* * +\subsection{Making new names} +* * +********************************************************* + +@namesFromProtoNames@ takes a bunch of protonames, which are defined +together in a group (eg a pattern or set of bindings), checks they +are distinct, and creates new full names for them. + +\begin{code} +namesFromProtoNames :: String -- Documentation string + -> [(ProtoName, SrcLoc)] + -> Rn4M [Name] + +namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn + = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_` + mkNewNames goodies + ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + where + (goodies, dups) = removeDups cmp pnames_w_src_loc + -- We want to compare their local names rather than their + -- full protonames. It probably doesn't matter here, but it + -- does in Rename3.lhs! + cmp (a, _) (b, _) = cmpByLocalName a b +\end{code} + +@mkNewNames@ assumes the names are unique. + +\begin{code} +mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name] +mkNewNames pnames_w_locs + = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs -> + returnRn4 (zipWith new_short_name uniqs pnames_w_locs) + where + new_short_name uniq (Unk str, srcloc) -- gotta be an Unk... + = Short uniq (mkShortName str srcloc) +\end{code} + + +********************************************************* +* * +\subsection{Local scope extension and lookup} +* * +********************************************************* + +If the input name is an @Imp@, @lookupValue@ looks it up in the GNF. +If it is an @Unk@, it looks it up first in the local environment +(scope stack), and if it isn't found there, then in the value GNF. If +it isn't found at all, @lookupValue@ adds an error message, and +returns an @Unbound@ name. + +\begin{code} +unboundName :: ProtoName -> Name +unboundName pn + = Unbound (grab_string pn) + where + grab_string (Unk s) = s + grab_string (Imp _ _ _ s) = s +\end{code} + +@lookupValue@ looks up a non-invisible value; +@lookupValueEvenIfInvisible@ gives a successful lookup even if the +value is not visible to the user (e.g., came out of a pragma). +@lookup_val@ is the help function to do the work. + +\begin{code} +lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + = (lookup_val v `thenRn4` \ name -> + if invisibleName name + then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc) + else returnRn4 name + ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + +lookupValueEvenIfInvisible v = lookup_val v + +lookup_val :: ProtoName -> Rn4M Name + +lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn + = case (lookupFM ss v) of + Just name -> returnRn4 name sw_chkr gnfs ss a b locn + Nothing -> case (v_gnf pname) of + Just name -> returnRn4 name sw_chkr gnfs ss a b locn + Nothing -> failButContinueRn4 (unboundName pname) + (unknownNameErr "value" pname locn) + sw_chkr gnfs ss a b locn + +-- If it ain't an Unk it must be in the global name fun; that includes +-- prelude things. +lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn + = case (v_gnf pname) of + Just name -> returnRn4 name sw_chkr gnfs ss a b locn + Nothing -> failButContinueRn4 (unboundName pname) + (unknownNameErr "value" pname locn) + sw_chkr gnfs ss a b locn +\end{code} + +Looking up the operators in a fixity decl is done differently. We +want to simply drop any fixity decls which refer to operators which +aren't in scope. Unfortunately, such fixity decls {\em will} appear +because the parser collects *all* the fixity decls from {\em all} the +imported interfaces (regardless of selective import), and dumps them +together as the module fixity decls. This is really a bug. In +particular: +\begin{itemize} +\item +We won't complain about fixity decls for operators which aren't +declared. +\item +We won't attach the right fixity to something which has been renamed. +\end{itemize} + +We're not going to export Prelude-related fixities (ToDo: correctly), +so we nuke those, too. + +\begin{code} +lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing sw_chkr gnfs +lookupFixityOp pname sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs +\end{code} + +\begin{code} +lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name +-- The global name funs handle Prel things + +lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + = (lookup_tycon tc `thenRn4` \ name -> + if invisibleName name + then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc) + else returnRn4 name + ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + +lookupTyConEvenIfInvisible tc = lookup_tycon tc + +lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn + +lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn + = case (tc_gnf pname) of + Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn + _ -> failButContinueRn4 (unboundName pname) + (unknownNameErr "type constructor" pname locn) + sw_chkr gnfs ss a b locn +\end{code} + +\begin{code} +lookupClass :: ProtoName -> Rn4M Name + +lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn + = case (tc_gnf pname) of + Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn + _ -> failButContinueRn4 (unboundName pname) + (unknownNameErr "class" pname locn) + sw_chkr gnfs ss a b locn +\end{code} + +@lookupClassOp@ is used when looking up the lhs identifiers in a class +or instance decl. It checks that the name it finds really is a class +op, and that its class matches that of the class or instance decl +being looked at. + +\begin{code} +lookupClassOp :: Name -> ProtoName -> Rn4M Name + +lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn + = case v_gnf pname of + Just op_name | isClassOpName class_name op_name + || isUnboundName class_name -- avoid spurious errors + -> returnRn4 op_name sw_chkr gnfs ss a b locn + + other -> failButContinueRn4 (unboundName pname) + (badClassOpErr class_name pname locn) + sw_chkr gnfs ss a b locn +\end{code} + +@extendSS@ extends the scope; @extendSS2@ also removes the newly bound +free vars from the result. + +\begin{code} +extendSS :: [Name] -- Newly bound names + -> Rn4M a + -> Rn4M a + +extendSS binders expr sw_chkr gnfs ss errs us locn + = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) -> + expr sw_chkr gnfs new_ss new_errs us locn } + where + extend :: [Name] -> ScopeStack -> Rn4M ScopeStack + + extend names ss + = if (sw_chkr NameShadowingNotOK) then + hard_way names ss + else -- ignore shadowing; blast 'em in + returnRn4 ( + addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names] + ) + + hard_way [] ss = returnRn4 ss + hard_way (name@(Short _ sname):names) ss + = let + str = getOccurrenceName sname + in + (case (lookupFM ss str) of + Nothing -> returnRn4 (addToFM ss str name) + Just _ -> failButContinueRn4 ss (shadowedNameErr name locn) + + ) `thenRn4` \ new_ss -> + hard_way names new_ss + +extendSS2 :: [Name] -- Newly bound names + -> Rn4M (a, UniqSet Name) + -> Rn4M (a, UniqSet Name) + +extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn + = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of + ((e2, freevars), errs) + -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)), + errs) +\end{code} + +The free var set returned by @(extendSS binders m)@ is that returned +by @m@, {\em minus} binders. + +********************************************************* +* * +\subsection{mkTyVarNamesEnv} +* * +********************************************************* + +\begin{code} +type TyVarNamesEnv = [(ProtoName, Name)] + +nullTyVarNamesEnv :: TyVarNamesEnv +nullTyVarNamesEnv = [] + +catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv +catTyVarNamesEnvs e1 e2 = e1 ++ e2 + +domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName] +domTyVarNamesEnv env = map fst env +\end{code} + +@mkTyVarNamesEnv@ checks for duplicates, and complains if so. + +\begin{code} +mkTyVarNamesEnv + :: SrcLoc + -> [ProtoName] -- The type variables + -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars + +mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + = (namesFromProtoNames "type variable" + (tyvars `zip` repeat src_loc) `thenRn4` \ tyvars2 -> + + -- tyvars2 may not be in the same order as tyvars, so we need some + -- jiggery pokery to build the right tyvar env, and return the + -- renamed tyvars in the original order. + let tv_string_name_pairs = extend tyvars2 [] + tv_env = map (lookup tv_string_name_pairs) tyvars + tyvars2_in_orig_order = map snd tv_env + in + returnRn4 (tv_env, tyvars2_in_orig_order) + ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + where + extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)] + extend [] ss = ss + extend (name@(Short _ sname):names) ss + = (getOccurrenceName sname, name) : extend names ss + + lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name) + lookup pairs tyvar_pn + = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn)) +\end{code} + +\begin{code} +lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name +lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + = (case (assoc_maybe env pname) of + Just name -> returnRn4 name + Nothing -> getSrcLocRn4 `thenRn4` \ loc -> + failButContinueRn4 (unboundName pname) + (unknownNameErr "type variable" pname loc) + ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn + where + assoc_maybe [] _ = Nothing + assoc_maybe ((tv,xxx) : tvs) key + = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key +\end{code} diff --git a/ghc/compiler/root.lit b/ghc/compiler/root.lit new file mode 100644 index 0000000..120cdad --- /dev/null +++ b/ghc/compiler/root.lit @@ -0,0 +1,115 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Glasgow Haskell Compiler Sources} + +\author{The GRASP Team} +} +\date{February 1991} +\maketitle +\tableofcontents +\end{onlystandalone} + +#\input{main/Main.lhs} + +#\section[prefix_form_reader]{Reader} +#\downsection +#\input{reader/ReaderIntermForm.lhs} +#\input{reader/ReaderIntermSyntax.lhs} +#\input{reader/RIFToHaskell.lhs} +#\upsection +# +#\section[Names]{Things to do with names} +#\downsection +#\input{names/Names.lhs} +#\input{names/NameSupply.lhs} +#\input{names/UniqInts.lhs} +#\input{names/NameSupplyMonad.lhs} +#\input{names/SpecialStrings.lhs} +#\upsection +# +#\section[AbsSyntax_stuff]{Abstract syntax stuff} +#\downsection +#\input{absSyntax/AbsSyntax.lhs} +#\input{absSyntax/PrintAbsSyntax.lhs} +#\input{absSyntax/PrettyAbsSyntax.lhs} +#\input{absSyntax/UniType.lhs} +#\input{absSyntax/PrintUniType.lhs} +#\input{absSyntax/PrettyUniType.lhs} +#\input{absSyntax/TypeFuns.lhs} +#\input{absSyntax/AbsSyntaxRepFuns.lhs} +#\upsection +# +#\section[Error_reporting]{Error reporting things} +#\downsection +#\input{errors/Error.lhs} +#\upsection +# +#\section[Dependency_analysis]{Dependency analysis} +#\downsection +#\input{depanal/Depend.lhs} +#\input{depanal/StronglyConnComp.lhs} +#\upsection +# +#\input{typecheck/root.lit} +# +#\section[SyntaxPrimitives_stuff]{Basic syntax stuff} +#\downsection +#\input{syntaxPrims/SyntaxPrimitives.lhs} +#\input{syntaxPrims/PrintSyntaxPrims.lhs} +#\input{syntaxPrims/SyntaxConstants.lhs} +#\input{syntaxPrims/SyntaxConstants.lh} +#\upsection +# +#\section[CoreSyntax_stuff]{CoreSyntax syntax stuff} +#\downsection +#\input{coreSyntax/CoreSyntax.lhs} +#\input{coreSyntax/PrintCoreSyntax.lhs} +#\input{coreSyntax/AnnCoreSyntax.lhs} +#\upsection +# +#\input{deSugar/root.lit} +# +#\section[Simplify_stuff]{Simplifying core expressions} +#\downsection +#\input{simplify/Simplify.lhs} +#\upsection +# +#\section[Lambda_lifting]{A simple lambda-lifter} +#\downsection +#\input{llift/LambdaLift.lhs} +#\upsection +# +#\section[core-to-stg-conversion]{Converting core syntax to STG syntax} +#\downsection +#\input{core2stg/CoreToStg.lhs} +#\upsection + +\section[stg-syntax]{The STG syntax} +\downsection +\input{stgSyntax/StgSyntax.lhs} +\input{stgSyntax/PrintStgSyntax.lhs} +\upsection + +\input{codeGen/root.lit} + +#\section[abstract-C-syntax]{Abstract C syntax} +#\downsection +#\input{absCSyntax/AbstractC.lhs} +#\input{absCSyntax/FlattenAbsC.lhs} +#\input{absCSyntax/PrintAbstractC.lhs} +#\input{absCSyntax/AbsToRealC.lhs} +#\upsection + +#\section[Utility_functions]{Utility functions} +#\downsection +#\input{utils/Util.lhs} +#\input{utils/Util2.lhs} +#\input{utils/Pretty.lhs} +#\input{utils/Set.lhs} +#\upsection + +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/simplCore/AnalFBWW.hi b/ghc/compiler/simplCore/AnalFBWW.hi new file mode 100644 index 0000000..d6fdc36 --- /dev/null +++ b/ghc/compiler/simplCore/AnalFBWW.hi @@ -0,0 +1,8 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AnalFBWW where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import Id(Id) +analFBWW :: (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs new file mode 100644 index 0000000..ac9414d --- /dev/null +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -0,0 +1,253 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[AnalFBWW]{Spoting good functions for splitting into workers/wrappers} + +\begin{code} +#include "HsVersions.h" + +module AnalFBWW ( analFBWW ) where + +IMPORT_Trace +import Outputable +import Pretty + +import PlainCore +import TaggedCore +import Util +import Id ( addIdFBTypeInfo ) +import IdInfo +import IdEnv +import AbsPrel ( foldrId, buildId, + nilDataCon, consDataCon, mkListTy, mkFunTy, + unpackCStringAppendId + ) +import BinderInfo +import SimplEnv -- everything +import NewOccurAnal +import Maybes + +\end{code} + +\begin{code} +analFBWW + :: (GlobalSwitch -> Bool) + -> PlainCoreProgram + -> PlainCoreProgram +analFBWW switch top_binds = trace "ANALFBWW" (snd anno) + where + anals :: [InBinding] + anals = newOccurAnalyseBinds top_binds switch (const False) + anno = mapAccumL annotateBindingFBWW nullIdEnv anals +\end{code} + +\begin{code} +data OurFBType + = IsFB FBType + | IsNotFB -- unknown + | IsCons -- \ xy -> (:) ty xy + | IsBottom -- _|_ + deriving (Eq) + -- We only handle *reasonable* types + -- Later might add concept of bottom + -- because foldr f z () = +unknownFBType = IsNotFB +goodProdFBType = IsFB (FBType [] FBGoodProd) + +maybeFBtoFB (Just ty) = ty +maybeFBtoFB (Nothing) = IsNotFB + +addArgs :: Int -> OurFBType -> OurFBType +addArgs n (IsFB (FBType args prod)) + = IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod) +addArgs n IsNotFB = IsNotFB +addArgs n IsCons = panic "adding argument to a cons" +addArgs n IsBottom = IsNotFB + +rmArg :: OurFBType -> OurFBType +rmArg (IsFB (FBType [] prod)) = IsNotFB -- panic "removing argument from producer" +rmArg (IsFB (FBType args prod)) = IsFB (FBType (tail args) prod) +rmArg IsBottom = IsBottom +rmArg _ = IsNotFB + +joinFBType :: OurFBType -> OurFBType -> OurFBType +joinFBType (IsBottom) a = a +joinFBType a (IsBottom) = a +joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod')) + | length args == length args' = (IsFB (FBType (zipWith argJ args args') + (prodJ prod prod'))) + where + argJ FBGoodConsum FBGoodConsum = FBGoodConsum + argJ _ _ = FBBadConsum + prodJ FBGoodProd FBGoodProd = FBGoodProd + prodJ _ _ = FBBadProd + +joinFBType _ _ = IsNotFB + +-- +-- Mutter :: IdEnv FBType need to be in an *inlinable* context. +-- + +analExprFBWW :: InExpr -> IdEnv OurFBType -> OurFBType + +-- +-- [ build g ] is a good context +-- +analExprFBWW (CoApp (CoTyApp (CoVar bld) _) _) env + | bld == buildId = goodProdFBType + +-- +-- [ foldr (:) ys xs ] ==> good +-- (but better if xs) +-- +analExprFBWW (CoApp (CoApp (CoApp + (CoTyApp (CoTyApp (CoVar foldr_id) _) _) (CoVarAtom c)) _) _) + env + | pprTrace ("FOLDR:" ++ show (foldr_id == foldrId,isCons c)) + (ppr PprDebug foldr_id) + (foldr_id == foldrId && isCons c) = goodProdFBType + where + isCons c = case lookupIdEnv env c of + Just IsCons -> True + _ -> False +analExprFBWW (CoVar v) env = maybeFBtoFB (lookupIdEnv env v) +analExprFBWW (CoLit _) _ = unknownFBType + +-- +-- [ x : xs ] ==> good iff [ xs ] is good +-- + +analExprFBWW (CoCon con _ [_,CoVarAtom y]) env + | con == consDataCon = maybeFBtoFB (lookupIdEnv env y) +-- +-- [] is good +-- +analExprFBWW (CoCon con _ []) _ + | con == nilDataCon = goodProdFBType +analExprFBWW (CoCon _ _ _) _ = unknownFBType +analExprFBWW (CoPrim _ _ _) _ = unknownFBType + +-- \ xy -> (:) ty xy == a CONS +analExprFBWW (CoLam [(x,_),(y,_)] + (CoCon con _ [CoVarAtom x',CoVarAtom y'])) env + | con == consDataCon && x == x' && y == y' + = IsCons +analExprFBWW (CoLam ids e) env + = addArgs (length ids) (analExprFBWW e (delManyFromIdEnv env (map fst ids))) +analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env +analExprFBWW (CoApp f atom) env = rmArg (analExprFBWW f env) +analExprFBWW (CoTyApp f ty) env = analExprFBWW f env +analExprFBWW (CoSCC lab e) env = analExprFBWW e env +analExprFBWW (CoLet binds e) env = analExprFBWW e (analBind binds env) +analExprFBWW (CoCase e alts) env = foldl1 joinFBType (analAltsFBWW alts env) + +analAltsFBWW (CoAlgAlts alts deflt) env = + case analDefFBWW deflt env of + Just ty -> ty : tys + Nothing -> tys + where + tys = map (\(con,binders,e) -> analExprFBWW e (delManyFromIdEnv env (map fst binders))) alts +analAltsFBWW (CoPrimAlts alts deflt) env = + case analDefFBWW deflt env of + Just ty -> ty : tys + Nothing -> tys + where + tys = map (\(lit,e) -> analExprFBWW e env) alts + + +analDefFBWW CoNoDefault env = Nothing +analDefFBWW (CoBindDefault v e) env = Just (analExprFBWW e (delOneFromIdEnv env (fst v))) +\end{code} + + +Only add a type info if: + +1. Is a functionn. +2. Is an inlineable object. + +\begin{code} +analBindExpr :: BinderInfo -> InExpr -> IdEnv OurFBType -> OurFBType +analBindExpr bnd expr env = + case analExprFBWW expr env of + IsFB ty@(FBType [] _) -> + if oneSafeOcc False bnd + then IsFB ty + else IsNotFB + other -> other + +analBind :: InBinding -> IdEnv OurFBType -> IdEnv OurFBType +analBind (CoNonRec (v,bnd) e) env = + case analBindExpr bnd e env of + ty@(IsFB _) -> addOneToIdEnv env v ty + ty@(IsCons) -> addOneToIdEnv env v ty + _ -> delOneFromIdEnv env v -- remember about shadowing! + +analBind (CoRec binds) env = + let + first_set = [ (v,IsFB (FBType [FBBadConsum | _ <- args ] FBGoodProd)) | ((v,_),e) <- binds, + (_,args,_) <- [digForLambdas e]] + env' = delManyFromIdEnv env (map (fst.fst) binds) + in + growIdEnvList env' (fixpoint 0 binds env' first_set) + +fixpoint :: Int -> [(InBinder,InExpr)] -> IdEnv OurFBType -> [(Id,OurFBType)] -> [(Id,OurFBType)] +fixpoint n binds env maps = + if maps == maps' + then maps + else fixpoint (n+1) binds env maps' + where + env' = growIdEnvList env maps + maps' = [ (v,ty) | ((v,bind),e) <- binds, + (ty@(IsFB (FBType cons prod))) <- [analBindExpr bind e env']] + +\end{code} + + +\begin{code} +annotateExprFBWW :: InExpr -> IdEnv OurFBType -> PlainCoreExpr +annotateExprFBWW (CoVar v) env = CoVar v +annotateExprFBWW (CoLit i) env = CoLit i +annotateExprFBWW (CoCon c t a) env = CoCon c t a +annotateExprFBWW (CoPrim p t a) env = CoPrim p t a +annotateExprFBWW (CoLam ids e) env = CoLam ids' (annotateExprFBWW e (delManyFromIdEnv env ids')) + where ids' = map fst ids +annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env) +annotateExprFBWW (CoApp f atom) env = CoApp (annotateExprFBWW f env) atom +annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty +annotateExprFBWW (CoSCC lab e) env = CoSCC lab (annotateExprFBWW e env) +annotateExprFBWW (CoCase e alts) env = CoCase (annotateExprFBWW e env) + (annotateAltsFBWW alts env) +annotateExprFBWW (CoLet bnds e) env = CoLet bnds' (annotateExprFBWW e env') + where + (env',bnds') = annotateBindingFBWW env bnds + +annotateAltsFBWW (CoAlgAlts alts deflt) env = CoAlgAlts alts' deflt' + where + alts' = [ let + binders' = map fst binders + in (con,binders',annotateExprFBWW e (delManyFromIdEnv env binders')) + | (con,binders,e) <- alts ] + deflt' = annotateDefFBWW deflt env +annotateAltsFBWW (CoPrimAlts alts deflt) env = CoPrimAlts alts' deflt' + where + alts' = [ (lit,annotateExprFBWW e env) | (lit,e) <- alts ] + deflt' = annotateDefFBWW deflt env + +annotateDefFBWW CoNoDefault env = CoNoDefault +annotateDefFBWW (CoBindDefault v e) env + = CoBindDefault (fst v) (annotateExprFBWW e (delOneFromIdEnv env (fst v))) + +annotateBindingFBWW :: IdEnv OurFBType -> InBinding -> (IdEnv OurFBType,PlainCoreBinding) +annotateBindingFBWW env bnds = (env',bnds') + where + env' = analBind bnds env + bnds' = case bnds of + CoNonRec (v,_) e -> CoNonRec (fixId v) (annotateExprFBWW e env) + CoRec bnds -> CoRec [ (fixId v,annotateExprFBWW e env') | ((v,_),e) <- bnds ] + fixId v = + (case lookupIdEnv env' v of + Just (IsFB ty@(FBType xs p)) + | not (null xs) -> pprTrace "ADDED to:" (ppr PprDebug v) + (addIdFBTypeInfo v (mkFBTypeInfo ty)) + _ -> v) +\end{code} diff --git a/ghc/compiler/simplCore/BinderInfo.hi b/ghc/compiler/simplCore/BinderInfo.hi new file mode 100644 index 0000000..3bad6eb --- /dev/null +++ b/ghc/compiler/simplCore/BinderInfo.hi @@ -0,0 +1,39 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface BinderInfo where +import Outputable(Outputable) +data BinderInfo = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int +data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-} +data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-} +data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-} +argOccurrence :: Int -> BinderInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +combineAltsBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +combineBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +funOccurrence :: Int -> BinderInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +getBinderInfoArity :: BinderInfo -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: BinderInfo) -> case u0 of { _ALG_ _ORIG_ BinderInfo DeadCode -> _!_ I# [] [0#]; _ORIG_ BinderInfo ManyOcc (u1 :: Int) -> u1; _ORIG_ BinderInfo OneOcc (u2 :: FunOrArg) (u3 :: DuplicationDanger) (u4 :: InsideSCC) (u5 :: Int) (u6 :: Int) -> u6; _NO_DEFLT_ } _N_ #-} +inlineUnconditionally :: Bool -> BinderInfo -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +isDupDanger :: DuplicationDanger -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: DuplicationDanger) -> case u0 of { _ALG_ _ORIG_ BinderInfo NoDupDanger -> _!_ False [] []; _ORIG_ BinderInfo DupDanger -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} +isFun :: FunOrArg -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FunOrArg) -> case u0 of { _ALG_ _ORIG_ BinderInfo ArgOcc -> _!_ False [] []; _ORIG_ BinderInfo FunOcc -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} +markDangerousToDup :: BinderInfo -> BinderInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +markInsideSCC :: BinderInfo -> BinderInfo + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +markMany :: BinderInfo -> BinderInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +oneSafeOcc :: Bool -> BinderInfo -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +oneTextualOcc :: Bool -> BinderInfo -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +setBinderInfoArityToZero :: BinderInfo -> BinderInfo + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +instance Outputable BinderInfo + {-# GHC_PRAGMA _M_ BinderInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BinderInfo) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs new file mode 100644 index 0000000..d899916 --- /dev/null +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -0,0 +1,238 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[BinderInfo]{Information attached to binders by SubstAnal} +%* * +%************************************************************************ + +\begin{code} + +#include "HsVersions.h" + +module BinderInfo ( + BinderInfo(..), + FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!) + + inlineUnconditionally, oneTextualOcc, oneSafeOcc, + + combineBinderInfo, combineAltsBinderInfo, + + argOccurrence, funOccurrence, + markMany, markDangerousToDup, markInsideSCC, + getBinderInfoArity, + setBinderInfoArityToZero, + + isFun, isDupDanger -- for Simon Marlow deforestation + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import PlainCore +import Outputable +import Pretty +import Util -- for pragmas only +\end{code} + +The @BinderInfo@ describes how a variable is used in a given scope. + +NOTE: With SCCs we have to be careful what we unfold! We don't want to +change the attribution of execution costs. If we decide to unfold +within an SCC we can tag the definition as @DontKeepBinder@. +Definitions tagged as @KeepBinder@ are discarded when we enter the +scope of an SCC. + +\begin{code} +data BinderInfo + = DeadCode -- Dead code; discard the binding. + + | ManyOcc -- Everything else besides DeadCode and OneOccs + + Int -- number of arguments on stack when called + + + | OneOcc -- Just one occurrence (or one each in + -- mutually-exclusive case alts). + + FunOrArg -- How it occurs + + DuplicationDanger + + InsideSCC + + Int -- Number of mutually-exclusive case alternatives + -- in which it occurs + + -- Note that we only worry about the case-alt counts + -- if the OneOcc is substitutable -- that's the only + -- time we *use* the info; we could be more clever for + -- other cases if we really had to. (WDP/PS) + + Int -- number of arguments on stack when called + +-- In general, we are feel free to substitute unless +-- (a) is in an argument position (ArgOcc) +-- (b) is inside a lambda [or type lambda?] (DupDanger) +-- (c) is inside an SCC expression (InsideSCC) +-- (d) is in the RHS of a binding for a variable with an INLINE pragma +-- (because the RHS will be inlined regardless of its size) +-- [again, DupDanger] + +data FunOrArg + = FunOcc -- An occurrence in a function position + | ArgOcc -- Other arg occurrence + + -- When combining branches of a case, only report FunOcc if + -- both branches are FunOccs + +data DuplicationDanger + = DupDanger -- Inside a non-linear lambda (that is, a lambda which + -- is sure to be instantiated only once), or inside + -- the rhs of an INLINE-pragma'd thing. Either way, + -- substituting a redex for this occurrence is + -- dangerous because it might duplicate work. + + | NoDupDanger -- It's ok; substitution won't duplicate work. + +data InsideSCC + = InsideSCC -- Inside an SCC; so be careful when substituting. + | NotInsideSCC -- It's ok. +\end{code} + + +Predicates +~~~~~~~~~~ + +@oneTextualOcc@ checks for one occurrence, in any position. +The occurrence may be inside a lambda, that's all right. + +\begin{code} +oneTextualOcc :: Bool -> BinderInfo -> Bool + +oneTextualOcc ok_to_dup (OneOcc _ _ _ n_alts _) = n_alts <= 1 || ok_to_dup +oneTextualOcc _ other = False +\end{code} + +@safeSingleOcc@ detects single occurences of values that are safe to +inline, {\em including} ones in an argument position. + +\begin{code} +oneSafeOcc :: Bool -> BinderInfo -> Bool +oneSafeOcc ok_to_dup (OneOcc _ NoDupDanger NotInsideSCC n_alts _) + = n_alts <= 1 || ok_to_dup +oneSafeOcc _ other = False +\end{code} + +@inlineUnconditionally@ decides whether a let-bound thing can +definitely be inlined. + +\begin{code} +inlineUnconditionally :: Bool -> BinderInfo -> Bool + +--inlineUnconditionally ok_to_dup DeadCode = True +inlineUnconditionally ok_to_dup (OneOcc FunOcc NoDupDanger NotInsideSCC n_alt_occs _) + = n_alt_occs <= 1 || ok_to_dup + -- We [i.e., Patrick] don't mind the code explosion, + -- though. We could have a flag to limit the + -- damage, e.g., limit to M alternatives. + +inlineUnconditionally _ _ = False +\end{code} + +\begin{code} +isFun :: FunOrArg -> Bool +isFun FunOcc = True +isFun _ = False + +isDupDanger :: DuplicationDanger -> Bool +isDupDanger DupDanger = True +isDupDanger _ = False +\end{code} + + +Construction +~~~~~~~~~~~~~ +\begin{code} +argOccurrence, funOccurrence :: Int -> BinderInfo + +funOccurrence = OneOcc FunOcc NoDupDanger NotInsideSCC 1 +argOccurrence = OneOcc ArgOcc NoDupDanger NotInsideSCC 1 + +markMany, markDangerousToDup, markInsideSCC :: BinderInfo -> BinderInfo + +markMany (OneOcc _ _ _ _ ar) = ManyOcc ar +markMany (ManyOcc ar) = ManyOcc ar +markMany DeadCode = panic "markMany" + +markDangerousToDup (OneOcc posn _ in_scc n_alts ar) + = OneOcc posn DupDanger in_scc n_alts ar +markDangerousToDup other = other + +markInsideSCC (OneOcc posn dup_danger _ n_alts ar) + = OneOcc posn dup_danger InsideSCC n_alts ar +markInsideSCC other = other + +combineBinderInfo, combineAltsBinderInfo + :: BinderInfo -> BinderInfo -> BinderInfo + +combineBinderInfo DeadCode info2 = info2 +combineBinderInfo info1 DeadCode = info1 +combineBinderInfo info1 info2 + = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) + +combineAltsBinderInfo DeadCode info2 = info2 +combineAltsBinderInfo info1 DeadCode = info1 +combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) + (OneOcc posn2 dup2 scc2 n_alts2 ar_2) + = OneOcc (combine_posns posn1 posn2) + (combine_dups dup1 dup2) + (combine_sccs scc1 scc2) + (n_alts1 + n_alts2) + (min ar_1 ar_2) + where + combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn + combine_posns _ _ = ArgOcc + + combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo + combine_dups _ DupDanger = DupDanger + combine_dups _ _ = NoDupDanger + + combine_sccs InsideSCC _ = InsideSCC -- Too paranoid?? ToDo + combine_sccs _ InsideSCC = InsideSCC + combine_sccs _ _ = NotInsideSCC + +combineAltsBinderInfo info1 info2 + = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) + +setBinderInfoArityToZero :: BinderInfo -> BinderInfo +setBinderInfoArityToZero DeadCode = DeadCode +setBinderInfoArityToZero (ManyOcc _) = ManyOcc 0 +setBinderInfoArityToZero (OneOcc fa dd sc i _) = OneOcc fa dd sc i 0 +\end{code} + +\begin{code} +getBinderInfoArity (DeadCode) = 0 +getBinderInfoArity (ManyOcc i) = i +getBinderInfoArity (OneOcc _ _ _ _ i) = i +\end{code} + +\begin{code} +instance Outputable BinderInfo where + ppr sty DeadCode = ppStr "Dead" + ppr sty (ManyOcc ar) = ppBesides [ ppStr "Many-", ppInt ar ] + ppr sty (OneOcc posn dup_danger in_scc n_alts ar) + = ppBesides [ ppStr "One-", pp_posn posn, ppChar '-', pp_danger dup_danger, + ppChar '-', pp_scc in_scc, ppChar '-', ppInt n_alts, + ppChar '-', ppInt ar ] + where + pp_posn FunOcc = ppStr "fun" + pp_posn ArgOcc = ppStr "arg" + + pp_danger DupDanger = ppStr "*dup*" + pp_danger NoDupDanger = ppStr "nodup" + + pp_scc InsideSCC = ppStr "*SCC*" + pp_scc NotInsideSCC = ppStr "noscc" +\end{code} + diff --git a/ghc/compiler/simplCore/ConFold.hi b/ghc/compiler/simplCore/ConFold.hi new file mode 100644 index 0000000..789f3b0 --- /dev/null +++ b/ghc/compiler/simplCore/ConFold.hi @@ -0,0 +1,12 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ConFold where +import CoreSyn(CoreAtom, CoreExpr) +import Id(Id) +import PrimOps(PrimOp) +import SimplEnv(SimplEnv) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import UniType(UniType) +completePrim :: SimplEnv -> PrimOp -> [UniType] -> [CoreAtom Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 122222 _N_ _S_ "LSLS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs new file mode 100644 index 0000000..19c2a78 --- /dev/null +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -0,0 +1,321 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[ConFold]{Constant Folder} + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. + See the @IntDivOp@ below. + +\begin{code} +#include "HsVersions.h" + +module ConFold ( completePrim ) where + +IMPORT_Trace + +import PlainCore +import TaggedCore +import SimplEnv +import SimplMonad + +import AbsPrel ( trueDataCon, falseDataCon, PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import BasicLit ( mkMachInt, mkMachWord, BasicLit(..) ) +import Id ( Id, getIdUniType ) +import Maybes ( Maybe(..) ) +import Util +\end{code} + +\begin{code} +completePrim :: SimplEnv + -> PrimOp -> [OutType] -> [OutAtom] + -> SmplM OutExpr +\end{code} + +In the parallel world, we use _seq_ to control the order in which +certain expressions will be evaluated. Operationally, the expression +``_seq_ a b'' evaluates a and then evaluates b. We have an inlining +for _seq_ which translates _seq_ to: + + _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y } + +Now, we know that the seq# primitive will never return 0#, but we +don't let the simplifier know that. We also use a special error +value, parError#, which is *not* a bottoming Id, so as far as the +simplifier is concerned, we have to evaluate seq# a before we know +whether or not b will be evaluated. + +This is fine, but we'd like to get rid of the extraneous code. Hence, +we *do* let the simplifier know that seq# is strict in its argument. +As a result, we hope that `a' will be evaluated before seq# is called. +At this point, we have a very special and magical simpification which +says that ``seq# a'' can be immediately simplified to `1#' if we +know that `a' is already evaluated. + +NB: If we ever do case-floating, we have an extra worry: + + case a of + a' -> let b' = case seq# a of { True -> b; False -> parError# } + in case b' of ... + + => + + case a of + a' -> let b' = case True of { True -> b; False -> parError# } + in case b' of ... + + => + + case a of + a' -> let b' = b + in case b' of ... + + => + + case a of + a' -> case b of ... + +The second case must never be floated outside of the first! + +\begin{code} +completePrim env SeqOp [ty] [CoLitAtom lit] + = returnSmpl (CoLit (mkMachInt 1)) + +completePrim env op@SeqOp tys@[ty] args@[CoVarAtom var] + = case (lookupUnfolding env var) of + NoUnfoldingDetails -> give_up + LiteralForm _ -> hooray + OtherLiteralForm _ -> hooray + ConstructorForm _ _ _ -> hooray + OtherConstructorForm _ -> hooray + GeneralForm _ WhnfForm _ _ -> hooray + _ -> give_up + where + give_up = returnSmpl (CoPrim op tys args) + hooray = returnSmpl (CoLit (mkMachInt 1)) +\end{code} + +\begin{code} +completePrim env op tys args + = case args of + [CoLitAtom (MachChar char_lit)] -> oneCharLit op char_lit + [CoLitAtom (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit) + op int_lit + [CoLitAtom (MachFloat float_lit)] -> oneFloatLit op float_lit + [CoLitAtom (MachDouble double_lit)] -> oneDoubleLit op double_lit + [CoLitAtom other_lit] -> oneLit op other_lit + + [CoLitAtom (MachChar char_lit1), + CoLitAtom (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2 + + [CoLitAtom (MachInt int_lit1 True), -- both *signed* literals + CoLitAtom (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2 + + [CoLitAtom (MachInt int_lit1 False), -- both *unsigned* literals + CoLitAtom (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2 + + [CoLitAtom (MachInt int_lit1 False), -- unsigned+signed (shift ops) + CoLitAtom (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2 + + [CoLitAtom (MachFloat float_lit1), + CoLitAtom (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2 + + [CoLitAtom (MachDouble double_lit1), + CoLitAtom (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2 + + [CoLitAtom lit, CoVarAtom var] -> litVar op lit var + [CoVarAtom var, CoLitAtom lit] -> litVar op lit var + + other -> give_up + + where + give_up = returnSmpl (CoPrim op tys args) + + return_char c = returnSmpl (CoLit (MachChar c)) + return_int i = returnSmpl (CoLit (mkMachInt i)) + return_word i = returnSmpl (CoLit (mkMachWord i)) + return_float f = returnSmpl (CoLit (MachFloat f)) + return_double d = returnSmpl (CoLit (MachDouble d)) + return_lit lit = returnSmpl (CoLit lit) + + return_bool True = returnSmpl trueVal + return_bool False = returnSmpl falseVal + + return_prim_case var lit val_if_eq val_if_neq + = newId (getIdUniType var) `thenSmpl` \ unused_binder -> + let + result + = CoCase (CoVar var) + (CoPrimAlts [(lit,val_if_eq)] + (CoBindDefault unused_binder val_if_neq)) + in +-- pprTrace "return_prim_case:" (ppr PprDebug result) ( + returnSmpl result +-- ) + + --------- Ints -------------- + oneIntLit IntNegOp i = return_int (-i) + oneIntLit ChrOp i = return_char (chr (fromInteger i)) +-- SIGH: these two cause trouble in unfoldery +-- as we can't distinguish unsigned literals in interfaces (ToDo?) +-- oneIntLit Int2WordOp i = ASSERT( i>=0 ) return_word i +-- oneIntLit Int2AddrOp i = ASSERT( i>=0 ) return_lit (MachAddr i) + oneIntLit Int2FloatOp i = return_float (fromInteger i) + oneIntLit Int2DoubleOp i = return_double (fromInteger i) + oneIntLit _ _ = {-trace "oneIntLit: giving up"-} give_up + + oneWordLit Word2IntOp w = {-lazy:ASSERT( w<= maxInt)-} return_int w +-- oneWordLit NotOp w = ??? ToDo: sort-of a pain + oneWordLit _ _ = {-trace "oneIntLit: giving up"-} give_up + + twoIntLits IntAddOp i1 i2 = return_int (i1+i2) + twoIntLits IntSubOp i1 i2 = return_int (i1-i2) + twoIntLits IntMulOp i1 i2 = return_int (i1*i2) + twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2) + twoIntLits IntDivOp i1 i2 | i2 /= 0 = return_int (i1 `div` i2) + twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2) + twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2) + twoIntLits IntGeOp i1 i2 = return_bool (i1 >= i2) + twoIntLits IntEqOp i1 i2 = return_bool (i1 == i2) + twoIntLits IntNeOp i1 i2 = return_bool (i1 /= i2) + twoIntLits IntLtOp i1 i2 = return_bool (i1 < i2) + twoIntLits IntLeOp i1 i2 = return_bool (i1 <= i2) + -- ToDo: something for integer-shift ops? + twoIntLits _ _ _ = {-trace "twoIntLits: giving up"-} give_up + + twoWordLits WordGtOp w1 w2 = return_bool (w1 > w2) + twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2) + twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2) + twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2) + twoWordLits WordLtOp w1 w2 = return_bool (w1 < w2) + twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2) + -- ToDo: something for AndOp, OrOp? + twoWordLits _ _ _ = {-trace "twoWordLits: giving up"-} give_up + + -- ToDo: something for shifts + oneWordOneIntLit _ _ _ = {-trace "oneWordOneIntLit: giving up"-} give_up + + --------- Floats -------------- + oneFloatLit FloatNegOp f = return_float (-f) +#if __GLASGOW_HASKELL__ <= 22 + oneFloatLit FloatExpOp f = return_float (exp f) + oneFloatLit FloatLogOp f = return_float (log f) + oneFloatLit FloatSqrtOp f = return_float (sqrt f) + oneFloatLit FloatSinOp f = return_float (sin f) + oneFloatLit FloatCosOp f = return_float (cos f) + oneFloatLit FloatTanOp f = return_float (tan f) + oneFloatLit FloatAsinOp f = return_float (asin f) + oneFloatLit FloatAcosOp f = return_float (acos f) + oneFloatLit FloatAtanOp f = return_float (atan f) + oneFloatLit FloatSinhOp f = return_float (sinh f) + oneFloatLit FloatCoshOp f = return_float (cosh f) + oneFloatLit FloatTanhOp f = return_float (tanh f) +#else + -- hard to do all that in Rationals ?? (WDP 94/10) ToDo +#endif + oneFloatLit _ _ = {-trace "oneFloatLits: giving up"-} give_up + + twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2) + twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2) + twoFloatLits FloatEqOp f1 f2 = return_bool (f1 == f2) + twoFloatLits FloatNeOp f1 f2 = return_bool (f1 /= f2) + twoFloatLits FloatLtOp f1 f2 = return_bool (f1 < f2) + twoFloatLits FloatLeOp f1 f2 = return_bool (f1 <= f2) + twoFloatLits FloatAddOp f1 f2 = return_float (f1 + f2) + twoFloatLits FloatSubOp f1 f2 = return_float (f1 - f2) + twoFloatLits FloatMulOp f1 f2 = return_float (f1 * f2) + twoFloatLits FloatDivOp f1 f2 | f2 /= 0 = return_float (f1 / f2) +#if __GLASGOW_HASKELL__ <= 22 + twoFloatLits FloatPowerOp f1 f2 = return_float (f1 ** f2) +#else + -- hard to do all that in Rationals ?? (WDP 94/10) ToDo +#endif + twoFloatLits _ _ _ = {-trace "twoFloatLits: giving up"-} give_up + + --------- Doubles -------------- + oneDoubleLit DoubleNegOp d = return_double (-d) +#if __GLASGOW_HASKELL__ <= 22 + oneDoubleLit DoubleExpOp d = return_double (exp d) + oneDoubleLit DoubleLogOp d = return_double (log d) + oneDoubleLit DoubleSqrtOp d = return_double (sqrt d) + oneDoubleLit DoubleSinOp d = return_double (sin d) + oneDoubleLit DoubleCosOp d = return_double (cos d) + oneDoubleLit DoubleTanOp d = return_double (tan d) + oneDoubleLit DoubleAsinOp d = return_double (asin d) + oneDoubleLit DoubleAcosOp d = return_double (acos d) + oneDoubleLit DoubleAtanOp d = return_double (atan d) + oneDoubleLit DoubleSinhOp d = return_double (sinh d) + oneDoubleLit DoubleCoshOp d = return_double (cosh d) + oneDoubleLit DoubleTanhOp d = return_double (tanh d) +#else + -- hard to do all that in Rationals ?? (WDP 94/10) ToDo +#endif + oneDoubleLit _ _ = {-trace "oneDoubleLit: giving up"-} give_up + + twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2) + twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2) + twoDoubleLits DoubleEqOp d1 d2 = return_bool (d1 == d2) + twoDoubleLits DoubleNeOp d1 d2 = return_bool (d1 /= d2) + twoDoubleLits DoubleLtOp d1 d2 = return_bool (d1 < d2) + twoDoubleLits DoubleLeOp d1 d2 = return_bool (d1 <= d2) + twoDoubleLits DoubleAddOp d1 d2 = return_double (d1 + d2) + twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2) + twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2) + twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2) +#if __GLASGOW_HASKELL__ <= 22 + twoDoubleLits DoublePowerOp d1 d2 = return_double (d1 ** d2) +#else + -- hard to do all that in Rationals ?? (WDP 94/10) ToDo +#endif + twoDoubleLits _ _ _ = {-trace "twoDoubleLits: giving up"-} give_up + + --------- Characters -------------- + oneCharLit OrdOp c = return_int (fromInt (ord c)) + oneCharLit _ _ = {-trace "oneCharLIt: giving up"-} give_up + + twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2) + twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2) + twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2) + twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2) + twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2) + twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2) + twoCharLits _ _ _ = {-trace "twoCharLits: giving up"-} give_up + + --------- Miscellaneous -------------- + oneLit Addr2IntOp (MachAddr i) = return_int i + oneLit op lit = give_up + + --------- Equality and inequality for Int/Char -------------- + -- This stuff turns + -- n ==# 3# + -- into + -- case n of + -- 3# -> True + -- m -> False + -- + -- This is a Good Thing, because it allows case-of case things + -- to happen, and case-default absorption to happen. For + -- example: + -- + -- if (n ==# 3#) || (n ==# 4#) then e1 else e2 + -- will transform to + -- case n of + -- 3# -> e1 + -- 4# -> e1 + -- m -> e2 + -- (modulo the usual precautions to avoid duplicating e1) + + litVar IntEqOp lit var = return_prim_case var lit trueVal falseVal + litVar IntNeOp lit var = return_prim_case var lit falseVal trueVal + litVar CharEqOp lit var = return_prim_case var lit trueVal falseVal + litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal + litVar other_op lit var = give_up + + +trueVal = CoCon trueDataCon [] [] +falseVal = CoCon falseDataCon [] [] +\end{code} diff --git a/ghc/compiler/simplCore/FloatIn.hi b/ghc/compiler/simplCore/FloatIn.hi new file mode 100644 index 0000000..bca9504 --- /dev/null +++ b/ghc/compiler/simplCore/FloatIn.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface FloatIn where +import BasicLit(BasicLit) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..)) +import PrimOps(PrimOp) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreExpr = CoreExpr Id Id +type PlainCoreProgram = [CoreBinding Id Id] +floatInwards :: [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs new file mode 100644 index 0000000..2568533 --- /dev/null +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -0,0 +1,390 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[FloatIn]{Floating Inwards pass} +%* * +%************************************************************************ + +The main purpose of @floatInwards@ is floating into branches of a +case, so that we don't allocate things, save them on the stack, and +then discover that they aren't needed in the chosen branch. + +\begin{code} +#include "HsVersions.h" + +module FloatIn ( + floatInwards, + + -- and to make the interface self-sufficient... + CoreExpr, CoreBinding, Id, + PlainCoreProgram(..), PlainCoreExpr(..) + ) where + +import Pretty -- ToDo: debugging only + +import PlainCore +import AnnCoreSyn + +import FreeVars +import UniqSet +import Util +\end{code} + +Top-level interface function, @floatInwards@. Note that we do not +actually float any bindings downwards from the top-level. + +\begin{code} +floatInwards :: [PlainCoreBinding] -> [PlainCoreBinding] + +floatInwards binds + = map fi_top_bind binds + where + fi_top_bind (CoNonRec binder rhs) + = CoNonRec binder (fiExpr [] (freeVars rhs)) + fi_top_bind (CoRec pairs) + = CoRec [ (b, fiExpr [] (freeVars rhs)) | (b, rhs) <- pairs ] +\end{code} + +%************************************************************************ +%* * +\subsection{Mail from Andr\'e [edited]} +%* * +%************************************************************************ + +{\em Will wrote: What??? I thought the idea was to float as far +inwards as possible, no matter what. This is dropping all bindings +every time it sees a lambda of any kind. Help! } + +You are assuming we DO DO full laziness AFTER floating inwards! We +have to [not float inside lambdas] if we don't. + +If we indeed do full laziness after the floating inwards (we could +check the compilation flags for that) then I agree we could be more +aggressive and do float inwards past lambdas. + +Actually we are not doing a proper full laziness (see below), which +was another reason for not floating inwards past a lambda. + +This can easily be fixed. +The problem is that we float lets outwards, +but there are a few expressions which are not +let bound, like case scrutinees and case alternatives. +After floating inwards the simplifier could decide to inline +the let and the laziness would be lost, e.g. +\begin{verbatim} +let a = expensive ==> \b -> case expensive of ... +in \ b -> case a of ... +\end{verbatim} +The fix is +\begin{enumerate} +\item +to let bind the algebraic case scrutinees (done, I think) and +the case alternatives (except the ones with an +unboxed type)(not done, I think). This is best done in the +SetLevels.lhs module, which tags things with their level numbers. +\item +do the full laziness pass (floating lets outwards). +\item +simplify. The simplifier inlines the (trivial) lets that were + created but were not floated outwards. +\end{enumerate} + +With the fix I think Will's suggestion that we can gain even more from +strictness by floating inwards past lambdas makes sense. + +We still gain even without going past lambdas, as things may be +strict in the (new) context of a branch (where it was floated to) or +of a let rhs, e.g. +\begin{verbatim} +let a = something case x of +in case x of alt1 -> case something of a -> a + a + alt1 -> a + a ==> alt2 -> b + alt2 -> b + +let a = something let b = case something of a -> a + a +in let b = a + a ==> in (b,b) +in (b,b) +\end{verbatim} +Also, even if a is not found to be strict in the new context and is +still left as a let, if the branch is not taken (or b is not entered) +the closure for a is not built. + +%************************************************************************ +%* * +\subsection{Main floating-inwards code} +%* * +%************************************************************************ + +\begin{code} +type FreeVarsSet = UniqSet Id + +type FloatingBinds = [(PlainCoreBinding, FreeVarsSet)] + -- In dependency order (outermost first) + + -- The FreeVarsSet is the free variables of the binding. In the case + -- of recursive bindings, the set doesn't include the bound + -- variables. + +fiExpr :: FloatingBinds -- binds we're trying to drop + -- as far "inwards" as possible + -> CoreExprWithFVs -- input expr + -> PlainCoreExpr -- result + +fiExpr to_drop (_,AnnCoVar v) = mkCoLets' to_drop (CoVar v) + +fiExpr to_drop (_,AnnCoLit k) = mkCoLets' to_drop (CoLit k) + +fiExpr to_drop (_,AnnCoCon c tys atoms) + = mkCoLets' to_drop (CoCon c tys atoms) + +fiExpr to_drop (_,AnnCoPrim c tys atoms) + = mkCoLets' to_drop (CoPrim c tys atoms) +\end{code} + +Here we are not floating inside lambda (type lambdas are OK): +\begin{code} +fiExpr to_drop (_,AnnCoLam binders body) + = mkCoLets' to_drop (mkCoLam binders (fiExpr [] body)) + +fiExpr to_drop (_,AnnCoTyLam tyvar body) + | whnf body + -- we do not float into type lambdas if they are followed by + -- a whnf (actually we check for lambdas and constructors). + -- The reason is that a let binding will get stuck + -- in between the type lambda and the whnf and the simplifier + -- does not know how to pull it back out from a type lambda. + -- Ex: + -- let v = ... + -- in let f = /\t -> \a -> ... + -- ==> + -- let f = /\t -> let v = ... in \a -> ... + -- which is bad as now f is an updatable closure (update PAP) + -- and has arity 0. This example comes from cichelli. + = mkCoLets' to_drop (CoTyLam tyvar (fiExpr [] body)) + | otherwise + = CoTyLam tyvar (fiExpr to_drop body) + where + whnf :: CoreExprWithFVs -> Bool + whnf (_,AnnCoLit _) = True + whnf (_,AnnCoCon _ _ _) = True + whnf (_,AnnCoLam _ _) = True + whnf (_,AnnCoTyLam _ e) = whnf e + whnf (_,AnnCoSCC _ e) = whnf e + whnf _ = False + +\end{code} + +Applications: we could float inside applications, but it's probably +not worth it (a purely practical choice, hunch- [not experience-] +based). +\begin{code} +fiExpr to_drop (_,AnnCoApp fun atom) + = mkCoLets' to_drop (CoApp (fiExpr [] fun) atom) + +fiExpr to_drop (_,AnnCoTyApp expr ty) + = CoTyApp (fiExpr to_drop expr) ty +\end{code} + +We don't float lets inwards past an SCC. + +ToDo: CoSCC: {\em should} keep info on current cc, and when passing +one, if it is not the same, annotate all lets in binds with current +cc, change current cc to the new one and float binds into expr. +\begin{code} +fiExpr to_drop (_, AnnCoSCC cc expr) + = mkCoLets' to_drop (CoSCC cc (fiExpr [] expr)) +\end{code} + +For @CoLets@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~in the body, (b1)~in the RHS of a CoNonRec binding, +or~(b2), in each of the RHSs of the pairs of a @CoRec@. + +Note that we do {\em weird things} with this let's binding. Consider: +\begin{verbatim} +let + w = ... +in { + let v = ... w ... + in ... w ... +} +\end{verbatim} +Look at the inner \tr{let}. As \tr{w} is used in both the bind and +body of the inner let, we could panic and leave \tr{w}'s binding where +it is. But \tr{v} is floatable into the body of the inner let, and +{\em then} \tr{w} will also be only in the body of that inner let. + +So: rather than drop \tr{w}'s binding here, we add it onto the list of +things to drop in the outer let's body, and let nature take its +course. + +\begin{code} +fiExpr to_drop (_,AnnCoLet (AnnCoNonRec id rhs) body) + = fiExpr new_to_drop body + where + rhs_fvs = freeVarsOf rhs + body_fvs = freeVarsOf body + + ([rhs_binds, body_binds], shared_binds) = sepBindsByDropPoint [rhs_fvs, body_fvs] to_drop + + new_to_drop = body_binds ++ -- the bindings used only in the body + [(CoNonRec id rhs', rhs_fvs')] ++ -- the new binding itself + shared_binds -- the bindings used both in rhs and body + + -- Push rhs_binds into the right hand side of the binding + rhs' = fiExpr rhs_binds rhs + rhs_fvs' = rhs_fvs `unionUniqSets` (floatedBindsFVs rhs_binds) + +fiExpr to_drop (_,AnnCoLet (AnnCoRec bindings) body) + = fiExpr new_to_drop body + where + (binders, rhss) = unzip bindings + + rhss_fvs = map freeVarsOf rhss + body_fvs = freeVarsOf body + + (body_binds:rhss_binds, shared_binds) + = sepBindsByDropPoint (body_fvs:rhss_fvs) to_drop + + new_to_drop = -- the bindings used only in the body + body_binds ++ + -- the new binding itself + [(CoRec (fi_bind rhss_binds bindings), rhs_fvs')] ++ + -- the bindings used both in rhs and body or in more than one rhs + shared_binds + + rhs_fvs' = unionUniqSets (unionManyUniqSets rhss_fvs) + (unionManyUniqSets (map floatedBindsFVs rhss_binds)) + + -- Push rhs_binds into the right hand side of the binding + fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + -> [(Id, CoreExprWithFVs)] + -> [(Id, PlainCoreExpr)] + + fi_bind to_drops pairs + = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ] +\end{code} + +For @CoCase@, the possible ``drop points'' for the \tr{to_drop} +bindings are: (a)~inside the scrutinee, (b)~inside one of the +alternatives/default [default FVs always {\em first}!]. + +\begin{code} +fiExpr to_drop (_, AnnCoCase scrut alts) + = let + fvs_scrut = freeVarsOf scrut + drop_pts_fvs = fvs_scrut : (get_fvs_from_deflt_and_alts alts) + in + case (sepBindsByDropPoint drop_pts_fvs to_drop) + of (scrut_drops : deflt_drops : alts_drops, drop_here) -> + mkCoLets' drop_here (CoCase (fiExpr scrut_drops scrut) + (fi_alts deflt_drops alts_drops alts)) + + where + ---------------------------- + -- pin default FVs on first! + -- + get_fvs_from_deflt_and_alts (AnnCoAlgAlts alts deflt) + = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ] + + get_fvs_from_deflt_and_alts (AnnCoPrimAlts alts deflt) + = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts] + + get_deflt_fvs AnnCoNoDefault = emptyUniqSet + get_deflt_fvs (AnnCoBindDefault b rhs) = freeVarsOf rhs + + ---------------------------- + fi_alts to_drop_deflt to_drop_alts (AnnCoAlgAlts alts deflt) + = CoAlgAlts + [ (con, params, fiExpr to_drop rhs) + | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ] + (fi_default to_drop_deflt deflt) + + fi_alts to_drop_deflt to_drop_alts (AnnCoPrimAlts alts deflt) + = CoPrimAlts + [ (lit, fiExpr to_drop rhs) + | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ] + (fi_default to_drop_deflt deflt) + + fi_default to_drop AnnCoNoDefault = CoNoDefault + fi_default to_drop (AnnCoBindDefault b e) = CoBindDefault b (fiExpr to_drop e) +\end{code} + +%************************************************************************ +%* * +\subsection{@sepBindsByDropPoint@} +%* * +%************************************************************************ + +This is the crucial function. The idea is: We have a wad of bindings +that we'd like to distribute inside a collection of {\em drop points}; +insides the alternatives of a \tr{case} would be one example of some +drop points; the RHS and body of a non-recursive \tr{let} binding +would be another (2-element) collection. + +So: We're given a list of sets-of-free-variables, one per drop point, +and a list of floating-inwards bindings. If a binding can go into +only one drop point (without suddenly making something out-of-scope), +in it goes. If a binding is used inside {\em multiple} drop points, +then it has to go in a you-must-drop-it-above-all-these-drop-points +point. + +We have to maintain the order on these drop-point-related lists. + +\begin{code} +sepBindsByDropPoint + :: [FreeVarsSet] -- one set of FVs per drop point + -> FloatingBinds -- candidate floaters + -> ([FloatingBinds], -- floaters that *can* be floated into + -- the corresponding drop point + FloatingBinds) -- everything else, bindings which must + -- not be floated inside any drop point + +sepBindsByDropPoint drop_pts [] + = ([[] | p <- drop_pts], []) -- cut to the chase scene; it happens + +sepBindsByDropPoint drop_pts floaters + = let + (per_drop_pt, must_stay_here, _) + --= sep drop_pts emptyUniqSet{-fvs of prev drop_pts-} floaters + = split' drop_pts floaters [] empty_boxes + empty_boxes = take (length drop_pts) (repeat []) + + in + (map reverse per_drop_pt, reverse must_stay_here) + where + split' drop_pts_fvs [] mult_branch drop_boxes + = (drop_boxes, mult_branch, drop_pts_fvs) + + -- only in a or unused + split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) + | all (\b -> {-b `elementOfUniqSet` a &&-} + not (b `elementOfUniqSet` (unionManyUniqSets as))) + (bindersOf (fst bind)) + = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes) + where + a' = a `unionUniqSets` fvsOfBind bind + + -- not in a + split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) + | all (\b -> not (b `elementOfUniqSet` a)) (bindersOf (fst bind)) + = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes') + where + (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes + + -- in a and in as + split' aas@(a:as) (bind:binds) mult_branch drop_boxes + = split' aas' binds (bind : mult_branch) drop_boxes + where + aas' = map (unionUniqSets (fvsOfBind bind)) aas + + ------------------------- + fvsOfBind (_,fvs) = fvs + +--floatedBindsFVs :: +floatedBindsFVs binds = foldr unionUniqSets emptyUniqSet (map snd binds) + +--mkCoLets' :: [FloatingBinds] -> PlainCoreExpr -> PlainCoreExpr +mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e +\end{code} diff --git a/ghc/compiler/simplCore/FloatOut.hi b/ghc/compiler/simplCore/FloatOut.hi new file mode 100644 index 0000000..5a3d57b --- /dev/null +++ b/ghc/compiler/simplCore/FloatOut.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface FloatOut where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import Id(Id) +import SplitUniq(SplitUniqSupply) +floatOutwards :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs new file mode 100644 index 0000000..9ab7221 --- /dev/null +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -0,0 +1,427 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[FloatOut]{Float bindings outwards (towards the top level)} + +``Long-distance'' floating of bindings towards the top level. + +\begin{code} +#include "HsVersions.h" + +module FloatOut ( floatOutwards ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty +import Outputable + +import PlainCore + +import BasicLit ( BasicLit(..), PrimKind ) +import CmdLineOpts ( GlobalSwitch(..) ) +import CostCentre ( dupifyCC, CostCentre ) +import SetLevels +import Id ( eqId ) +import IdEnv +import Maybes ( Maybe(..), catMaybes, maybeToBool ) +import SplitUniq +import Util +\end{code} + +Random comments +~~~~~~~~~~~~~~~ +At the moment we never float a binding out to between two adjacent lambdas. For +example: +@ + \x y -> let t = x+x in ... +===> + \x -> let t = x+x in \y -> ... +@ +Reason: this is less efficient in the case where the original lambda is +never partially applied. + +But there's a case I've seen where this might not be true. Consider: +@ +elEm2 x ys + = elem' x ys + where + elem' _ [] = False + elem' x (y:ys) = x==y || elem' x ys +@ +It turns out that this generates a subexpression of the form +@ + \deq x ys -> let eq = eqFromEqDict deq in ... +@ +which might usefully be separated to +@ + \deq -> let eq = eqFromEqDict deq in \xy -> ... +@ +Well, maybe. We don't do this at the moment. + + +\begin{code} +type LevelledExpr = CoreExpr (Id, Level) Id +type LevelledBind = CoreBinding (Id, Level) Id +type FloatingBind = (Level, Floater) +type FloatingBinds = [FloatingBind] + +data Floater = LetFloater PlainCoreBinding + + | CaseFloater (PlainCoreExpr -> PlainCoreExpr) + -- Give me a right-hand side of the + -- (usually single) alternative, and + -- I'll build the case +\end{code} + +%************************************************************************ +%* * +\subsection[floatOutwards]{@floatOutwards@: let-floating interface function} +%* * +%************************************************************************ + +\begin{code} +floatOutwards :: (GlobalSwitch -> Bool) -- access to all global cmd-line opts + -> SplitUniqSupply + -> PlainCoreProgram + -> PlainCoreProgram + +floatOutwards sw_chker us pgm + = case (setLevels pgm sw_chker us) of { annotated_w_levels -> + + case unzip3 (map (floatTopBind sw_chker) annotated_w_levels) + of { (fcs, lcs, final_toplev_binds_s) -> + + (if sw_chker D_verbose_core2core + then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels) + else id + ) + ( if sw_chker D_simplifier_stats + then pprTrace "FloatOut stats: " (ppBesides [ + ppInt (sum fcs), ppStr " Lets floated out of ", + ppInt (sum lcs), ppStr " Lambdas"]) + else id + ) + concat final_toplev_binds_s + }} + +floatTopBind sw bind@(CoNonRec _ _) + = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, bind', _) -> + (fc,lc, floatsToBinds floats ++ [bind']) + } + +floatTopBind sw bind@(CoRec _) + = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, CoRec pairs', _) -> + -- Actually floats will be empty + --false:ASSERT(null floats) + (fc,lc, [CoRec (floatsToBindPairs floats ++ pairs')]) + } +\end{code} + +%************************************************************************ +%* * +\subsection[FloatOut-Bind]{Floating in a binding (the business end)} +%* * +%************************************************************************ + + +\begin{code} +floatBind :: (GlobalSwitch -> Bool) + -> IdEnv Level + -> Level + -> LevelledBind + -> (Int,Int, FloatingBinds, PlainCoreBinding, IdEnv Level) + +floatBind sw env lvl (CoNonRec (name,level) rhs) + = case (floatExpr sw env level rhs) of { (fc,lc, rhs_floats, rhs') -> + + -- A good dumping point + case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) -> + + (fc,lc, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level) + }} + +floatBind sw env lvl bind@(CoRec pairs) + = case (unzip4 (map do_pair pairs)) of { (fcs,lcs, rhss_floats, new_pairs) -> + + if not (isTopLvl bind_level) then + -- Standard case + (sum fcs,sum lcs, concat rhss_floats, CoRec new_pairs, new_env) + else + {- In a recursive binding, destined for the top level (only), + the rhs floats may contain + references to the bound things. For example + + f = ...(let v = ...f... in b) ... + + might get floated to + + v = ...f... + f = ... b ... + + and hence we must (pessimistically) make all the floats recursive + with the top binding. Later dependency analysis will unravel it. + -} + + (sum fcs,sum lcs, [], + CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)), + new_env) + + } + where + new_env = growIdEnvList env (map fst pairs) + + bind_level = getBindLevel bind + + do_pair ((name, level), rhs) + = case (floatExpr sw new_env level rhs) of { (fc,lc, rhs_floats, rhs') -> + + -- A good dumping point + case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) -> + + (fc,lc, rhs_floats', (name, install heres rhs')) + }} +\end{code} + +%************************************************************************ + +\subsection[FloatOut-Expr]{Floating in expressions} +%* * +%************************************************************************ + +\begin{code} +floatExpr :: (GlobalSwitch -> Bool) + -> IdEnv Level + -> Level + -> LevelledExpr + -> (Int,Int, FloatingBinds, PlainCoreExpr) + +floatExpr sw env _ (CoVar v) = (0,0, [], CoVar v) + +floatExpr sw env _ (CoLit l) = (0,0, [], CoLit l) + +floatExpr sw env _ (CoPrim op ty as) = (0,0, [], CoPrim op ty as) +floatExpr sw env _ (CoCon con ty as) = (0,0, [], CoCon con ty as) + +floatExpr sw env lvl (CoApp e a) + = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') -> + (fc,lc, floating_defns, CoApp e' a) } + +floatExpr sw env lvl (CoTyApp e ty) + = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') -> + (fc,lc, floating_defns, CoTyApp e' ty) } + +floatExpr sw env lvl (CoTyLam tv e) + = let + incd_lvl = incMinorLvl lvl + in + case (floatExpr sw env incd_lvl e) of { (fc,lc, floats, e') -> + + -- Dump any bindings which absolutely cannot go any further + case (partitionByLevel incd_lvl floats) of { (floats', heres) -> + + (fc,lc, floats', CoTyLam tv (install heres e')) + }} + +floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs) + = let + args' = map fst args + new_env = growIdEnvList env args + in + case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, floats, rhs') -> + + -- Dump any bindings which absolutely cannot go any further + case (partitionByLevel incd_lvl floats) of { (floats', heres) -> + + (fc + length floats', lc + 1, + floats', mkCoLam args' (install heres rhs')) + }} + +floatExpr sw env lvl (CoSCC cc expr) + = case (floatExpr sw env lvl expr) of { (fc,lc, floating_defns, expr') -> + let + -- annotate bindings floated outwards past an scc expression + -- with the cc. We mark that cc as "duplicated", though. + + annotated_defns = annotate (dupifyCC cc) floating_defns + in + (fc,lc, annotated_defns, CoSCC cc expr') } + where + annotate :: CostCentre -> FloatingBinds -> FloatingBinds + + annotate dupd_cc defn_groups + = [ (level, ann_bind floater) | (level, floater) <- defn_groups ] + where + ann_bind (LetFloater (CoNonRec binder rhs)) + = LetFloater (CoNonRec binder (ann_rhs rhs)) + + ann_bind (LetFloater (CoRec pairs)) + = LetFloater (CoRec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs]) + + ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> CoSCC dupd_cc (fn rhs) ) + + ann_rhs (CoLam args e) = CoLam args (ann_rhs e) + ann_rhs (CoTyLam tv e) = CoTyLam tv (ann_rhs e) + ann_rhs rhs@(CoCon _ _ _)= rhs -- no point in scc'ing WHNF data + ann_rhs rhs = CoSCC dupd_cc rhs + + -- Note: Nested SCC's are preserved for the benefit of + -- cost centre stack profiling (Durham) + +floatExpr sw env lvl (CoLet bind body) + = case (floatBind sw env lvl bind) of { (fcb,lcb, rhs_floats, bind', new_env) -> + case (floatExpr sw new_env lvl body) of { (fce,lce, body_floats, body') -> + (fcb + fce, lcb + lce, + rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats, body') + }} + where + bind_lvl = getBindLevel bind + +floatExpr sw env lvl (CoCase scrut alts) + = case (floatExpr sw env lvl scrut) of { (fce,lce, fde, scrut') -> + + case (scrut', float_alts alts) of + +{- CASE-FLOATING DROPPED FOR NOW. (SLPJ 7/2/94) + + (CoVar scrut_var, (fda, CoAlgAlts [(con,bs,rhs')] CoNoDefault)) + | scrut_var_lvl `ltMajLvl` lvl -> + + -- Candidate for case floater; scrutinising a variable; it can + -- escape outside a lambda; there's only one alternative. + (fda ++ fde ++ [case_floater], rhs') + + where + case_floater = (scrut_var_lvl, CaseFloater fn) + fn body = CoCase scrut' (CoAlgAlts [(con,bs,body)] CoNoDefault) + scrut_var_lvl = case lookupIdEnv env scrut_var of + Nothing -> Level 0 0 + Just lvl -> unTopify lvl + + END OF CASE FLOATING DROPPED -} + + (_, (fca,lca, fda, alts')) -> + + (fce + fca, lce + lca, fda ++ fde, CoCase scrut' alts') + } + where + incd_lvl = incMinorLvl lvl + + partition_fn = partitionByMajorLevel + +{- OMITTED + We don't want to be too keen about floating lets out of case alternatives + because they may benefit from seeing the evaluation done by the case. + + The main reason for doing this is to allocate in fewer larger blocks + but that's really an STG-level issue. + + case alts of + -- Just one alternative, then dump only + -- what *has* to be dumped + CoAlgAlts [_] CoNoDefault -> partitionByLevel + CoAlgAlts [] (CoBindDefault _ _) -> partitionByLevel + CoPrimAlts [_] CoNoDefault -> partitionByLevel + CoPrimAlts [] (CoBindDefault _ _) -> partitionByLevel + + -- If there's more than one alternative, then + -- this is a dumping point + other -> partitionByMajorLevel +-} + + float_alts (CoAlgAlts alts deflt) + = case (float_deflt deflt) of { (fcd,lcd, fdd, deflt') -> + case (unzip4 (map float_alg_alt alts)) of { (fcas,lcas, fdas, alts') -> + (fcd + sum fcas, lcd + sum lcas, + concat fdas ++ fdd, CoAlgAlts alts' deflt') }} + + float_alts (CoPrimAlts alts deflt) + = case (float_deflt deflt) of { (fcd,lcd, fdd, deflt') -> + case (unzip4 (map float_prim_alt alts)) of { (fcas,lcas, fdas, alts') -> + (fcd + sum fcas, lcd + sum lcas, + concat fdas ++ fdd, CoPrimAlts alts' deflt') }} + + ------------- + float_alg_alt (con, bs, rhs) + = let + bs' = map fst bs + new_env = growIdEnvList env bs + in + case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, rhs_floats, rhs') -> + case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) -> + (fc, lc, rhs_floats', (con, bs', install heres rhs')) + }} + + -------------- + float_prim_alt (lit, rhs) + = case (floatExpr sw env incd_lvl rhs) of { (fc,lc, rhs_floats, rhs') -> + case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) -> + (fc,lc, rhs_floats', (lit, install heres rhs')) + }} + + -------------- + float_deflt CoNoDefault = (0,0, [], CoNoDefault) + + float_deflt (CoBindDefault (b,lvl) rhs) + = case (floatExpr sw new_env lvl rhs) of { (fc,lc, rhs_floats, rhs') -> + case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) -> + (fc,lc, rhs_floats', CoBindDefault b (install heres rhs')) + }} + where + new_env = addOneToIdEnv env b lvl +\end{code} + +%************************************************************************ +%* * +\subsection[FloatOut-utils]{Utility bits for floating} +%* * +%************************************************************************ + +\begin{code} +getBindLevel (CoNonRec (_, lvl) _) = lvl +getBindLevel (CoRec (((_,lvl), _) : _)) = lvl +\end{code} + +\begin{code} +partitionByMajorLevel, partitionByLevel + :: Level -- Partitioning level + + -> FloatingBinds -- Defns to be divided into 2 piles... + + -> (FloatingBinds, -- Defns with level strictly < partition level, + FloatingBinds) -- The rest + + +partitionByMajorLevel ctxt_lvl defns + = partition float_further defns + where + float_further (my_lvl, _) = my_lvl `ltMajLvl` ctxt_lvl || + isTopLvl my_lvl + +partitionByLevel ctxt_lvl defns + = partition float_further defns + where + float_further (my_lvl, _) = my_lvl `ltLvl` ctxt_lvl +\end{code} + +\begin{code} +floatsToBinds :: FloatingBinds -> [PlainCoreBinding] +floatsToBinds floats = map get_bind floats + where + get_bind (_, LetFloater bind) = bind + get_bind (_, CaseFloater _) = panic "floatsToBinds" + +floatsToBindPairs :: FloatingBinds -> [(Id,PlainCoreExpr)] + +floatsToBindPairs floats = concat (map mk_pairs floats) + where + mk_pairs (_, LetFloater (CoRec pairs)) = pairs + mk_pairs (_, LetFloater (CoNonRec binder rhs)) = [(binder,rhs)] + mk_pairs (_, CaseFloater _) = panic "floatsToBindPairs" + +install :: FloatingBinds -> PlainCoreExpr -> PlainCoreExpr + +install defn_groups expr + = foldr install_group expr defn_groups + where + install_group (_, LetFloater defns) body = CoLet defns body + install_group (_, CaseFloater fn) body = fn body +\end{code} diff --git a/ghc/compiler/simplCore/FoldrBuildWW.hi b/ghc/compiler/simplCore/FoldrBuildWW.hi new file mode 100644 index 0000000..87f1197 --- /dev/null +++ b/ghc/compiler/simplCore/FoldrBuildWW.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface FoldrBuildWW where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import Id(Id) +import SplitUniq(SplitUniqSupply) +mkFoldrBuildWW :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(ALA)S" {_A_ 3 _U_ 221 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs new file mode 100644 index 0000000..9f480ee --- /dev/null +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -0,0 +1,181 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers} + +\begin{code} +#include "HsVersions.h" + +module FoldrBuildWW ( mkFoldrBuildWW ) where + +IMPORT_Trace +import Outputable +import Pretty +import AbsUniType ( alpha_tv, cloneTyVarFromTemplate, mkTyVarTy, + splitTypeWithDictsAsArgs, eqTyCon, mkForallTy, + alpha_tyvar, alpha_ty, alpha, TyVarTemplate + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import UniType ( UniType(..) ) -- **** CAN SEE THE CONSTRUCTORS **** +import PlainCore +import Unique ( runBuiltinUs ) +import WwLib -- share the same monad (is this eticit ?) +import AbsPrel ( listTyCon, mkListTy, nilDataCon, consDataCon, + foldrId, mkBuild, mkFoldr, buildId, + mkFunTy + ) +import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo, + replaceIdInfo, mkSysLocal, getIdUniType + ) +import IdInfo +import Maybes +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +\end{code} + +\begin{code} +mkFoldrBuildWW + :: (GlobalSwitch -> Bool) + -> SplitUniqSupply + -> PlainCoreProgram + -> PlainCoreProgram +mkFoldrBuildWW switch us top_binds = + (mapWw wwBind top_binds `thenWw` \ top_binds2 -> + returnWw (concat top_binds2)) us switch +\end{code} + +\begin{code} +wwBind :: PlainCoreBinding -> WwM [PlainCoreBinding] +wwBind (CoNonRec bndr expr) + = try_split_bind bndr expr `thenWw` \ re -> + returnWw [CoNonRec bnds expr | (bnds,expr) <- re] +wwBind (CoRec binds) + = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res -> + returnWw [CoRec (concat res)] + +wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr +wwExpr e@(CoVar _) = returnWw e +wwExpr e@(CoLit _) = returnWw e +wwExpr e@(CoCon _ _ _) = returnWw e +wwExpr e@(CoPrim _ _ _) = returnWw e +wwExpr (CoLam ids e) = + wwExpr e `thenWw` \ e' -> + returnWw (CoLam ids e') +wwExpr (CoTyLam tyvar e) = + wwExpr e `thenWw` \ e' -> + returnWw (CoTyLam tyvar e') +wwExpr (CoApp f atom) = + wwExpr f `thenWw` \ f' -> + returnWw (CoApp f atom) +wwExpr (CoTyApp f ty) = + wwExpr f `thenWw` \ f' -> + returnWw (CoTyApp f' ty) +wwExpr (CoSCC lab e) = + wwExpr e `thenWw` \ e' -> + returnWw (CoSCC lab e') +wwExpr (CoLet bnds e) = + wwExpr e `thenWw` \ e' -> + wwBind bnds `thenWw` \ bnds' -> + returnWw (foldr CoLet e' bnds') +wwExpr (CoCase e alts) = + wwExpr e `thenWw` \ e' -> + wwAlts alts `thenWw` \ alts' -> + returnWw (CoCase e' alts') + +wwAlts (CoAlgAlts alts deflt) = + mapWw (\(con,binders,e) -> + wwExpr e `thenWw` \ e' -> + returnWw (con,binders,e')) alts `thenWw` \ alts' -> + wwDef deflt `thenWw` \ deflt' -> + returnWw (CoAlgAlts alts' deflt) +wwAlts (CoPrimAlts alts deflt) = + mapWw (\(lit,e) -> + wwExpr e `thenWw` \ e' -> + returnWw (lit,e')) alts `thenWw` \ alts' -> + wwDef deflt `thenWw` \ deflt' -> + returnWw (CoPrimAlts alts' deflt) + +wwDef e@CoNoDefault = returnWw e +wwDef (CoBindDefault v e) = + wwExpr e `thenWw` \ e' -> + returnWw (CoBindDefault v e') +\end{code} + +\begin{code} +try_split_bind :: Id -> PlainCoreExpr -> WwM [(Id,PlainCoreExpr)] +try_split_bind id expr = + wwExpr expr `thenWw` \ expr' -> + case getFBType (getIdFBTypeInfo id) of + Just (FBType consum prod) + | FBGoodProd == prod -> +{- || any (== FBGoodConsum) consum -} + let + (big_args,args,body) = digForLambdas expr' + in + if length args /= length consum -- funny number of arguments + then returnWw [(id,expr')] + else + -- f /\ t1 .. tn \ v1 .. vn -> e + -- ===> + -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr c n e + -- f /\ t1 .. tn \ v1 .. vn + -- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n) + pprTrace "WW:" (ppr PprDebug id) (returnWw ()) + `thenWw` \ () -> + getUniqueWw `thenWw` \ ty_new_uq -> + getUniqueWw `thenWw` \ worker_new_uq -> + getUniqueWw `thenWw` \ c_new_uq -> + getUniqueWw `thenWw` \ n_new_uq -> + let + -- The *new* type + n_ty = alpha_ty + n_ty_templ = alpha + + (templ,arg_tys,res) = splitTypeWithDictsAsArgs (getIdUniType id) + expr_ty = getListTy res + getListTy res = case res of + UniData lty [ty] | lty `eqTyCon` listTyCon -> ty + _ -> panic "Trying to split a non List datatype into Worker/Wrapper" + + c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty) + c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ) + + worker_ty = mkForallTy (templ ++ [alpha_tv]) + (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ])) + wrapper_id = id `replaceIdInfo` + (getIdInfo id `addInfo_UF` + iWantToBeINLINEd UnfoldAlways) + worker_id = mkWorkerId worker_new_uq id worker_ty + noIdInfo + -- TODO : CHECK if mkWorkerId is thr + -- right function to use .. + -- Now the bodies + + c_id = mkSysLocal SLIT("_fbww") c_new_uq c_ty mkUnknownSrcLoc + n_id = mkSysLocal SLIT("_fbww") n_new_uq n_ty mkUnknownSrcLoc + worker_rhs = foldr CoTyLam + (mkCoLam (args++[c_id,n_id]) worker_body) + (big_args ++ [alpha_tyvar]) + worker_body = runBuiltinUs ( + mkCoApps (mkCoTyApps (CoVar foldrId) [expr_ty, n_ty]) + [CoVar c_id,CoVar n_id,body]) + wrapper_rhs = foldr CoTyLam + (mkCoLam (args) wrapper_body) + big_args + wrapper_body = runBuiltinUs ( + mkCoApps (mkCoTyApp (CoVar buildId) expr_ty) + [CoTyLam alpha_tyvar (mkCoLam [c_id,n_id] + (foldl CoApp + (mkCoTyApps (CoVar worker_id) + [mkTyVarTy t | t <- big_args ++ [alpha_tyvar]]) + (map CoVarAtom (args++[c_id,n_id]))))]) + + in + if length args /= length arg_tys || + length big_args /= length templ + then panic "LEN PROBLEM" + else + returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)] + _ -> returnWw [(id,expr')] +\end{code} + diff --git a/ghc/compiler/simplCore/LiberateCase.hi b/ghc/compiler/simplCore/LiberateCase.hi new file mode 100644 index 0000000..e2b140b --- /dev/null +++ b/ghc/compiler/simplCore/LiberateCase.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface LiberateCase where +import CoreSyn(CoreBinding) +import Id(Id) +liberateCase :: Int -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs new file mode 100644 index 0000000..908f28a --- /dev/null +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -0,0 +1,336 @@ +% +% (c) The AQUA Project, Glasgow University, 1994 +% +\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} + + +\begin{code} +#include "HsVersions.h" + +module LiberateCase ( liberateCase ) where + +IMPORT_Trace + +import Id ( localiseId, toplevelishId{-debugging-} ) +import IdEnv +import Maybes +import Outputable +import PlainCore +import Pretty +import SimplEnv ( UnfoldingGuidance(..) ) +import Util +\end{code} + +This module walks over @Core@, and looks for @case@ on free variables. +The criterion is: + if there is case on a free on the route to the recursive call, + then the recursive call is replaced with an unfolding. + +Example + +\begin{verbatim} +f = \ t -> case v of + V a b -> a : f t +\end{verbatim} + +=> the inner f is replaced. + +\begin{verbatim} +f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> case v of + V a b -> a : f t + in f) t +\end{verbatim} +(note the NEED for shadowing) + +=> Run Andr\'e's wonder pass ... +\begin{verbatim} +f = \ t -> case v of + V a b -> a : (letrec + f = \ t -> a : f t + in f t) +\begin{verbatim} +Better code, because 'a' is free inside the inner letrec, rather +than needing projection from v. + + +To think about (Apr 94) +~~~~~~~~~~~~~~ + +Main worry: duplicating code excessively. At the moment we duplicate +the entire binding group once at each recursive call. But there may +be a group of recursive calls which share a common set of evaluated +free variables, in which case the duplication is a plain waste. + +Another thing we could consider adding is some unfold-threshold thing, +so that we'll only duplicate if the size of the group rhss isn't too +big. + +Data types +~~~~~~~~~~ + +The ``level'' of a binder tells how many +recursive defns lexically enclose the binding +A recursive defn "encloses" its RHS, not its +scope. For example: +\begin{verbatim} + letrec f = let g = ... in ... + in + let h = ... + in ... +\end{verbatim} +Here, the level of @f@ is zero, the level of @g@ is one, +and the level of @h@ is zero (NB not one). + +\begin{code} +type LibCaseLevel = Int + +topLevel :: LibCaseLevel +topLevel = 0 +\end{code} + +\begin{code} +data LibCaseEnv + = LibCaseEnv + Int -- Bomb-out size for deciding if + -- potential liberatees are too big. + -- (passed in from cmd-line args) + + LibCaseLevel -- Current level + + (IdEnv LibCaseLevel) -- Binds all non-top-level in-scope Ids + -- (top-level and imported things have + -- a level of zero) + + (IdEnv PlainCoreBinding)-- Binds *only* recursively defined + -- Ids, to their own binding group, + -- and *only* in their own RHSs + + [(Id,LibCaseLevel)] -- Each of these Ids was scrutinised by an + -- enclosing case expression, with the + -- specified number of enclosing + -- recursive bindings; furthermore, + -- the Id is bound at a lower level + -- than the case expression. The + -- order is insignificant; it's a bag + -- really + +initEnv :: Int -> LibCaseEnv +initEnv bomb_size = LibCaseEnv bomb_size 0 nullIdEnv nullIdEnv [] + +bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size +\end{code} + + +Programs +~~~~~~~~ +\begin{code} +liberateCase :: Int -> [PlainCoreBinding] -> [PlainCoreBinding] +liberateCase bomb_size prog + = do_prog (initEnv bomb_size) prog + where + do_prog env [] = [] + do_prog env (bind:binds) = bind' : do_prog env' binds + where + (env', bind') = libCaseBind env bind +\end{code} + +Bindings +~~~~~~~~ + +\begin{code} +libCaseBind :: LibCaseEnv -> PlainCoreBinding -> (LibCaseEnv, PlainCoreBinding) + +libCaseBind env (CoNonRec binder rhs) + = (addBinders env [binder], CoNonRec binder (libCase env rhs)) + +libCaseBind env (CoRec pairs) + = (env_body, CoRec pairs') + where + (binders, rhss) = unzip pairs + + env_body = addBinders env binders + + pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] + + env_rhs = if all rhs_small_enough rhss then extended_env else env + + -- We extend the rec-env by binding each Id to its rhs, first + -- processing the rhs with an *un-extended* environment, so + -- that the same process doesn't occur for ever! + + extended_env + = addRecBinds env [ (localiseId binder, libCase env_body rhs) + | (binder, rhs) <- pairs ] + + -- Why "localiseId" above? Because we're creating a new local + -- copy of the original binding. In particular, the original + -- binding might have been for a TopLevId, and this copy clearly + -- will not be top-level! + + -- It is enough to change just the binder, because subsequent + -- simplification will propagate the right info from the binder. + + -- Why does it matter? Because the codeGen keeps a separate + -- environment for top-level Ids, and it is disastrous for it + -- to think that something is top-level when it isn't. + + rhs_small_enough rhs + = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of + UnfoldNever -> False + _ -> True -- we didn't BOMB, so it must be OK + + lIBERATE_BOMB_SIZE = bombOutSize env +\end{code} + + +Expressions +~~~~~~~~~~~ + +\begin{code} +libCase :: LibCaseEnv + -> PlainCoreExpr + -> PlainCoreExpr + +libCase env (CoLit lit) = CoLit lit +libCase env (CoVar v) = mkCoLetsNoUnboxed (libCaseId env v) (CoVar v) +libCase env (CoApp fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (CoApp (libCase env fun) arg) +libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty +libCase env (CoCon con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoCon con tys args) +libCase env (CoPrim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (CoPrim op tys args) +libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body) +libCase env (CoSCC cc body) = CoSCC cc (libCase env body) + +libCase env (CoLam binders body) + = CoLam binders (libCase env' body) + where + env' = addBinders env binders + +libCase env (CoLet bind body) + = CoLet bind' (libCase env_body body) + where + (env_body, bind') = libCaseBind env bind + +libCase env (CoCase scrut alts) + = CoCase (libCase env scrut) (libCaseAlts env_alts alts) + where + env_alts = case scrut of + CoVar scrut_var -> addScrutedVar env scrut_var + other -> env +\end{code} + + +Case alternatives +~~~~~~~~~~~~~~~~~ + +\begin{code} +libCaseAlts env (CoAlgAlts alts deflt) + = CoAlgAlts (map do_alt alts) (libCaseDeflt env deflt) + where + do_alt (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) + +libCaseAlts env (CoPrimAlts alts deflt) + = CoPrimAlts (map do_alt alts) (libCaseDeflt env deflt) + where + do_alt (lit,rhs) = (lit, libCase env rhs) + +libCaseDeflt env CoNoDefault + = CoNoDefault +libCaseDeflt env (CoBindDefault binder rhs) + = CoBindDefault binder (libCase (addBinders env [binder]) rhs) +\end{code} + +Atoms and Ids +~~~~~~~~~~~~~ +\begin{code} +libCaseAtoms :: LibCaseEnv -> [PlainCoreAtom] -> [PlainCoreBinding] +libCaseAtoms env atoms = concat [libCaseAtom env atom | atom <- atoms] + +libCaseAtom :: LibCaseEnv -> PlainCoreAtom -> [PlainCoreBinding] +libCaseAtom env (CoVarAtom arg_id) = libCaseId env arg_id +libCaseAtom env (CoLitAtom lit) = [] + +libCaseId :: LibCaseEnv -> Id -> [PlainCoreBinding] +libCaseId env v + | maybeToBool maybe_rec_bind && -- It's a use of a recursive thing + there_are_free_scruts -- with free vars scrutinised in RHS + = [the_bind] + + | otherwise + = [] + + where + maybe_rec_bind :: Maybe PlainCoreBinding -- The binding of the recursive thingy + maybe_rec_bind = lookupRecId env v + Just the_bind = maybe_rec_bind + + rec_id_level = lookupLevel env v + + there_are_free_scruts = freeScruts env rec_id_level +\end{code} + + + +Utility functions +~~~~~~~~~~~~~~~~~ +\begin{code} +addBinders :: LibCaseEnv -> [Id] -> LibCaseEnv +addBinders (LibCaseEnv bomb lvl lvl_env rec_env scruts) binders + = LibCaseEnv bomb lvl lvl_env' rec_env scruts + where + lvl_env' = growIdEnvList lvl_env (binders `zip` repeat lvl) + +addRecBinds :: LibCaseEnv -> [(Id,PlainCoreExpr)] -> LibCaseEnv +addRecBinds (LibCaseEnv bomb lvl lvl_env rec_env scruts) pairs + = LibCaseEnv bomb lvl' lvl_env' rec_env' scruts + where + lvl' = lvl + 1 + lvl_env' = growIdEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs] + rec_env' = growIdEnvList rec_env [(binder, CoRec pairs) | (binder,_) <- pairs] + +addScrutedVar :: LibCaseEnv + -> Id -- This Id is being scrutinised by a case expression + -> LibCaseEnv + +addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var + | bind_lvl < lvl + = LibCaseEnv bomb lvl lvl_env rec_env scruts' + -- Add to scruts iff the scrut_var is being scrutinised at + -- a deeper level than its defn + + | otherwise = env + where + scruts' = (scrut_var, lvl) : scruts + bind_lvl = case lookupIdEnv lvl_env scrut_var of + Just lvl -> lvl + Nothing -> --false: ASSERT(toplevelishId scrut_var) + topLevel + +lookupRecId :: LibCaseEnv -> Id -> Maybe PlainCoreBinding +lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id +#ifndef DEBUG + = lookupIdEnv rec_env id +#else + = case (lookupIdEnv rec_env id) of + xxx@(Just _) -> xxx + xxx -> --false: ASSERT(toplevelishId id) + xxx +#endif + +lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel +lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id + = case lookupIdEnv lvl_env id of + Just lvl -> lvl + Nothing -> ASSERT(toplevelishId id) + topLevel + +freeScruts :: LibCaseEnv + -> LibCaseLevel -- Level of the recursive Id + -> Bool -- True <=> there is an enclosing case of a variable + -- bound outside (ie level <=) the recursive Id. +freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl + = not (null free_scruts) + where + free_scruts = [v | (v,lvl) <- scruts, lvl > rec_bind_lvl] +\end{code} diff --git a/ghc/compiler/simplCore/MagicUFs.hi b/ghc/compiler/simplCore/MagicUFs.hi new file mode 100644 index 0000000..aac448f --- /dev/null +++ b/ghc/compiler/simplCore/MagicUFs.hi @@ -0,0 +1,41 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface MagicUFs where +import BasicLit(BasicLit) +import Class(Class) +import CmdLineOpts(SimplifierSwitch, SwitchResult) +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PlainCore(PlainCoreArg(..), PlainCoreAtom(..), PlainCoreExpr(..)) +import PreludePS(_PackedString) +import PrimOps(PrimOp) +import SimplEnv(EnclosingCcDetails, IdVal, SimplEnv, UnfoldEnv) +import SimplMonad(SimplCount, SmplM(..), TickType) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-} +type PlainCoreArg = CoreArg Id +type PlainCoreAtom = CoreAtom Id +type PlainCoreExpr = CoreExpr Id Id +data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-} +data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-} +type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount) +data TickType {-# GHC_PRAGMA UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +applyMagicUnfoldingFun :: MagicUnfoldingFun -> SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "U(S)LL" {_A_ 3 _U_ 12222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 3 \ (u0 :: SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) (u1 :: SimplEnv) (u2 :: [CoreArg Id]) -> _APP_ u0 [ u1, u2 ] _N_} _F_ _IF_ARGS_ 0 3 CXX 4 \ (u0 :: MagicUnfoldingFun) (u1 :: SimplEnv) (u2 :: [CoreArg Id]) -> case u0 of { _ALG_ _ORIG_ MagicUFs MUF (u3 :: SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) -> _APP_ u3 [ u1, u2 ]; _NO_DEFLT_ } _N_ #-} +mkMagicUnfoldingFun :: _PackedString -> MagicUnfoldingFun + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs new file mode 100644 index 0000000..371c0a7 --- /dev/null +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -0,0 +1,525 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[MagicUFs]{Magic unfoldings that the simplifier knows about} + +\begin{code} +#include "HsVersions.h" + +module MagicUFs ( + MagicUnfoldingFun, -- absolutely abstract + + mkMagicUnfoldingFun, + applyMagicUnfoldingFun, + + CoreArg, PlainCoreArg(..), CoreAtom, PlainCoreAtom(..), + CoreExpr, PlainCoreExpr(..), Id, Maybe, SimplEnv, + SplitUniqSupply, TickType, UniType, + SmplM(..), SimplCount + ) where + +IMPORT_Trace -- ToDo: not sure why this is being used + +import AbsPrel ( foldlId, foldrId, buildId, + nilDataCon, consDataCon, mkListTy, mkFunTy, + unpackCStringAppendId + ) +import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate ) +import BasicLit ( BasicLit(..) ) +import CmdLineOpts ( SimplifierSwitch(..), switchIsOn, SwitchResult ) +import Id +import IdInfo +import Maybes ( Maybe(..), maybeToBool ) +import Outputable +import PlainCore +import Pretty +import SimplEnv +import SimplMonad +import TaggedCore +import Util +\end{code} + +%************************************************************************ +%* * +\subsection{Types, etc., for magic-unfolding functions} +%* * +%************************************************************************ + +\begin{code} +data MagicUnfoldingFun + = MUF ( SimplEnv -- state of play in simplifier... + -- (note: we can get simplifier switches + -- from the SimplEnv) + -> [PlainCoreArg] -- arguments + -> SmplM (Maybe PlainCoreExpr)) + -- Just result, or Nothing +\end{code} + +Give us a string tag, we'll give you back the corresponding MUF. +\begin{code} +mkMagicUnfoldingFun :: FAST_STRING -> MagicUnfoldingFun + +mkMagicUnfoldingFun tag + = assoc ("mkMagicUnfoldingFun:" ++ _UNPK_ tag) magic_UFs_table tag +\end{code} + +Give us an MUF and stuff to apply it to, and we'll give you back the +answer. +\begin{code} +applyMagicUnfoldingFun + :: MagicUnfoldingFun + -> SimplEnv + -> [PlainCoreArg] + -> SmplM (Maybe PlainCoreExpr) + +applyMagicUnfoldingFun (MUF fun) env args = fun env args +\end{code} + +%************************************************************************ +%* * +\subsection{The table of actual magic unfoldings} +%* * +%************************************************************************ + +\begin{code} +magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)] + +magic_UFs_table + = [(SLIT("build"), MUF build_fun), + (SLIT("foldl"), MUF foldl_fun), + (SLIT("foldr"), MUF foldr_fun) ] +\end{code} + +%************************************************************************ +%* * +\subsubsection{Unfolding function for @append@} +%* * +%************************************************************************ + +\begin{code} +-- First build, the way we express our lists. + +build_fun :: SimplEnv + -> [PlainCoreArg] + -> SmplM (Maybe PlainCoreExpr) +build_fun env [TypeArg ty,ValArg (CoVarAtom e)] + | switchIsSet env SimplDoInlineFoldrBuild = + let + tyL = mkListTy ty + ourCons = mkCoTyApp (CoVar consDataCon) ty + ourNil = mkCoTyApp (CoVar nilDataCon) ty + in + newIds [ ty `mkFunTy` (tyL `mkFunTy` tyL), + tyL ] `thenSmpl` \ [c,n] -> + returnSmpl(Just (CoLet (CoNonRec c ourCons) + (CoLet (CoNonRec n ourNil) + (CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) (CoVarAtom n))))) +-- ToDo: add `build' without an argument instance. +-- This is strange, because of g's type. +build_fun env _ = + ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild)) + returnSmpl Nothing + +-- Now foldr, the way we consume lists. + +foldr_fun :: SimplEnv + -> [PlainCoreArg] + -> SmplM (Maybe PlainCoreExpr) +{- +foldr_fun env _ + | trace "HEHJDHF!" False = error "NEVER" +-} +foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args) + | isConsFun env arg_k && isNilForm env arg_z + = -- foldr (:) [] ==> id + -- this transformation is *always* benificial + -- cf. foldr (:) [] (build g) == g (:) [] + -- with foldr (:) [] (build g) == build g + -- after unfolding build, they are the same thing. + tick FoldrConsNil `thenSmpl_` + newId (mkListTy ty1) `thenSmpl` \ x -> + returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args))) + +foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args) + | do_fb_red && isNilForm env arg_list + = -- foldr f z [] = z + -- again another short cut, helps with unroling of constant lists + tick Foldr_Nil `thenSmpl_` + returnSmpl (Just (atomToExpr arg_z)) + + | do_fb_red && arg_list_isBuildForm + = -- foldr k z (build g) ==> g k z + -- this next line *is* the foldr/build rule proper. + tick FoldrBuild `thenSmpl_` + returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))) + + | do_fb_red && arg_list_isAppendForm + = -- foldr k z (foldr (:) ys xs) ==> foldr k (foldr k z ys) xs + -- this unfolds foldr one into foldr + tick FoldrFoldr `thenSmpl_` + newId ty2 `thenSmpl` \ other_foldr -> + let + inner_foldr = applyToArgs (CoVar foldrId) + [TypeArg ty1,TypeArg ty2, + ValArg arg_k,ValArg arg_z,ValArg ys] + outer_foldr = applyToArgs (CoVar foldrId) + ([TypeArg ty1,TypeArg ty2, + ValArg arg_k,ValArg (CoVarAtom other_foldr),ValArg xs] + ++ rest_args) + in returnSmpl (Just (CoLet (CoNonRec other_foldr inner_foldr) outer_foldr)) + + | do_fb_red && arg_list_isListForm + = -- foldr k z (a:b:c:rest) = + -- (\ f -> f a (f b (f c (foldr f z rest)))) k rest_args + -- NB: 'k' is used just one by foldr, but 'f' is used many + -- times inside the list structure. This means that + -- 'f' needs to be inside a lambda, to make sure the simplifier + -- realises this. + -- + -- The structure of + -- f a (f b (f c (foldr f z rest))) + -- in core becomes: + -- let ele_1 = foldr f z rest + -- ele_2 = f c ele_1 + -- ele_3 = f b ele_2 + -- in f a ele_3 + -- + tick Foldr_List `thenSmpl_` + newIds ( + ty1 `mkFunTy` (ty2 `mkFunTy` ty2) : + take (length the_list) (repeat ty2) + ) `thenSmpl` \ (f_id:ele_id1:ele_ids) -> + let + fst_bind = CoNonRec + ele_id1 + (applyToArgs (CoVar foldrId) + [TypeArg ty1,TypeArg ty2, + ValArg (CoVarAtom f_id), + ValArg arg_z, + ValArg the_tl]) + --ToDo: look for a zipWith that checks for the same length of a 3 lists + rest_binds = zipWith3 + (\ e v e' -> CoNonRec e (mkRhs v e')) + ele_ids + (reverse (tail the_list)) + (init (ele_id1:ele_ids)) + mkRhs v e = CoApp (CoApp (CoVar f_id) v) (CoVarAtom e) + core_list = foldr + CoLet + (mkRhs (head the_list) (last (ele_id1:ele_ids))) + (fst_bind:rest_binds) + in + returnSmpl (Just (applyToArgs (CoLam [f_id] core_list) + (ValArg arg_k:rest_args))) + + where + do_fb_red = switchIsSet env SimplDoFoldrBuild + + arg_list_isBuildForm = maybeToBool buildForm + buildForm = getBuildForm env arg_list + (Just g) = buildForm + + arg_list_isListForm = maybeToBool listForm + listForm = getListForm env arg_list + (Just (the_list,the_tl)) = listForm + + arg_list_isAppendForm = maybeToBool appendForm + appendForm = getAppendForm env arg_list + (Just (xs,ys)) = appendForm + +foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) +{- OLD: + | doing_inlining && isConsFun env arg_k + = -- foldr (:) z xs = xs ++ z + tick FoldrCons `thenSmpl_` + newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] -> + returnSmpl (Just (applyToArgs + (CoLam [z,x] (applyToArgs + (CoVar appendId) [ + TypeArg ty1, + ValArg (CoVarAtom x), + ValArg (CoVarAtom z)])) + rest_args)) +-} + | doing_inlining && (isInterestingArg env arg_k + || isConsFun env arg_k) + = -- foldr k args = + -- (\ f z xs -> + -- letrec + -- h x = case x of + -- [] -> z + -- (a:b) -> f a (h b) + -- in + -- h xs) k args + -- + tick FoldrInline `thenSmpl_` + newIds [ + ty1, -- a :: t1 + mkListTy ty1, -- b :: [t1] + ty2, -- v :: t2 + mkListTy ty1, -- x :: t1 + mkListTy ty1 `mkFunTy` ty2, + -- h :: [t1] -> t2 + ty1 `mkFunTy` (ty2 `mkFunTy` ty2), + -- f + ty2, -- z + mkListTy ty1 -- xs + ] `thenSmpl` \ [a,b,v,x,h,f,z,xs] -> + let + h_rhs = (CoLam [x] (CoCase (CoVar x) + (CoAlgAlts + [(nilDataCon,[],atomToExpr (CoVarAtom z)), + (consDataCon,[a,b],body)] + CoNoDefault))) + body = CoLet (CoNonRec v (CoApp (CoVar h) (CoVarAtom b))) + (CoApp (CoApp (atomToExpr (CoVarAtom f)) + (CoVarAtom a)) + (CoVarAtom v)) + in + returnSmpl (Just + (applyToArgs + (CoLam [f,z,xs] + (CoLet (CoRec [(h,h_rhs)]) + (CoApp (CoVar h) (CoVarAtom xs)))) + (ValArg arg_k:rest_args))) + where + doing_inlining = switchIsSet env SimplDoInlineFoldrBuild +foldr_fun _ _ = returnSmpl Nothing + +isConsFun :: SimplEnv -> PlainCoreAtom -> Bool +isConsFun env (CoVarAtom v) = + case lookupUnfolding env v of + GeneralForm _ _ (CoLam [(x,_),(y,_)] + (CoCon con tys [CoVarAtom x',CoVarAtom y'])) _ + | con == consDataCon && x==x' && y==y' + -> ASSERT ( length tys == 1 ) True + _ -> False +isConsFun env _ = False + +isNilForm :: SimplEnv -> PlainCoreAtom -> Bool +isNilForm env (CoVarAtom v) = + case lookupUnfolding env v of + GeneralForm _ _ (CoTyApp (CoVar id) _) _ + | id == nilDataCon -> True + ConstructorForm id _ _ + | id == nilDataCon -> True + LiteralForm (NoRepStr s) | _NULL_ s -> True + _ -> False +isNilForm env _ = False + +getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id +getBuildForm env (CoVarAtom v) = + case lookupUnfolding env v of + GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-( + GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _ + | bld == buildId -> Just g + _ -> Nothing +getBuildForm env _ = Nothing + +getAppendForm :: SimplEnv -> PlainCoreAtom -> Maybe (CoreAtom Id,CoreAtom Id) +getAppendForm env (CoVarAtom v) = + case lookupUnfolding env v of + GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-( + GeneralForm _ _ (CoApp (CoApp (CoApp (CoTyApp (CoTyApp (CoVar fld) _) _) con) ys) xs) _ + | fld == foldrId && isConsFun env con -> Just (xs,ys) + _ -> Nothing +getAppendForm env _ = Nothing + +-- +-- this gets a list of the form a : b : c : d and returns ([a,b,c],d) +-- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = [] +-- + +getListForm + :: SimplEnv + -> PlainCoreAtom + -> Maybe ([PlainCoreAtom],PlainCoreAtom) +getListForm env (CoVarAtom v) = + case lookupUnfolding env v of + ConstructorForm id _ [head,tail] + | id == consDataCon -> + case getListForm env tail of + Nothing -> Just ([head],tail) + Just (lst,new_tail) -> Just (head:lst,new_tail) + _ -> Nothing +getListForm env _ = Nothing + +isInterestingArg :: SimplEnv -> PlainCoreAtom -> Bool +isInterestingArg env (CoVarAtom v) = + case lookupUnfolding env v of + GeneralForm False _ _ UnfoldNever -> False + GeneralForm _ _ exp guide -> True + _ -> False +isInterestingArg env _ = False + +foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args) + | do_fb_red && isNilForm env arg_list + = -- foldl f z [] = z + -- again another short cut, helps with unroling of constant lists + tick Foldr_Nil `thenSmpl_` + returnSmpl (Just (atomToExpr arg_z)) + + | do_fb_red && arg_list_isBuildForm + = -- foldl t1 t2 k z (build t3 g) ==> + -- let c {- INLINE -} = \ b g' a -> g' (f a b) + -- n {- INLINE -} = \ a -> a + -- in g t1 c n z + -- this next line *is* the foldr/build rule proper. + tick FoldrBuild `thenSmpl_` + -- c :: t2 -> (t1 -> t1) -> t1 -> t1 + -- n :: t1 -> t1 + newIds [ + {- pre_c -} ty2 `mkFunTy` ((ty1 `mkFunTy` ty1) `mkFunTy` (ty1 `mkFunTy` ty1)), + {- pre_n -} ty1 `mkFunTy` ty1, + {- b -} ty2, + {- g' -} ty1 `mkFunTy` ty1, + {- a -} ty1, + {- a' -} ty1, + {- t -} ty1 + ] `thenSmpl` \ [pre_c, + pre_n, + b, + g', + a, + a', + t] -> + + let + c = addIdUnfolding pre_c (iWantToBeINLINEd UnfoldAlways) + c_rhs = CoLam [b,g',a] + (CoLet (CoNonRec t (CoApp (CoApp (atomToExpr arg_k) (CoVarAtom a)) (CoVarAtom b))) + (CoApp (CoVar g') (CoVarAtom t))) + n = addIdUnfolding pre_n (iWantToBeINLINEd UnfoldAlways) + n_rhs = CoLam [a'] (CoVar a') + in + returnSmpl (Just (CoLet (CoNonRec c c_rhs) (CoLet (CoNonRec n n_rhs) + (applyToArgs (CoVar g) + (TypeArg (ty1 `mkFunTy` ty1):ValArg (CoVarAtom c):ValArg (CoVarAtom n) + :ValArg arg_z:rest_args))))) + + + | do_fb_red && arg_list_isAppendForm + = -- foldl k z (foldr (:) ys xs) ==> foldl k (foldl k z xs) ys + -- be caseful with for order of xs / ys + tick FoldrFoldr `thenSmpl_` + newId ty1 `thenSmpl` \ other_foldl -> + let + inner_foldl = applyToArgs (CoVar foldlId) + [TypeArg ty1,TypeArg ty2, + ValArg arg_k,ValArg arg_z,ValArg xs] + outer_foldl = applyToArgs (CoVar foldlId) + ([TypeArg ty1,TypeArg ty2, + ValArg arg_k,ValArg (CoVarAtom other_foldl),ValArg ys] + ++ rest_args) + in returnSmpl (Just (CoLet (CoNonRec other_foldl inner_foldl) outer_foldl)) + + | do_fb_red && arg_list_isListForm + = -- foldl k z (a:b:c:rest) = + -- (\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args + -- NB: 'k' is used just one by foldr, but 'f' is used many + -- times inside the list structure. This means that + -- 'f' needs to be inside a lambda, to make sure the simplifier + -- realises this. + -- + -- The structure of + -- foldl f (f (f (f z a) b) c) rest + -- f a (f b (f c (foldr f z rest))) + -- in core becomes: + -- let ele_1 = f z a + -- ele_2 = f ele_1 b + -- ele_3 = f ele_2 c + -- in foldl f ele_3 rest + -- + tick Foldr_List `thenSmpl_` + newIds ( + ty1 `mkFunTy` (ty2 `mkFunTy` ty1) : + take (length the_list) (repeat ty1) + ) `thenSmpl` \ (f_id:ele_ids) -> + let + --ToDo: look for a zipWith that checks for the same length of a 3 lists + rest_binds = zipWith3 + (\ e v e' -> CoNonRec e (mkRhs v e')) + ele_ids -- :: [Id] + the_list -- :: [PlainCoreAtom] + (init (arg_z:map CoVarAtom ele_ids)) -- :: [PlainCoreAtom] + mkRhs v e = CoApp (CoApp (CoVar f_id) e) v + + last_bind = applyToArgs (CoVar foldlId) + [TypeArg ty1,TypeArg ty2, + ValArg (CoVarAtom f_id), + ValArg (CoVarAtom (last ele_ids)), + ValArg the_tl] + core_list = foldr + CoLet + last_bind + rest_binds + in + returnSmpl (Just (applyToArgs (CoLam [f_id] core_list) + (ValArg arg_k:rest_args))) + + where + do_fb_red = switchIsSet env SimplDoFoldrBuild + + arg_list_isBuildForm = maybeToBool buildForm + buildForm = getBuildForm env arg_list + (Just g) = buildForm + + arg_list_isListForm = maybeToBool listForm + listForm = getListForm env arg_list + (Just (the_list,the_tl)) = listForm + + arg_list_isAppendForm = maybeToBool appendForm + appendForm = getAppendForm env arg_list + (Just (xs,ys)) = appendForm + +foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args) + | doing_inlining && (isInterestingArg env arg_k + || isConsFun env arg_k) + = -- foldl k args = + -- (\ f z xs -> + -- letrec + -- h x r = case x of + -- [] -> r + -- (a:b) -> h b (f r a) + -- in + -- h xs z) k args + -- + tick FoldrInline `thenSmpl_` + newIds [ + ty2, -- a :: t1 + mkListTy ty2, -- b :: [t1] + ty1, -- v :: t2 + mkListTy ty2, -- x :: t1 + mkListTy ty2 `mkFunTy` (ty1 `mkFunTy` ty1), + -- h :: [t2] -> t1 -> t1 + ty1 `mkFunTy` (ty2 `mkFunTy` ty1), + -- f + ty1, -- z + mkListTy ty2, -- xs + ty1 -- r + ] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] -> + let + h_rhs = (CoLam [x,r] (CoCase (CoVar x) + (CoAlgAlts + [(nilDataCon,[],atomToExpr (CoVarAtom r)), + (consDataCon,[a,b],body)] + CoNoDefault))) + body = CoLet (CoNonRec v (CoApp (CoApp (CoVar f) (CoVarAtom r)) + (CoVarAtom a))) + (CoApp (CoApp (atomToExpr (CoVarAtom h)) + (CoVarAtom b)) + (CoVarAtom v)) + in + returnSmpl (Just + (applyToArgs + (CoLam [f,z,xs] + (CoLet (CoRec [(h,h_rhs)]) + (CoApp (CoApp (CoVar h) (CoVarAtom xs)) + (CoVarAtom z)))) + (ValArg arg_k:rest_args))) + where + doing_inlining = switchIsSet env SimplDoInlineFoldrBuild + +foldl_fun env _ = returnSmpl Nothing +\end{code} + diff --git a/ghc/compiler/simplCore/NewOccurAnal.hi b/ghc/compiler/simplCore/NewOccurAnal.hi new file mode 100644 index 0000000..e98a46d --- /dev/null +++ b/ghc/compiler/simplCore/NewOccurAnal.hi @@ -0,0 +1,31 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface NewOccurAnal where +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CmdLineOpts(GlobalSwitch, SimplifierSwitch) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..)) +import PrimOps(PrimOp) +import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..)) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreExpr = CoreExpr Id Id +type PlainCoreProgram = [CoreBinding Id Id] +type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id +type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id +newOccurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id] + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _N_ #-} +newOccurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/NewOccurAnal.lhs b/ghc/compiler/simplCore/NewOccurAnal.lhs new file mode 100644 index 0000000..5cfd563 --- /dev/null +++ b/ghc/compiler/simplCore/NewOccurAnal.lhs @@ -0,0 +1,720 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[NewOccurAnal]{The *New* Occurrence analysis pass} +%* * +%************************************************************************ + +The occurrence analyser analyses the way in which variables are used +in their scope, and pins that information on the binder. It does {\em +not} take any strategic decisions about what to do as a result (eg +discard binding, inline binding etc). That's the job of the +simplifier. + +The occurrence analyser {\em simply} records usage information. That is, +it pins on each binder info on how that binder occurs in its scope. + +Any uses within the RHS of a let(rec) binding for a variable which is +itself unused are ignored. For example: +@ + let x = ... + y = ...x... + in + x+1 +@ +Here, y is unused, so x will be marked as appearing just once. + +An exported Id gets tagged as ManyOcc. + +IT MUST OBSERVE SCOPING: CANNOT assume unique binders. + +Lambdas +~~~~~~~ +The occurrence analyser marks each binder in a lambda the same way. +Thus: + \ x y -> f y x +will have both x and y marked as single occurrence, and *not* dangerous-to-dup. +Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup, +but the simplifer very carefully takes care of this special case. +(See the CoLam case in simplExpr.) + +Why? Because typically applications are saturated, in which case x is *not* +dangerous-to-dup. + +Things to muse upon +~~~~~~~~~~~~~~~~~~~ + +There *is* a reason not to substitute for +variables applied to types: it can undo the effect of floating +Consider: +\begin{verbatim} + c = /\a -> e + f = /\b -> let d = c b + in \ x::b -> ... +\end{verbatim} +Here, inlining c would be a Bad Idea. + +At present I've set it up so that the "inside-lambda" flag sets set On +for type-lambdas too, which effectively prevents such substitutions. +I don't *think* it disables any interesting ones either. + +Oh yes it does. +Consider + + let { (u6.sAMi, <1,0>) = (_build s141374) ua.sALY } in + let { + (ua.sAMj, <1,0>) = + /\ s141380 -> \ (u5.sAM1, <2,0>) (u6.sAMl, <2,0>) -> + let { + (u9.sAM7, <2,0>) = + \ (u7.sAM2, <3,0>) -> + let { (u8.sAM3, <3,0>) = f.sALV u7.sAM2 + } in u5.sAM1 u8.sAM3 + } in ((foldr s141374) s141380) u9.sAM7 u6.sAMl u6.sAMi + } in (_build s141376) ua.sAMj] + +I want to `inline' u6.sAMi, via the foldr/build rule, +but I cant. So I need to inline through /\. I only do it when +I've got a `linear' stack, ie actually real arguments still to apply. + +\begin{code} +#include "HsVersions.h" + +module NewOccurAnal ( + newOccurAnalyseBinds, newOccurAnalyseExpr, + + -- and to make the interface self-sufficient... + CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch, + PlainCoreProgram(..), PlainCoreExpr(..), + SimplifiableCoreExpr(..), SimplifiableCoreBinding(..) + ) where + +IMPORT_Trace +import Outputable -- ToDo: rm; debugging +import Pretty + +import PlainCore -- the stuff we read... +import TaggedCore -- ... and produce Simplifiable* + +import AbsUniType +import BinderInfo +import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) ) +import Digraph ( stronglyConnComp ) +import Id ( eqId, idWantsToBeINLINEd, isConstMethodId, + isSpecPragmaId_maybe, getIdArgUsageInfo, + SpecInfo + ) +import IdInfo -- ( ArgUsage(..), ArgUsageInfo, OptIdInfo(..), getArgUsage) +import IdEnv +import Maybes +import UniqSet +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection[OccurAnal-types]{Data types} +%* * +%************************************************************************ + +\begin{code} +data OccEnv = OccEnv + Bool -- Keep-unused-bindings flag + -- False <=> OK to chuck away binding + -- and ignore occurrences within it + Bool -- Keep-spec-pragma-ids flag + -- False <=> OK to chuck away spec pragma bindings + -- and ignore occurrences within it + Bool -- Keep-conjurable flag + -- False <=> OK to throw away *dead* + -- "conjurable" Ids; at the moment, that + -- *only* means constant methods, which + -- are top-level. A use of a "conjurable" + -- Id may appear out of thin air -- e.g., + -- specialiser conjuring up refs to const + -- methods. + Bool -- IgnoreINLINEPragma flag + -- False <=> OK to use INLINEPragma information + -- True <=> ignore INLINEPragma information + (UniqSet Id) -- Candidates + +addNewCands :: OccEnv -> [Id] -> OccEnv +addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids + = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids) + +addNewCand :: OccEnv -> Id -> OccEnv +addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id + = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id) + +isCandidate :: OccEnv -> Id -> Bool +isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands + +ignoreINLINEPragma :: OccEnv -> Bool +ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma + +keepUnusedBinding :: OccEnv -> Id -> Bool +keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder + = keep_dead || (keep_spec && is_spec) + where + is_spec = maybeToBool (isSpecPragmaId_maybe binder) + +keepBecauseConjurable :: OccEnv -> Id -> Bool +keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder + = keep_conjurable && is_conjurable + where + is_conjurable = isConstMethodId binder + +type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage + +combineUsageDetails, combineAltsUsageDetails + :: UsageDetails -> UsageDetails -> UsageDetails + +combineUsageDetails usage1 usage2 + = --BSCC("combineUsages") + combineIdEnvs combineBinderInfo usage1 usage2 + --ESCC + +combineAltsUsageDetails usage1 usage2 + = --BSCC("combineUsages") + combineIdEnvs combineAltsBinderInfo usage1 usage2 + --ESCC + +addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails +addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info) + -- ToDo: make this more efficient + +emptyDetails = (nullIdEnv :: UsageDetails) + +unitDetails id info = (unitIdEnv id info :: UsageDetails) + +tagBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [(Id,BinderInfo)]) -- Tagged binders + +tagBinders usage binders + = (usage `delManyFromIdEnv` binders, + [(binder, usage_of usage binder) | binder <- binders] + ) + +tagBinder :: UsageDetails -- Of scope + -> Id -- Binders + -> (UsageDetails, -- Details with binders removed + (Id,BinderInfo)) -- Tagged binders + +tagBinder usage binder + = (usage `delOneFromIdEnv` binder, + (binder, usage_of usage binder) + ) + +usage_of usage binder + | isExported binder = ManyOcc 0 -- Exported things count as many + | otherwise + = case lookupIdEnv usage binder of + Nothing -> DeadCode + Just info -> info + +fixStkToZero :: Id -> UsageDetails -> UsageDetails +fixStkToZero id env = modifyIdEnv env setBinderInfoArityToZero id + +isNeeded env usage binder + = case usage_of usage binder of + DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway + other -> True +\end{code} + + +%************************************************************************ +%* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +%* * +%************************************************************************ + +Here's the externally-callable interface: + +\begin{code} +newOccurAnalyseBinds + :: [PlainCoreBinding] -- input + -> (GlobalSwitch -> Bool) + -> (SimplifierSwitch -> Bool) + -> [SimplifiableCoreBinding] -- output + +newOccurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr + | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds' + | otherwise = binds' + where + (_, binds') = do initial_env binds + + initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings) + (simplifier_sw_chkr KeepSpecPragmaIds) + (not (simplifier_sw_chkr SimplMayDeleteConjurableIds)) + (simplifier_sw_chkr IgnoreINLINEPragma) + emptyUniqSet + + do env [] = (emptyDetails, []) + do env (bind:binds) + = (final_usage, new_binds ++ the_rest) + where + new_env = env `addNewCands` (bindersOf bind) + (binds_usage, the_rest) = do new_env binds + (final_usage, new_binds) = --BSCC("occAnalBind1") + occAnalBind env bind binds_usage + --ESCC +\end{code} + +\begin{code} +newOccurAnalyseExpr :: UniqSet Id -- Set of interesting free vars + -> PlainCoreExpr + -> (IdEnv BinderInfo, -- Occ info for interesting free vars + SimplifiableCoreExpr) + +newOccurAnalyseExpr candidates expr + = occAnal initial_env initContext expr + where + initial_env = OccEnv False {- Drop unused bindings -} + False {- Drop SpecPragmaId bindings -} + True {- Keep conjurable Ids -} + False {- Do not ignore INLINE Pragma -} + candidates + +newOccurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr +newOccurAnalyseGlobalExpr expr + = -- Top level expr, so no interesting free vars, and + -- discard occurence info returned + expr' where (_, expr') = newOccurAnalyseExpr emptyUniqSet expr +\end{code} + +%************************************************************************ +%* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +%* * +%************************************************************************ + +Bindings +~~~~~~~~ + +\begin{code} +occAnalBind :: OccEnv + -> PlainCoreBinding + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [SimplifiableCoreBinding]) + +occAnalBind env (CoNonRec binder rhs) body_usage + | isNeeded env body_usage binder -- It's mentioned in body + = (final_body_usage `combineUsageDetails` rhs_usage, + [CoNonRec tagged_binder rhs']) + + | otherwise + = (body_usage, []) + + where + stk = mkContextFromBinderInfo (usage_of body_usage binder) + (rhs_usage, rhs') = occAnalRhs env binder stk rhs + (final_body_usage, tagged_binder) = tagBinder body_usage binder + +occAnalBind env (CoRec [(binder,rhs)]) body_usage + | getContextSize after_stk < getContextSize stk && mentions_itself + -- our pre-condition does not hold! + -- so, we have to go back, and + -- *make* of pre-condition hold. + -- Will, you can leave out this trace + = {-pprTrace ("after_stk < stk (BAD, BAD, VERY VERY BAD):" + ++ show (getContextSize after_stk,getContextSize stk)) (ppr PprDebug binder) -} + (occAnalBind env (CoRec [(binder,rhs)]) (fixStkToZero binder body_usage)) + + | isNeeded env body_usage binder -- It's mentioned in body + = --BSCC("occAnalBindC") + (final_usage, [final_bind]) + --ESCC + + | otherwise + = --BSCC("occAnalBindD") + (body_usage, []) + --ESCC + + where + stk = shareContext (mkContextFromBinderInfo (usage_of body_usage binder)) + new_env = env `addNewCand` binder + (rhs_usage, rhs') = occAnalRhs new_env binder stk rhs + total_usage = combineUsageDetails body_usage rhs_usage + (final_usage, tagged_binder) = tagBinder total_usage binder + + after_stk = mkContextFromBinderInfo (usage_of rhs_usage binder) + + final_bind = if mentions_itself + then CoRec [(tagged_binder,rhs')] + else CoNonRec tagged_binder rhs' + + mentions_itself = maybeToBool (lookupIdEnv rhs_usage binder) +\end{code} + +Dropping dead code for recursive bindings is done in a very simple way: + + the entire set of bindings is dropped if none of its binders are + mentioned in its body; otherwise none are. + +This seems to miss an obvious improvement. +@ + letrec f = ...g... + g = ...f... + in + ...g... + +===> + + letrec f = ...g... + g = ...(...g...)... + in + ...g... +@ + +Now @f@ is unused. But dependency analysis will sort this out into a +@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped. +It isn't easy to do a perfect job in one blow. Consider + +@ + letrec f = ...g... + g = ...h... + h = ...k... + k = ...m... + m = ...m... + in + ...m... +@ + + +\begin{code} +occAnalBind env (CoRec pairs) body_usage + = foldr do_final_bind (body_usage, []) sccs + where + + (binders, rhss) = unzip pairs + new_env = env `addNewCands` binders + + analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))] + analysed_pairs = [(id, occAnalRhs new_env id initContext rhs) | (id,rhs) <- pairs] + + lookup :: Id -> (UsageDetails, SimplifiableCoreExpr) + lookup id = assoc "occAnalBind:lookup" analysed_pairs id + + + ---- stuff for dependency analysis of binds ------------------------------- + + edges :: [(Id,Id)] -- (a,b) means a mentions b + edges = concat [ edges_from binder rhs_usage + | (binder, (rhs_usage, _)) <- analysed_pairs] + + edges_from :: Id -> UsageDetails -> [(Id,Id)] + edges_from id its_rhs_usage + = [(id,mentioned) | mentioned <- binders, + maybeToBool (lookupIdEnv its_rhs_usage mentioned) + ] + + sccs :: [[Id]] + sccs = case binders of + [_] -> [binders] -- Singleton; no need to analyse + other -> stronglyConnComp eqId edges binders + + ---- stuff to "re-constitute" bindings from dependency-analysis info ------ + + do_final_bind sCC@[binder] (body_usage, binds_so_far) + | isNeeded env body_usage binder + = (combined_usage, new_bind:binds_so_far) + + | otherwise -- Dead + = (body_usage, binds_so_far) + where + total_usage = combineUsageDetails body_usage rhs_usage + (rhs_usage, rhs') = lookup binder + (combined_usage, tagged_binder) = tagBinder total_usage binder + + new_bind + | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')] + | otherwise = CoNonRec tagged_binder rhs' + where + mentions_itself binder usage + = maybeToBool (lookupIdEnv usage binder) + + do_final_bind sCC (body_usage, binds_so_far) + | any (isNeeded env body_usage) sCC + = (combined_usage, new_bind:binds_so_far) + + | otherwise -- Dead + = (body_usage, binds_so_far) + where + (rhs_usages, rhss') = unzip (map lookup sCC) + total_usage = foldr combineUsageDetails body_usage rhs_usages + (combined_usage, tagged_binders) = tagBinders total_usage sCC + + new_bind = CoRec (tagged_binders `zip` rhss') +\end{code} + +@occAnalRhs@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that ths +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +\begin{code} +occAnalRhs :: OccEnv + -> Id -- Binder + -> Context -- Stack Style Context + -> PlainCoreExpr -- Rhs + -> (UsageDetails, SimplifiableCoreExpr) + +occAnalRhs env id stk rhs + | idWantsToBeINLINEd id && not (ignoreINLINEPragma env) + = (mapIdEnv markMany rhs_usage, rhs') + + | otherwise + = (rhs_usage, rhs') + + where + (rhs_usage, rhs') = occAnal env stk rhs +\end{code} + +Expressions +~~~~~~~~~~~ +\begin{code} +occAnal :: OccEnv + -> Context + -> PlainCoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + SimplifiableCoreExpr) + +occAnal env stk (CoVar v) + | isCandidate env v + = (unitIdEnv v (funOccurrence (getContextSize stk)), CoVar v) + + | otherwise + = (emptyDetails, CoVar v) + +occAnal env _ (CoLit lit) = (emptyDetails, CoLit lit) +-- PERHAPS ASSERT THAT STACK == 0 ? +occAnal env _ (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args) +occAnal env _ (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args) + +occAnal env stk (CoSCC lbl body) + = (mapIdEnv markInsideSCC usage, CoSCC lbl body') + where + (usage, body') = occAnal env initContext body + +occAnal env stk (CoApp fun arg) + = occAnalApp env (incContext stk) [ValArg arg] fun +occAnal env stk (CoTyApp fun arg) + = occAnalApp env stk [TypeArg arg] fun +{- +occAnal env (CoApp fun arg) + = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg) + where + (fun_usage, fun') = occAnal env fun + arg_usage = occAnalAtom env arg + +occAnal env (CoTyApp fun ty) + = (fun_usage, CoTyApp fun' ty) + where + (fun_usage, fun') = occAnal env fun +-} +occAnal env stk (CoLam binders body) | isLinContext stk + = (final_usage, mkCoLam tagged_binders body') + where + (lin_binders,other_binders) = splitAt (getContextSize stk) binders + new_env = env `addNewCands` lin_binders + (body_usage, body') = occAnal new_env (lamOnContext stk (length lin_binders)) + (mkCoLam other_binders body) + (final_usage, tagged_binders) = tagBinders body_usage lin_binders + +occAnal env stk (CoLam binders body) + = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body') + where + new_env = env `addNewCands` binders + (body_usage, body') = occAnal new_env (lamOnContext stk (length binders)) body + (final_usage, tagged_binders) = tagBinders body_usage binders + +{- +occAnal env (CoLam binders body) + = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body') + where + new_env = env `addNewCands` binders + (body_usage, body') = occAnal new_env body + (final_usage, tagged_binders) = tagBinders body_usage binders +-} + +occAnal env stk (CoTyLam tyvar body) + = (new_body_usage, CoTyLam tyvar body') + where + (body_usage, body') = occAnal env stk body + new_body_usage = if isLinContext stk + then body_usage + else mapIdEnv markDangerousToDup body_usage + +occAnal env stk (CoCase scrut alts) + = (scrut_usage `combineUsageDetails` alts_usage, + CoCase scrut' alts') + where + (scrut_usage, scrut') = occAnal env initContext scrut + (alts_usage, alts') = occAnalAlts env stk alts + + +occAnal env stk (CoLet bind body) + = (final_usage , foldr CoLet body' new_binds) -- mkCoLets* wants PlainCore... (sigh) + where + new_env = env `addNewCands` (bindersOf bind) + (body_usage, body') = occAnal new_env stk {- ?? -} body + (final_usage, new_binds) = --BSCC("occAnalBind2") + occAnalBind env bind body_usage + --ESCC +\end{code} + +Case alternatives +~~~~~~~~~~~~~~~~~ +\begin{code} +occAnalAlts env stk (CoAlgAlts alts deflt) + = (foldr combineAltsUsageDetails deflt_usage alts_usage, + -- Note: combine*Alts*UsageDetails... + CoAlgAlts alts' deflt') + where + (alts_usage, alts') = unzip (map do_alt alts) + (deflt_usage, deflt') = occAnalDeflt env stk deflt + + do_alt (con, args, rhs) + = (final_usage, (con, tagged_args, rhs')) + where + new_env = env `addNewCands` args + (rhs_usage, rhs') = occAnal new_env stk rhs + (final_usage, tagged_args) = tagBinders rhs_usage args + +occAnalAlts env stk (CoPrimAlts alts deflt) + = (foldr combineAltsUsageDetails deflt_usage alts_usage, + -- Note: combine*Alts*UsageDetails... + CoPrimAlts alts' deflt') + where + (alts_usage, alts') = unzip (map do_alt alts) + (deflt_usage, deflt') = occAnalDeflt env stk deflt + + do_alt (lit, rhs) + = (rhs_usage, (lit, rhs')) + where + (rhs_usage, rhs') = occAnal env stk rhs + +occAnalDeflt env stk CoNoDefault = (emptyDetails, CoNoDefault) + +occAnalDeflt env stk (CoBindDefault binder rhs) + = (final_usage, CoBindDefault tagged_binder rhs') + where + new_env = env `addNewCand` binder + (rhs_usage, rhs') = occAnal new_env stk rhs + (final_usage, tagged_binder) = tagBinder rhs_usage binder +\end{code} + + +Atoms +~~~~~ +\begin{code} +occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails + +occAnalAtoms env atoms + = foldr do_one_atom emptyDetails atoms + where + do_one_atom (CoLitAtom lit) usage = usage + do_one_atom (CoVarAtom v) usage + | isCandidate env v = addOneOcc usage v (argOccurrence 0) + | otherwise = usage + + +occAnalArgAtoms :: OccEnv -> [(PlainCoreAtom,ArgUsage)] -> UsageDetails +occAnalArgAtoms env atoms + = foldr do_one_atom emptyDetails atoms + where + do_one_atom (CoLitAtom lit,_) usage = usage + do_one_atom (CoVarAtom v,ArgUsage ar) usage + | isCandidate env v = addOneOcc usage v (argOccurrence ar) + | otherwise = usage + do_one_atom (CoVarAtom v,UnknownArgUsage) usage + | isCandidate env v = addOneOcc usage v (argOccurrence 0) + | otherwise = usage + +occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails + +occAnalAtom env (CoLitAtom lit) = emptyDetails +occAnalAtom env (CoVarAtom v) + | isCandidate env v = unitDetails v (argOccurrence 0) + | otherwise = emptyDetails +-- +-- This function looks for (fully) applied calls to special ids. +-- +occAnalApp + :: OccEnv + -> Context + -> [PlainCoreArg] + -> PlainCoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + SimplifiableCoreExpr) +occAnalApp env stk args fun@(CoVar v) + | not (null aut) + && getContextSize stk >= length aut -- fully applied + = (fun_usage `combineUsageDetails` arg_usages, + applyToArgs fun' args) + where + val_args = [ x | ValArg x <- args ] + aut = getArgUsage (getIdArgUsageInfo v) + (fun_usage, fun') = occAnal env stk fun + arg_usages = occAnalArgAtoms env (zip val_args aut) +occAnalApp env stk args (CoApp fun arg) + = occAnalApp env (incContext stk) (ValArg arg:args) fun +occAnalApp env stk args (CoTyApp fun arg) + = occAnalApp env stk (TypeArg arg:args) fun +occAnalApp env stk args fun + = (fun_usage `combineUsageDetails` arg_usages, + applyToArgs fun' args) + where + (fun_usage, fun') = occAnal env stk fun + arg_usages = occAnalAtoms env val_args + val_args = [ x | ValArg x <- args ] +\end{code} + +%************************************************************************ +%* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +%* * +%************************************************************************ + + +Abstract, but simple rep. for stacks. +\begin{code} +data Context = Context Int Bool -- if b then n > 0 + +lamOnContext :: Context -> Int -> Context +lamOnContext (Context n b) i = mkContext (max 0 (n - i)) b + +isLinContext :: Context -> Bool +isLinContext (Context n b) = b + +getContextSize :: Context -> Int +getContextSize (Context n b) = n + +incContext :: Context -> Context +incContext (Context n u) = Context (n + 1) u + +initContext :: Context +initContext = Context 0 False + +shareContext :: Context -> Context +shareContext (Context n u) = mkContext n False + +mkContext :: Int -> Bool -> Context +mkContext 0 _ = Context 0 False +mkContext i b = Context i b + +mkContextFromBinderInfo :: BinderInfo -> Context +mkContextFromBinderInfo (DeadCode) = mkContext 0 False +mkContextFromBinderInfo (ManyOcc i) = mkContext i False +mkContextFromBinderInfo bi@(OneOcc _ _ _ _ i) + = mkContext i (oneSafeOcc True bi) +\end{code} + diff --git a/ghc/compiler/simplCore/OccurAnal.hi b/ghc/compiler/simplCore/OccurAnal.hi new file mode 100644 index 0000000..b1aa258 --- /dev/null +++ b/ghc/compiler/simplCore/OccurAnal.hi @@ -0,0 +1,33 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface OccurAnal where +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CmdLineOpts(GlobalSwitch, SimplifierSwitch) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..)) +import PrimOps(PrimOp) +import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..)) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreExpr = CoreExpr Id Id +type PlainCoreProgram = [CoreBinding Id Id] +type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id +type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id +occurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id] + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _N_ #-} +occurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +occurAnalyseGlobalExpr :: CoreExpr Id Id -> CoreExpr (Id, BinderInfo) Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs new file mode 100644 index 0000000..6445d56 --- /dev/null +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -0,0 +1,546 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[OccurAnal]{Occurrence analysis pass} +%* * +%************************************************************************ + +The occurrence analyser analyses the way in which variables are used +in their scope, and pins that information on the binder. It does {\em +not} take any strategic decisions about what to do as a result (eg +discard binding, inline binding etc). That's the job of the +simplifier. + +The occurrence analyser {\em simply} records usage information. That is, +it pins on each binder info on how that binder occurs in its scope. + +Any uses within the RHS of a let(rec) binding for a variable which is +itself unused are ignored. For example: +@ + let x = ... + y = ...x... + in + x+1 +@ +Here, y is unused, so x will be marked as appearing just once. + +An exported Id gets tagged as ManyOcc. + +IT MUST OBSERVE SCOPING: CANNOT assume unique binders. + +Lambdas +~~~~~~~ +The occurrence analyser marks each binder in a lambda the same way. +Thus: + \ x y -> f y x +will have both x and y marked as single occurrence, and *not* dangerous-to-dup. +Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup, +but the simplifer very carefully takes care of this special case. +(See the CoLam case in simplExpr.) + +Why? Because typically applications are saturated, in which case x is *not* +dangerous-to-dup. + +Things to muse upon +~~~~~~~~~~~~~~~~~~~ + +There *is* a reason not to substitute for +variables applied to types: it can undo the effect of floating +Consider: +\begin{verbatim} + c = /\a -> e + f = /\b -> let d = c b + in \ x::b -> ... +\end{verbatim} +Here, inlining c would be a Bad Idea. + +At present I've set it up so that the "inside-lambda" flag sets set On for +type-lambdas too, which effectively prevents such substitutions. I don't *think* +it disables any interesting ones either. + +\begin{code} +#include "HsVersions.h" + +module OccurAnal ( + occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, + + -- and to make the interface self-sufficient... + CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch, + PlainCoreProgram(..), PlainCoreExpr(..), + SimplifiableCoreExpr(..), SimplifiableCoreBinding(..) + ) where + +IMPORT_Trace +import Outputable -- ToDo: rm; debugging +import Pretty + +import PlainCore -- the stuff we read... +import TaggedCore -- ... and produce Simplifiable* + +import AbsUniType +import BinderInfo +import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) ) +import Digraph ( stronglyConnComp ) +import Id ( eqId, idWantsToBeINLINEd, isConstMethodId, + isSpecPragmaId_maybe, SpecInfo ) +import IdEnv +import Maybes +import UniqSet +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection[OccurAnal-types]{Data types} +%* * +%************************************************************************ + +\begin{code} +data OccEnv = OccEnv + Bool -- Keep-unused-bindings flag + -- False <=> OK to chuck away binding + -- and ignore occurrences within it + Bool -- Keep-spec-pragma-ids flag + -- False <=> OK to chuck away spec pragma bindings + -- and ignore occurrences within it + Bool -- Keep-conjurable flag + -- False <=> OK to throw away *dead* + -- "conjurable" Ids; at the moment, that + -- *only* means constant methods, which + -- are top-level. A use of a "conjurable" + -- Id may appear out of thin air -- e.g., + -- specialiser conjuring up refs to const + -- methods. + Bool -- IgnoreINLINEPragma flag + -- False <=> OK to use INLINEPragma information + -- True <=> ignore INLINEPragma information + (UniqSet Id) -- Candidates + +addNewCands :: OccEnv -> [Id] -> OccEnv +addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids + = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids) + +addNewCand :: OccEnv -> Id -> OccEnv +addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id + = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id) + +isCandidate :: OccEnv -> Id -> Bool +isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands + +ignoreINLINEPragma :: OccEnv -> Bool +ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma + +keepUnusedBinding :: OccEnv -> Id -> Bool +keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder + = keep_dead || (keep_spec && is_spec) + where + is_spec = maybeToBool (isSpecPragmaId_maybe binder) + +keepBecauseConjurable :: OccEnv -> Id -> Bool +keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder + = keep_conjurable && is_conjurable + where + is_conjurable = isConstMethodId binder + +type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage + +combineUsageDetails, combineAltsUsageDetails + :: UsageDetails -> UsageDetails -> UsageDetails + +combineUsageDetails usage1 usage2 + = --BSCC("combineUsages") + combineIdEnvs combineBinderInfo usage1 usage2 + --ESCC + +combineAltsUsageDetails usage1 usage2 + = --BSCC("combineUsages") + combineIdEnvs combineAltsBinderInfo usage1 usage2 + --ESCC + +addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails +addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info) + -- ToDo: make this more efficient + +emptyDetails = (nullIdEnv :: UsageDetails) + +unitDetails id info = (unitIdEnv id info :: UsageDetails) + +tagBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [(Id,BinderInfo)]) -- Tagged binders + +tagBinders usage binders + = (usage `delManyFromIdEnv` binders, + [(binder, usage_of usage binder) | binder <- binders] + ) + +tagBinder :: UsageDetails -- Of scope + -> Id -- Binders + -> (UsageDetails, -- Details with binders removed + (Id,BinderInfo)) -- Tagged binders + +tagBinder usage binder + = (usage `delOneFromIdEnv` binder, + (binder, usage_of usage binder) + ) + +usage_of usage binder + | isExported binder = ManyOcc 0 -- Exported things count as many + | otherwise + = case lookupIdEnv usage binder of + Nothing -> DeadCode + Just info -> info + +isNeeded env usage binder + = case usage_of usage binder of + DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway + other -> True +\end{code} + + +%************************************************************************ +%* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +%* * +%************************************************************************ + +Here's the externally-callable interface: + +\begin{code} +occurAnalyseBinds + :: [PlainCoreBinding] -- 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' + where + (_, binds') = do initial_env binds + + initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings) + (simplifier_sw_chkr KeepSpecPragmaIds) + (not (simplifier_sw_chkr SimplMayDeleteConjurableIds)) + (simplifier_sw_chkr IgnoreINLINEPragma) + emptyUniqSet + + do env [] = (emptyDetails, []) + do env (bind:binds) + = (final_usage, new_binds ++ the_rest) + where + new_env = env `addNewCands` (bindersOf bind) + (binds_usage, the_rest) = do new_env binds + (final_usage, new_binds) = --BSCC("occAnalBind1") + occAnalBind env bind binds_usage + --ESCC +\end{code} + +\begin{code} +occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars + -> PlainCoreExpr + -> (IdEnv BinderInfo, -- Occ info for interesting free vars + SimplifiableCoreExpr) + +occurAnalyseExpr candidates expr + = occAnal initial_env expr + where + initial_env = OccEnv False {- Drop unused bindings -} + False {- Drop SpecPragmaId bindings -} + True {- Keep conjurable Ids -} + False {- Do not ignore INLINE Pragma -} + candidates + +occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr +occurAnalyseGlobalExpr expr + = -- Top level expr, so no interesting free vars, and + -- discard occurence info returned + expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr +\end{code} + +%************************************************************************ +%* * +\subsection[OccurAnal-main]{Counting occurrences: main function} +%* * +%************************************************************************ + +Bindings +~~~~~~~~ + +\begin{code} +occAnalBind :: OccEnv + -> PlainCoreBinding + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [SimplifiableCoreBinding]) + +occAnalBind env (CoNonRec binder rhs) body_usage + | isNeeded env body_usage binder -- It's mentioned in body + = (final_body_usage `combineUsageDetails` rhs_usage, + [CoNonRec tagged_binder rhs']) + + | otherwise + = (body_usage, []) + + where + (rhs_usage, rhs') = occAnalRhs env binder rhs + (final_body_usage, tagged_binder) = tagBinder body_usage binder +\end{code} + +Dropping dead code for recursive bindings is done in a very simple way: + + the entire set of bindings is dropped if none of its binders are + mentioned in its body; otherwise none are. + +This seems to miss an obvious improvement. +@ + letrec f = ...g... + g = ...f... + in + ...g... + +===> + + letrec f = ...g... + g = ...(...g...)... + in + ...g... +@ + +Now @f@ is unused. But dependency analysis will sort this out into a +@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped. +It isn't easy to do a perfect job in one blow. Consider + +@ + letrec f = ...g... + g = ...h... + h = ...k... + k = ...m... + m = ...m... + in + ...m... +@ + + +\begin{code} +occAnalBind env (CoRec pairs) body_usage + = foldr do_final_bind (body_usage, []) sccs + where + + (binders, rhss) = unzip pairs + new_env = env `addNewCands` binders + + analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))] + analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs] + + lookup :: Id -> (UsageDetails, SimplifiableCoreExpr) + lookup id = assoc "occAnalBind:lookup" analysed_pairs id + + + ---- stuff for dependency analysis of binds ------------------------------- + + edges :: [(Id,Id)] -- (a,b) means a mentions b + edges = concat [ edges_from binder rhs_usage + | (binder, (rhs_usage, _)) <- analysed_pairs] + + edges_from :: Id -> UsageDetails -> [(Id,Id)] + edges_from id its_rhs_usage + = [(id,mentioned) | mentioned <- binders, + maybeToBool (lookupIdEnv its_rhs_usage mentioned) + ] + + sccs :: [[Id]] + sccs = case binders of + [_] -> [binders] -- Singleton; no need to analyse + other -> stronglyConnComp eqId edges binders + + ---- stuff to "re-constitute" bindings from dependency-analysis info ------ + + do_final_bind sCC@[binder] (body_usage, binds_so_far) + | isNeeded env body_usage binder + = (combined_usage, new_bind:binds_so_far) + + | otherwise -- Dead + = (body_usage, binds_so_far) + where + total_usage = combineUsageDetails body_usage rhs_usage + (rhs_usage, rhs') = lookup binder + (combined_usage, tagged_binder) = tagBinder total_usage binder + + new_bind + | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')] + | otherwise = CoNonRec tagged_binder rhs' + where + mentions_itself binder usage + = maybeToBool (lookupIdEnv usage binder) + + do_final_bind sCC (body_usage, binds_so_far) + | any (isNeeded env body_usage) sCC + = (combined_usage, new_bind:binds_so_far) + + | otherwise -- Dead + = (body_usage, binds_so_far) + where + (rhs_usages, rhss') = unzip (map lookup sCC) + total_usage = foldr combineUsageDetails body_usage rhs_usages + (combined_usage, tagged_binders) = tagBinders total_usage sCC + + new_bind = CoRec (tagged_binders `zip` rhss') +\end{code} + +@occAnalRhs@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that ths +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +\begin{code} +occAnalRhs :: OccEnv + -> Id -- Binder + -> PlainCoreExpr -- Rhs + -> (UsageDetails, SimplifiableCoreExpr) + +occAnalRhs env id rhs + | idWantsToBeINLINEd id && not (ignoreINLINEPragma env) + = (mapIdEnv markMany rhs_usage, rhs') + + | otherwise + = (rhs_usage, rhs') + + where + (rhs_usage, rhs') = occAnal env rhs +\end{code} + +Expressions +~~~~~~~~~~~ +\begin{code} +occAnal :: OccEnv + -> PlainCoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + SimplifiableCoreExpr) + +occAnal env (CoVar v) + | isCandidate env v + = (unitIdEnv v (funOccurrence 0), CoVar v) + + | otherwise + = (emptyDetails, CoVar v) + +occAnal env (CoLit lit) = (emptyDetails, CoLit lit) +occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args) +occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args) + +occAnal env (CoSCC cc body) + = (mapIdEnv markInsideSCC usage, CoSCC cc body') + where + (usage, body') = occAnal env body + +occAnal env (CoApp fun arg) + = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg) + where + (fun_usage, fun') = occAnal env fun + arg_usage = occAnalAtom env arg + +occAnal env (CoTyApp fun ty) + = (fun_usage, CoTyApp fun' ty) + where + (fun_usage, fun') = occAnal env fun + +occAnal env (CoLam binders body) + = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body') + where + new_env = env `addNewCands` binders + (body_usage, body') = occAnal new_env body + (final_usage, tagged_binders) = tagBinders body_usage binders + +-- ANDY: WE MUST THINK ABOUT THIS! (ToDo) +occAnal env (CoTyLam tyvar body) + = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body') + where + (body_usage, body') = occAnal env body + +occAnal env (CoCase scrut alts) + = (scrut_usage `combineUsageDetails` alts_usage, + CoCase scrut' alts') + where + (scrut_usage, scrut') = occAnal env scrut + (alts_usage, alts') = occAnalAlts env alts + +occAnal env (CoLet bind body) + = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh) + 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 +\end{code} + +Case alternatives +~~~~~~~~~~~~~~~~~ +\begin{code} +occAnalAlts env (CoAlgAlts alts deflt) + = (foldr combineAltsUsageDetails deflt_usage alts_usage, + -- Note: combine*Alts*UsageDetails... + CoAlgAlts alts' deflt') + where + (alts_usage, alts') = unzip (map do_alt alts) + (deflt_usage, deflt') = occAnalDeflt env deflt + + do_alt (con, args, rhs) + = (final_usage, (con, tagged_args, rhs')) + where + new_env = env `addNewCands` args + (rhs_usage, rhs') = occAnal new_env rhs + (final_usage, tagged_args) = tagBinders rhs_usage args + +occAnalAlts env (CoPrimAlts alts deflt) + = (foldr combineAltsUsageDetails deflt_usage alts_usage, + -- Note: combine*Alts*UsageDetails... + CoPrimAlts alts' deflt') + where + (alts_usage, alts') = unzip (map do_alt alts) + (deflt_usage, deflt') = occAnalDeflt env deflt + + do_alt (lit, rhs) + = (rhs_usage, (lit, rhs')) + where + (rhs_usage, rhs') = occAnal env rhs + +occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault) + +occAnalDeflt env (CoBindDefault binder rhs) + = (final_usage, CoBindDefault tagged_binder rhs') + where + new_env = env `addNewCand` binder + (rhs_usage, rhs') = occAnal new_env rhs + (final_usage, tagged_binder) = tagBinder rhs_usage binder +\end{code} + + +Atoms +~~~~~ +\begin{code} +occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails + +occAnalAtoms env atoms + = foldr do_one_atom emptyDetails atoms + where + do_one_atom (CoLitAtom lit) usage = usage + do_one_atom (CoVarAtom v) usage + | isCandidate env v = addOneOcc usage v (argOccurrence 0) + | otherwise = usage + + +occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails + +occAnalAtom env (CoLitAtom lit) = emptyDetails +occAnalAtom env (CoVarAtom v) + | isCandidate env v = unitDetails v (argOccurrence 0) + | otherwise = emptyDetails +\end{code} diff --git a/ghc/compiler/simplCore/SAT.hi b/ghc/compiler/simplCore/SAT.hi new file mode 100644 index 0000000..181cc65 --- /dev/null +++ b/ghc/compiler/simplCore/SAT.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SAT where +import BasicLit(BasicLit) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PlainCore(PlainCoreProgram(..)) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreProgram = [CoreBinding Id Id] +doStaticArgs :: [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs new file mode 100644 index 0000000..6f484cf --- /dev/null +++ b/ghc/compiler/simplCore/SAT.lhs @@ -0,0 +1,215 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[SAT]{Static Argument Transformation pass} +%* * +%************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +We could possibly do the same for big lambdas, but we don't as +they will eventually be removed in later stages of the compiler, +therefore there is no penalty in keeping them. + +Experimental Evidence: Heap: +/- 7% + Instrs: Always improves for 2 or more Static Args. + +\begin{code} +#include "HsVersions.h" + +module SAT ( + doStaticArgs, + + -- and to make the interface self-sufficient... + PlainCoreProgram(..), CoreExpr, CoreBinding, Id + ) where + +import IdEnv +import Maybes ( Maybe(..) ) +import PlainCore +import SATMonad +import SplitUniq +import Util +\end{code} + +\begin{code} +doStaticArgs :: PlainCoreProgram -> SplitUniqSupply -> PlainCoreProgram + +doStaticArgs binds + = initSAT (mapSAT sat_bind binds) + where + sat_bind (CoNonRec binder expr) + = emptyEnvSAT `thenSAT_` + satExpr expr `thenSAT` (\ expr' -> + returnSAT (CoNonRec binder expr') ) + sat_bind (CoRec [(binder,rhs)]) + = emptyEnvSAT `thenSAT_` + insSAEnv binder (getArgLists rhs) `thenSAT_` + satExpr rhs `thenSAT` (\ rhs' -> + saTransform binder rhs') + sat_bind (CoRec pairs) + = emptyEnvSAT `thenSAT_` + mapSAT satExpr rhss `thenSAT` \ rhss' -> + returnSAT (CoRec (binders `zip` rhss')) + where + (binders, rhss) = unzip pairs +\end{code} + +\begin{code} +satAtom (CoVarAtom v) + = updSAEnv (Just (v,([],[]))) `thenSAT_` + returnSAT () + +satAtom _ = returnSAT () +\end{code} + +\begin{code} +satExpr :: PlainCoreExpr -> SatM PlainCoreExpr + +satExpr var@(CoVar v) + = updSAEnv (Just (v,([],[]))) `thenSAT_` + returnSAT var + +satExpr lit@(CoLit _) = returnSAT lit + +satExpr e@(CoCon con types args) + = mapSAT satAtom args `thenSAT_` + returnSAT e + +satExpr e@(CoPrim prim ty args) + = mapSAT satAtom args `thenSAT_` + returnSAT e + +satExpr (CoLam binders body) + = satExpr body `thenSAT` \ body' -> + returnSAT (CoLam binders body') + +satExpr (CoTyLam tyvar body) + = satExpr body `thenSAT` (\ body' -> + returnSAT (CoTyLam tyvar body') ) + +satExpr app@(CoApp _ _) + = getAppArgs app + +satExpr app@(CoTyApp _ _) + = getAppArgs app + +satExpr (CoCase expr alts) + = satExpr expr `thenSAT` \ expr' -> + sat_alts alts `thenSAT` \ alts' -> + returnSAT (CoCase expr' alts') + where + sat_alts (CoAlgAlts alts deflt) + = mapSAT satAlgAlt alts `thenSAT` \ alts' -> + sat_default deflt `thenSAT` \ deflt' -> + returnSAT (CoAlgAlts alts' deflt') + where + satAlgAlt (con, params, rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (con, params, rhs') + + sat_alts (CoPrimAlts alts deflt) + = mapSAT satPrimAlt alts `thenSAT` \ alts' -> + sat_default deflt `thenSAT` \ deflt' -> + returnSAT (CoPrimAlts alts' deflt') + where + satPrimAlt (lit, rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (lit, rhs') + + sat_default CoNoDefault + = returnSAT CoNoDefault + sat_default (CoBindDefault binder rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (CoBindDefault binder rhs') + +satExpr (CoLet (CoNonRec binder rhs) body) + = satExpr body `thenSAT` \ body' -> + satExpr rhs `thenSAT` \ rhs' -> + returnSAT (CoLet (CoNonRec binder rhs') body') + +satExpr (CoLet (CoRec [(binder,rhs)]) body) + = satExpr body `thenSAT` \ body' -> + insSAEnv binder (getArgLists rhs) `thenSAT_` + satExpr rhs `thenSAT` \ rhs' -> + saTransform binder rhs' `thenSAT` \ binding -> + returnSAT (CoLet binding body') + +satExpr (CoLet (CoRec binds) body) + = let + (binders, rhss) = unzip binds + in + satExpr body `thenSAT` \ body' -> + mapSAT satExpr rhss `thenSAT` \ rhss' -> + returnSAT (CoLet (CoRec (binders `zip` rhss')) body') + +satExpr (CoSCC cc expr) + = satExpr expr `thenSAT` \ expr2 -> + returnSAT (CoSCC cc expr2) + +-- ToDo: DPH stuff +\end{code} + +\begin{code} +getAppArgs :: PlainCoreExpr -> SatM PlainCoreExpr + +getAppArgs app + = get app `thenSAT` \ (app',result) -> + updSAEnv result `thenSAT_` + returnSAT app' + where + get :: PlainCoreExpr + -> SatM (PlainCoreExpr, Maybe (Id, SATInfo)) + + get (CoTyApp e ty) + = get e `thenSAT` \ (e',result) -> + returnSAT ( + CoTyApp e' ty, + case result of + Nothing -> Nothing + Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv)) + ) + + get (CoApp e a) + = get e `thenSAT` \ (e', result) -> + satAtom a `thenSAT_` + let si = case a of + (CoVarAtom v) -> Static v + _ -> NotStatic + in + returnSAT ( + CoApp e' a, + case result of + Just (v,(tv,lv)) -> Just (v,(tv,lv++[si])) + Nothing -> Nothing + ) + + get var@(CoVar v) + = returnSAT (var, Just (v,([],[]))) + + get e + = satExpr e `thenSAT` \ e2 -> + returnSAT (e2, Nothing) +\end{code} + diff --git a/ghc/compiler/simplCore/SATMonad.hi b/ghc/compiler/simplCore/SATMonad.hi new file mode 100644 index 0000000..b0a3ec0 --- /dev/null +++ b/ghc/compiler/simplCore/SATMonad.hi @@ -0,0 +1,55 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SATMonad where +import Class(Class) +import CoreSyn(CoreBinding, CoreExpr) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import PlainCore(PlainCoreExpr(..)) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +infixr 9 `thenSAT` +infixr 9 `thenSAT_` +data Arg a = Static a | NotStatic +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainCoreExpr = CoreExpr Id Id +type SATEnv = UniqFM ([Arg UniType], [Arg Id]) +type SATInfo = ([Arg UniType], [Arg Id]) +type SatM a = SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id])) +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +dropStatics :: [Arg a] -> [b] -> [b] + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ #-} +emptyEnvSAT :: SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _N_ _N_ #-} +getArgLists :: CoreExpr Id Id -> ([Arg UniType], [Arg Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +getSATInfo :: Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Labda ([Arg UniType], [Arg Id]), UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "LAL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +initSAT :: (SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))) -> SplitUniqSupply -> a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +insSAEnv :: Id -> ([Arg UniType], [Arg Id]) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 4 _U_ 1202 _N_ _S_ "LLAL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isStatic :: Arg a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 4 _/\_ u0 -> \ (u1 :: Arg u0) -> case u1 of { _ALG_ _ORIG_ SATMonad Static (u2 :: u0) -> _!_ True [] []; _ORIG_ SATMonad NotStatic -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +mapSAT :: (a -> SplitUniqSupply -> c -> (b, c)) -> [a] -> SplitUniqSupply -> c -> ([b], c) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +newSATName :: Id -> UniType -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Id, UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _N_ _N_ _N_ #-} +returnSAT :: b -> a -> c -> (b, c) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LAL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 3 2 XX 3 _/\_ u0 u1 u2 -> \ (u3 :: u1) (u4 :: u2) -> _!_ _TUP_2 [u1, u2] [u3, u4] _N_} _F_ _IF_ARGS_ 3 3 XXX 3 _/\_ u0 u1 u2 -> \ (u3 :: u1) (u4 :: u0) (u5 :: u2) -> _!_ _TUP_2 [u1, u2] [u3, u5] _N_ #-} +saTransform :: Id -> CoreExpr Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (CoreBinding Id Id, UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 2 _U_ 2212 _N_ _N_ _N_ _N_ #-} +thenSAT :: (SplitUniqSupply -> c -> (a, b)) -> (a -> SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSU(ALL)L" {_A_ 5 _U_ 11222 _N_ _N_ _F_ _IF_ARGS_ 4 5 XXXXX 8 _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: u0 -> SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: SplitUniqSupply) (u8 :: u2) -> case _APP_ u4 [ u6, u8 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: u1) -> _APP_ u5 [ u9, u7, ua ]; _NO_DEFLT_ } _N_} _F_ _ALWAYS_ _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: u0 -> SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: u2) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u8 :: Int) (u9 :: SplitUniqSupply) (ua :: SplitUniqSupply) -> case _APP_ u4 [ u9, u7 ] of { _ALG_ _TUP_2 (ub :: u0) (uc :: u1) -> _APP_ u5 [ ub, ua, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +thenSAT_ :: (SplitUniqSupply -> c -> (a, b)) -> (SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSU(ALL)L" {_A_ 5 _U_ 11222 _N_ _N_ _F_ _IF_ARGS_ 4 5 XXXXX 7 _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: SplitUniqSupply) (u8 :: u2) -> case _APP_ u4 [ u6, u8 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: u1) -> _APP_ u5 [ u7, ua ]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 4 4 XXCX 8 _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: u2) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u8 :: Int) (u9 :: SplitUniqSupply) (ua :: SplitUniqSupply) -> case _APP_ u4 [ u9, u7 ] of { _ALG_ _TUP_2 (ub :: u0) (uc :: u1) -> _APP_ u5 [ ua, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +updSAEnv :: Labda (Id, ([Arg UniType], [Arg Id])) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "S" _N_ _N_ #-} +instance Eq a => Eq (Arg a) + {-# GHC_PRAGMA _M_ SATMonad {-dfun-} _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs new file mode 100644 index 0000000..dbdff75 --- /dev/null +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -0,0 +1,259 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[SATMonad]{The Static Argument Transformation pass Monad} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module SATMonad ( + SATInfo(..), updSAEnv, + SatM(..), initSAT, emptyEnvSAT, + returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName, + getArgLists, Arg(..), insSAEnv, saTransform, + + SATEnv(..), isStatic, dropStatics, + + Id, UniType, SplitUniqSupply, PlainCoreExpr(..) + ) where + +import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate, + extractTyVarsFromTy, splitType, splitTyArgs, + glueTyArgs, instantiateTy, TauType(..), + Class, ThetaType(..), SigmaType(..), + InstTyEnv(..) + ) +import IdEnv +import Id ( mkSysLocal, getIdUniType ) +import Maybes ( Maybe(..) ) +import PlainCore +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SplitUniq +import Unique +import Util + +infixr 9 `thenSAT`, `thenSAT_` +\end{code} + +%************************************************************************ +%* * +\subsection{Static Argument Transformation Environment} +%* * +%************************************************************************ + +\begin{code} +type SATEnv = IdEnv SATInfo + +type SATInfo = ([Arg UniType],[Arg Id]) + +data Arg a = Static a | NotStatic + deriving Eq + +delOneFromSAEnv v us env + = ((), delOneFromIdEnv env v) + +updSAEnv :: Maybe (Id,SATInfo) -> SatM () +updSAEnv Nothing + = returnSAT () +updSAEnv (Just (b,(tyargs,args))) + = getSATInfo b `thenSAT` (\ r -> + case r of + Nothing -> returnSAT () + Just (tyargs',args') -> delOneFromSAEnv b `thenSAT_` + insSAEnv b (checkArgs tyargs tyargs', + checkArgs args args') + ) + +checkArgs as [] = notStatics (length as) +checkArgs [] as = notStatics (length as) +checkArgs (a:as) (a':as') | a == a' = a:checkArgs as as' +checkArgs (_:as) (_:as') = NotStatic:checkArgs as as' + +notStatics :: Int -> [Arg a] +notStatics n = nOfThem n NotStatic + +insSAEnv :: Id -> SATInfo -> SatM () +insSAEnv b info us env + = ((), addOneToIdEnv env b info) +\end{code} + +%************************************************************************ +%* * +\subsection{Static Argument Transformation Monad} +%* * +%************************************************************************ + +Two items of state to thread around: a UniqueSupply and a SATEnv. + +\begin{code} +type SatM result + = SplitUniqSupply -> SATEnv -> (result, SATEnv) + +initSAT :: SatM a -> SplitUniqSupply -> a + +initSAT f us = fst (f us nullIdEnv) + +thenSAT m k us env + = case splitUniqSupply us of { (s1, s2) -> + case m s1 env of { (m_result, menv) -> + k m_result s2 menv }} + +thenSAT_ m k us env + = case splitUniqSupply us of { (s1, s2) -> + case m s1 env of { (_, menv) -> + k s2 menv }} + +emptyEnvSAT :: SatM () +emptyEnvSAT us _ = ((), nullIdEnv) + +returnSAT v us env = (v, env) + +mapSAT f [] = returnSAT [] +mapSAT f (x:xs) + = f x `thenSAT` \ x' -> + mapSAT f xs `thenSAT` \ xs' -> + returnSAT (x':xs') +\end{code} + +%************************************************************************ +%* * +\subsection{Utility Functions} +%* * +%************************************************************************ + +\begin{code} +getSATInfo :: Id -> SatM (Maybe SATInfo) +getSATInfo var us env + = (lookupIdEnv env var, env) + +newSATName :: Id -> UniType -> SatM Id +newSATName id ty us env + = case (getSUnique us) of { unique -> + (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) } + where + new_str = getOccurrenceName id _APPEND_ SLIT("_sat") + +getArgLists :: PlainCoreExpr -> ([Arg UniType],[Arg Id]) +getArgLists expr + = let + (tvs, lambda_bounds, body) = digForLambdas expr + in + ([ Static (mkTyVarTy tv) | tv <- tvs ], + [ Static v | v <- lambda_bounds ]) + +dropArgs :: PlainCoreExpr -> PlainCoreExpr +dropArgs (CoLam v e) = dropArgs e +dropArgs (CoTyLam ty e) = dropArgs e +dropArgs e = e + +\end{code} + +We implement saTransform using shadowing of binders, that is +we transform +map = \f as -> case as of + [] -> [] + (a':as') -> let x = f a' + y = map f as' + in x:y +to +map = \f as -> let map = \f as -> map' as + in let rec map' = \as -> case as of + [] -> [] + (a':as') -> let x = f a' + y = map f as' + in x:y + in map' as + +the inner map should get inlined and eliminated. +\begin{code} +saTransform :: Id -> PlainCoreExpr -> SatM PlainCoreBinding +saTransform binder rhs + = getSATInfo binder `thenSAT` \ r -> + case r of + -- [Andre] test: do it only if we have more than one static argument. + --Just (tyargs,args) | any isStatic args + Just (tyargs,args) | length (filter isStatic args) > 1 + -> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' -> + mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs -> + trace ("SAT "++ show (length (filter isStatic args))) ( + returnSAT (CoNonRec binder new_rhs) + ) + _ -> returnSAT (CoRec [(binder, rhs)]) + where + mkNewRhs binder binder' tyargs args rhs + = let + non_static_args :: [Id] + non_static_args + = get_nsa args (snd (getArgLists rhs)) + where + get_nsa :: [Arg a] -> [Arg a] -> [a] + get_nsa [] _ = [] + get_nsa _ [] = [] + get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as + get_nsa (_:args) (_:as) = get_nsa args as + + local_body = foldl CoApp (CoVar binder') + [CoVarAtom a | a <- non_static_args] + + nonrec_rhs = origLams local_body + + -- HACK! The following is a fake SysLocal binder with + -- *the same* unique as binder. + -- the reason for this is the following: + -- this binder *will* get inlined but if it happen to be + -- a top level binder it is never removed as dead code, + -- therefore we have to remove that information (of it being + -- top-level or exported somehow. + -- A better fix is to use binder directly but with the TopLevel + -- tag (or Exported tag) modified. + fake_binder = mkSysLocal + (getOccurrenceName binder _APPEND_ SLIT("_fsat")) + (getTheUnique binder) + (getIdUniType binder) + mkUnknownSrcLoc + rec_body = mkCoLam non_static_args + ( CoLet (CoNonRec fake_binder nonrec_rhs) + {-in-} (dropArgs rhs)) + in + returnSAT ( + origLams (CoLet (CoRec [(binder',rec_body)]) {-in-} local_body) + ) + where + origLams = origLams' rhs + where + origLams' (CoLam v e) e' = mkCoLam v (origLams' e e') + origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e') + origLams' _ e' = e' + + new_ty tyargs args + = instantiateTy (mk_inst_tyenv tyargs tv_tmpl) + (mkSigmaTy tv_tmpl' dict_tys' tau_ty') + where + -- get type info for the local function: + (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder + (reg_arg_tys, res_type) = splitTyArgs tau_ty + + -- now, we drop the ones that are + -- static, that is, the ones we will not pass to the local function + l = length dict_tys + tv_tmpl' = dropStatics tyargs tv_tmpl + dict_tys' = dropStatics (take l args) dict_tys + reg_arg_tys' = dropStatics (drop l args) reg_arg_tys + tau_ty' = glueTyArgs reg_arg_tys' res_type + + mk_inst_tyenv [] _ = [] + mk_inst_tyenv (Static s:args) (t:ts) = (t,s) : mk_inst_tyenv args ts + mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts + +dropStatics [] t = t +dropStatics (Static _:args) (t:ts) = dropStatics args ts +dropStatics (_:args) (t:ts) = t:dropStatics args ts + +isStatic :: Arg a -> Bool +isStatic NotStatic = False +isStatic _ = True +\end{code} diff --git a/ghc/compiler/simplCore/SetLevels.hi b/ghc/compiler/simplCore/SetLevels.hi new file mode 100644 index 0000000..6a9e8c3 --- /dev/null +++ b/ghc/compiler/simplCore/SetLevels.hi @@ -0,0 +1,24 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SetLevels where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import Id(Id) +import Outputable(Outputable) +import SplitUniq(SplitUniqSupply) +data Level = Level Int Int | Top +incMinorLvl :: Level -> Level + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTopLvl :: Level -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: Level) -> case u0 of { _ALG_ _ORIG_ SetLevels Level (u1 :: Int) (u2 :: Int) -> _!_ False [] []; _ORIG_ SetLevels Top -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} +ltLvl :: Level -> Level -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +ltMajLvl :: Level -> Level -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-} +setLevels :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding (Id, Level) Id] + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-} +tOP_LEVEL :: Level + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ SetLevels Top [] [] _N_ #-} +instance Outputable Level + {-# GHC_PRAGMA _M_ SetLevels {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Level) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs new file mode 100644 index 0000000..e9a0336 --- /dev/null +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -0,0 +1,789 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section{SetLevels} + +We attach binding levels to Core bindings, in preparation for floating +outwards (@FloatOut@). + +We also let-ify many applications (notably case scrutinees), so they +will have a fighting chance of being floated sensible. + +\begin{code} +#include "HsVersions.h" + +module SetLevels ( + setLevels, + + Level(..), tOP_LEVEL, + + incMinorLvl, ltMajLvl, ltLvl, isTopLvl +-- not exported: , incMajorLvl, isTopMajLvl, unTopify + ) where + +import PlainCore + + +import AbsUniType ( isPrimType, isLeakFreeType, mkTyVarTy, + quantifyTy, TyVarTemplate -- Needed for quantifyTy + ) +import AnnCoreSyn +import BasicLit ( BasicLit(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import FreeVars +import Id ( mkSysLocal, getIdUniType, eqId, + isBottomingId, toplevelishId, DataCon(..) + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import IdEnv +import Maybes ( Maybe(..) ) +import Pretty -- debugging only +import PrimKind ( PrimKind(..) ) +import UniqSet +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import TyVarEnv +import SplitUniq +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection{Level numbers} +%* * +%************************************************************************ + +\begin{code} +data Level = Level + Int -- Level number of enclosing lambdas + Int -- Number of big-lambda and/or case expressions between + -- here and the nearest enclosing lambda + + | Top -- Means *really* the top level. +\end{code} + +The {\em level number} on a (type-)lambda-bound variable is the +nesting depth of the (type-)lambda which binds it. On an expression, it's the +maximum level number of its free (type-)variables. On a let(rec)-bound +variable, it's the level of its RHS. On a case-bound variable, it's +the number of enclosing lambdas. + +Top-level variables: level~0. Those bound on the RHS of a top-level +definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown +as ``subscripts'')... +\begin{verbatim} +a_0 = let b_? = ... in + x_1 = ... b ... in ... +\end{verbatim} + +Level 0 0 will make something get floated to a top-level "equals", @Top@ +makes it go right to the top. + +The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). That's +meant to be the level number of the enclosing binder in the final (floated) +program. If the level number of a sub-expression is less than that of the +context, then it might be worth let-binding the sub-expression so that it +will indeed float. This context level starts at @Level 0 0@; it is never @Top@. + +\begin{code} +type LevelledExpr = CoreExpr (Id, Level) Id +type LevelledAtom = CoreAtom Id +type LevelledBind = CoreBinding (Id, Level) Id + +type LevelEnvs = (IdEnv Level, -- bind Ids to levels + TyVarEnv Level) -- bind type variables to levels + +tOP_LEVEL = Top + +incMajorLvl :: Level -> Level +incMajorLvl Top = Level 1 0 +incMajorLvl (Level major minor) = Level (major+1) 0 + +incMinorLvl :: Level -> Level +incMinorLvl Top = Level 0 1 +incMinorLvl (Level major minor) = Level major (minor+1) + +maxLvl :: Level -> Level -> Level +maxLvl Top l2 = l2 +maxLvl l1 Top = l1 +maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) + | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 + | otherwise = l2 + +ltLvl :: Level -> Level -> Bool +ltLvl l1 Top = False +ltLvl Top (Level _ _) = True +ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || + (maj1 == maj2 && min1 < min2) + +ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft + -- *lambda* level to another +ltMajLvl l1 Top = False +ltMajLvl Top (Level 0 _) = False +ltMajLvl Top (Level _ _) = True +ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 + +isTopLvl :: Level -> Bool +isTopLvl Top = True +isTopLvl other = False + +isTopMajLvl :: Level -> Bool -- Tells if it's the top *lambda* level +isTopMajLvl Top = True +isTopMajLvl (Level maj _) = maj == 0 + +unTopify :: Level -> Level +unTopify Top = Level 0 0 +unTopify lvl = lvl + +instance Outputable Level where + ppr sty Top = ppStr "" + ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ] +\end{code} + +%************************************************************************ +%* * +\subsection{Main level-setting code} +%* * +%************************************************************************ + +\begin{code} +setLevels :: [PlainCoreBinding] + -> (GlobalSwitch -> Bool) -- access to all global cmd-line opts + -> SplitUniqSupply + -> [LevelledBind] + +setLevels binds sw us + = do_them binds sw us + where + -- "do_them"'s main business is to thread the monad along + -- It gives each top binding the same empty envt, because + -- things unbound in the envt have level number zero implicitly + do_them :: [PlainCoreBinding] -> LvlM [LevelledBind] + + do_them [] = returnLvl [] + do_them (b:bs) + = lvlTopBind b `thenLvl` \ (lvld_bind, _) -> + do_them bs `thenLvl` \ lvld_binds -> + returnLvl (lvld_bind ++ lvld_binds) + +initial_envs = (nullIdEnv, nullTyVarEnv) + +-- OLDER: +lvlTopBind (CoNonRec binder rhs) + = lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder (freeVars rhs)) + -- Rhs can have no free vars! + +lvlTopBind (CoRec pairs) + = lvlBind (Level 0 0) initial_envs (AnnCoRec [(b,freeVars rhs) | (b,rhs) <- pairs]) + +{- NEWER: Too bad about the types: WDP: +lvlTopBind (CoNonRec binder rhs) + = {-SIGH:wrong type: ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} -- Rhs can have no free vars! + lvlBind (Level 0 0) initial_envs (AnnCoNonRec binder emptyUniqSet) + +lvlTopBind (CoRec pairs) + = lvlBind (Level 0 0) initial_envs + (AnnCoRec [(b, emptyUniqSet) + | (b, rhs) <- pairs, + {-SIGH:ditto:ASSERT(isEmptyUniqSet (freeVarsOf rhs))-} True]) +-} +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +The binding stuff works for top level too. + +\begin{code} +type CoreBindingWithFVs = AnnCoreBinding Id Id FVInfo + +lvlBind :: Level + -> LevelEnvs + -> CoreBindingWithFVs + -> LvlM ([LevelledBind], LevelEnvs) + +lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoNonRec name rhs) + = setFloatLevel True {- Already let-bound -} + ctxt_lvl envs rhs ty `thenLvl` \ (final_lvl, rhs') -> + let + new_envs = (addOneToIdEnv venv name final_lvl, tenv) + in + returnLvl ([CoNonRec (name, final_lvl) rhs'], new_envs) + where + ty = getIdUniType name + + +lvlBind ctxt_lvl envs@(venv, tenv) (AnnCoRec pairs) + = decideRecFloatLevel ctxt_lvl envs binders rhss + `thenLvl` \ (final_lvl, extra_binds, rhss') -> + let + binders_w_lvls = binders `zip` repeat final_lvl + new_envs = (growIdEnvList venv binders_w_lvls, tenv) + in + returnLvl (extra_binds ++ [CoRec (binders_w_lvls `zip` rhss')], new_envs) + where + (binders,rhss) = unzip pairs +\end{code} + +%************************************************************************ +%* * +\subsection{Setting expression levels} +%* * +%************************************************************************ + +\begin{code} +lvlExpr :: Level -- ctxt_lvl: Level of enclosing expression + -> LevelEnvs -- Level of in-scope names/tyvars + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression +\end{code} + +The @ctxt_lvl@ is, roughly, the level of the innermost enclosing +binder. + +Here's an example + + v = \x -> ...\y -> let r = case (..x..) of + ..x.. + in .. + +When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's +the level of @r@, even though it's inside a level-2 @\y@. It's +important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we +don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE +--- because it isn't a *maximal* free expression. + +If there were another lambda in @r@'s rhs, it would get level-2 as well. + +\begin{code} +lvlExpr _ _ (_, AnnCoVar v) = returnLvl (CoVar v) +lvlExpr _ _ (_, AnnCoLit l) = returnLvl (CoLit l) +lvlExpr _ _ (_, AnnCoCon con tys atoms) = returnLvl (CoCon con tys atoms) +lvlExpr _ _ (_, AnnCoPrim op tys atoms) = returnLvl (CoPrim op tys atoms) + +lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoTyApp expr ty) + = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> + returnLvl (CoTyApp expr' ty) + +lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoApp fun arg) + = lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' -> + returnLvl (CoApp fun' arg) + +lvlExpr ctxt_lvl envs (_, AnnCoSCC cc expr) + = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> + returnLvl (CoSCC cc expr') + +lvlExpr ctxt_lvl (venv, tenv) (_, AnnCoTyLam tyvar e) + = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' -> + returnLvl (CoTyLam tyvar e') + where + incd_lvl = incMinorLvl ctxt_lvl + new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl + +{- if we were splitting lambdas: +lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam [arg] rhs) + = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' -> + returnLvl (CoLam arg_w_lvl rhs') + where + incd_lvl = incMajorLvl ctxt_lvl + arg_w_lvl = [(arg, incd_lvl)] + new_venv = growIdEnvList venv arg_w_lvl + +lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam (a:args) rhs) + = lvlExpr incd_lvl (new_venv, tenv) (AnnCoLam args rhs) `thenLvl` \ rhs' -> + -- don't use mkCoLam! + returnLvl (CoLam arg_w_lvl rhs') + where + incd_lvl = incMajorLvl ctxt_lvl + arg_w_lvl = [(a,incd_lvl)] + new_venv = growIdEnvList venv arg_w_lvl +-} + +lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoLam args rhs) + = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' -> + returnLvl (CoLam args_w_lvls rhs') + where + incd_lvl = incMajorLvl ctxt_lvl + args_w_lvls = [ (a, incd_lvl) | a <- args ] + new_venv = growIdEnvList venv args_w_lvls + +lvlExpr ctxt_lvl envs (_, AnnCoLet bind body) + = lvlBind ctxt_lvl envs bind `thenLvl` \ (binds', new_envs) -> + lvlExpr ctxt_lvl new_envs body `thenLvl` \ body' -> + returnLvl (foldr CoLet body' binds') -- mkCoLet* requires PlainCore... + +lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnCoCase expr alts) + = lvlMFE ctxt_lvl envs expr `thenLvl` \ expr' -> + lvl_alts alts `thenLvl` \ alts' -> + returnLvl (CoCase expr' alts') + where + expr_type = typeOfCoreExpr (deAnnotate expr) + incd_lvl = incMinorLvl ctxt_lvl + + lvl_alts (AnnCoAlgAlts alts deflt) + = mapLvl lvl_alt alts `thenLvl` \ alts' -> + lvl_deflt deflt `thenLvl` \ deflt' -> + returnLvl (CoAlgAlts alts' deflt') + where + lvl_alt (con, bs, e) + = let + bs' = [ (b, incd_lvl) | b <- bs ] + new_envs = (growIdEnvList venv bs', tenv) + in + lvlMFE incd_lvl new_envs e `thenLvl` \ e' -> + returnLvl (con, bs', e') + + lvl_alts (AnnCoPrimAlts alts deflt) + = mapLvl lvl_alt alts `thenLvl` \ alts' -> + lvl_deflt deflt `thenLvl` \ deflt' -> + returnLvl (CoPrimAlts alts' deflt') + where + lvl_alt (lit, e) + = lvlMFE incd_lvl envs e `thenLvl` \ e' -> + returnLvl (lit, e') + + lvl_deflt AnnCoNoDefault = returnLvl CoNoDefault + + lvl_deflt (AnnCoBindDefault b expr) + = let + new_envs = (addOneToIdEnv venv b incd_lvl, tenv) + in + lvlMFE incd_lvl new_envs expr `thenLvl` \ expr' -> + returnLvl (CoBindDefault (b, incd_lvl) expr') +\end{code} + +@lvlMFE@ is just like @lvlExpr@, except that it might let-bind +the expression, so that it can itself be floated. + +\begin{code} +lvlMFE :: Level -- Level of innermost enclosing lambda/tylam + -> LevelEnvs -- Level of in-scope names/tyvars + -> CoreExprWithFVs -- input expression + -> LvlM LevelledExpr -- Result expression + +lvlMFE ctxt_lvl envs@(venv,_) ann_expr + | isPrimType ty -- Can't let-bind it + = lvlExpr ctxt_lvl envs ann_expr + + | otherwise -- Not primitive type so could be let-bound + = setFloatLevel False {- Not already let-bound -} + ctxt_lvl envs ann_expr ty `thenLvl` \ (final_lvl, expr') -> + returnLvl expr' + where + ty = typeOfCoreExpr (deAnnotate ann_expr) +\end{code} + + +%************************************************************************ +%* * +\subsection{Deciding floatability} +%* * +%************************************************************************ + +@setFloatLevel@ is used for let-bound right-hand-sides, or for MFEs which +are being created as let-bindings + +Decision tree: +Let Bound? + YES. -> (a) try abstracting type variables. + If we abstract type variables it will go further, that is, past more + lambdas. same as asking if the level number given by the free + variables is less than the level number given by free variables + and type variables together. + Abstract offending type variables, e.g. + change f ty a b + to let v = /\ty' -> f ty' a b + in v ty + so that v' is not stopped by the level number of ty + tag the original let with its level number + (from its variables and type variables) + NO. is a WHNF? + YES. -> No point in let binding to float a WHNF. + Pin (leave) expression here. + NO. -> Will float past a lambda? + (check using free variables only, not type variables) + YES. -> do the same as (a) above. + NO. -> No point in let binding if it is not going anywhere + Pin (leave) expression here. + +\begin{code} +setFloatLevel :: Bool -- True <=> the expression is already let-bound + -- False <=> it's a possible MFE + -> Level -- of context + -> LevelEnvs + + -> CoreExprWithFVs -- Original rhs + -> UniType -- Type of rhs + + -> LvlM (Level, -- Level to attribute to this let-binding + LevelledExpr) -- Final rhs + +setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) + expr@(FVInfo fvs tfvs might_leak, _) ty +-- Invariant: ctxt_lvl is never = Top +-- Beautiful ASSERT, dudes (WDP 95/04)... + +-- Now deal with (by not floating) trivial non-let-bound expressions +-- which just aren't worth let-binding in order to float. We always +-- choose to float even trivial let-bound things because it doesn't do +-- any harm, and not floating it may pin something important. For +-- example +-- +-- x = let v = Nil +-- w = 1:v +-- in ... +-- +-- Here, if we don't float v we won't float w, which is Bad News. +-- If this gives any problems we could restrict the idea to things destined +-- for top level. + + | not alreadyLetBound + && (manifestly_whnf || not will_float_past_lambda) + = -- Pin whnf non-let-bound expressions, + -- or ones which aren't going anywhere useful + lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' -> + returnLvl (ctxt_lvl, expr') + + | alreadyLetBound && not worth_type_abstraction + = -- Process the expression with a new ctxt_lvl, obtained from + -- the free vars of the expression itself + lvlExpr (unTopify expr_lvl) envs expr `thenLvl` \ expr' -> + returnLvl (maybe_unTopify expr_lvl, expr') + + | otherwise -- This will create a let anyway, even if there is no + -- type variable to abstract, so we try to abstract anyway + = abstractWrtTyVars offending_tyvars ty envs lvl_after_ty_abstr expr + `thenLvl` \ final_expr -> + returnLvl (expr_lvl, final_expr) + -- OLD LIE: The body of the let, just a type application, isn't worth floating + -- so pin it with ctxt_lvl + -- The truth: better to give it expr_lvl in case it is pinning + -- something non-trivial which depends on it. + where + fv_list = uniqSetToList fvs + tv_list = uniqSetToList tfvs + expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl + ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list + tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list + lvl_after_ty_abstr = ids_only_lvl --`maxLvl` non_offending_tyvars_lvl + + will_float_past_lambda = -- Will escape lambda if let-bound + ids_only_lvl `ltMajLvl` ctxt_lvl + + worth_type_abstraction = -- Will escape (more) lambda(s)/type lambda(s) + -- if type abstracted + (ids_only_lvl `ltLvl` tyvars_only_lvl) + && not (is_trivial de_ann_expr) -- avoids abstracting trivial type applications + + de_ann_expr = deAnnotate expr + + is_trivial (CoTyApp e _) = is_trivial e + is_trivial (CoVar _) = True + is_trivial _ = False + + offending_tyvars = filter offending tv_list + --non_offending_tyvars = filter (not . offending) tv_list + --non_offending_tyvars_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL non_offending_tyvars + + offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar + + manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr + + maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0 + maybe_unTopify lvl = lvl + {- ToDo [Andre]: the line above (maybe) should be Level 1 0, + -- so that the let will not go past the *last* lambda if it can + -- generate a space leak. If it is already in major level 0 + -- It won't do any harm to give it a Level 1 0. + -- we should do the same test not only for things with level Top, + -- but also for anything that gets a major level 0. + the problem is that + f = \a -> let x = [1..1000] + in zip a x + ==> + f = let x = [1..1000] + in \a -> zip a x + is just as bad as floating x to the top level. + Notice it would be OK in cases like + f = \a -> let x = [1..1000] + y = length x + in a + y + ==> + f = let x = [1..1000] + y = length x + in \a -> a + y + as x will be gc'd after y is updated. + [We did not hit any problems with the above (Level 0 0) code + in nofib benchmark] + -} +\end{code} + +Abstract wrt tyvars, by making it just as if we had seen + + let v = /\a1..an. E + in v a1 ... an + +instead of simply E. The idea is that v can be freely floated, since it +has no free type variables. Of course, if E has no free type +variables, then we just return E. + +\begin{code} +abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr + = lvlExpr incd_lvl new_envs expr `thenLvl` \ expr' -> + newLvlVar poly_ty `thenLvl` \ poly_var -> + let + poly_var_rhs = mkCoTyLam offending_tyvars expr' + poly_var_binding = CoNonRec (poly_var, lvl) poly_var_rhs + poly_var_app = mkCoTyApps (CoVar poly_var) (map mkTyVarTy offending_tyvars) + final_expr = CoLet poly_var_binding poly_var_app -- mkCoLet* requires PlainCore + in + returnLvl final_expr + where + poly_ty = snd (quantifyTy offending_tyvars ty) + + -- These defns are just like those in the TyLam case of lvlExpr + (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars + + next lvl tyvar = (lvl1, (tyvar,lvl1)) + where lvl1 = incMinorLvl lvl + + new_tenv = growTyVarEnvList tenv tyvar_lvls + new_envs = (venv, new_tenv) +\end{code} + +Recursive definitions. We want to transform + + letrec + x1 = e1 + ... + xn = en + in + body + +to + + letrec + x1' = /\ ab -> let D' in e1 + ... + xn' = /\ ab -> let D' in en + in + let D in body + +where ab are the tyvars pinning the defn further in than it +need be, and D is a bunch of simple type applications: + + x1_cl = x1' ab + ... + xn_cl = xn' ab + +The "_cl" indicates that in D, the level numbers on the xi are the context level +number; type applications aren't worth floating. The D' decls are +similar: + + x1_ll = x1' ab + ... + xn_ll = xn' ab + +but differ in their level numbers; here the ab are the newly-introduced +type lambdas. + +\begin{code} +decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss + | isTopMajLvl ids_only_lvl && -- Destination = top + not (all canFloatToTop (tys `zip` rhss)) -- Some can't float to top + = -- Pin it here + let + ids_w_lvls = ids `zip` repeat ctxt_lvl + new_envs = (growIdEnvList venv ids_w_lvls, tenv) + in + mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' -> + returnLvl (ctxt_lvl, [], rhss') + +{- OMITTED; see comments above near isWorthFloatingExpr + + | not (any (isWorthFloating True . deAnnotate) rhss) + = -- Pin it here + mapLvl (lvlExpr ctxt_lvl envs) rhss `thenLvl` \ rhss' -> + returnLvl (ctxt_lvl, [], rhss') + +-} + + | ids_only_lvl `ltLvl` tyvars_only_lvl + = -- Abstract wrt tyvars; + -- offending_tyvars is definitely non-empty + -- (I love the ASSERT to check this... WDP 95/02) + let + -- These defns are just like those in the TyLam case of lvlExpr + (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify ids_only_lvl) offending_tyvars + + next lvl tyvar = (lvl1, (tyvar,lvl1)) + where lvl1 = incMinorLvl lvl + + ids_w_incd_lvl = [(id,incd_lvl) | id <- ids] + new_tenv = growTyVarEnvList tenv tyvar_lvls + new_venv = growIdEnvList venv ids_w_incd_lvl + new_envs = (new_venv, new_tenv) + in + mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' -> + mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars -> + let + ids_w_poly_vars = ids `zip` poly_vars + + -- The "d_rhss" are the right-hand sides of "D" and "D'" + -- in the documentation above + d_rhss = [ mkCoTyApps (CoVar poly_var) offending_tyvar_tys | poly_var <- poly_vars] + + -- "local_binds" are "D'" in the documentation above + local_binds = zipWith CoNonRec ids_w_incd_lvl d_rhss + + poly_var_rhss = [ mkCoTyLam offending_tyvars (foldr CoLet rhs' local_binds) + | rhs' <- rhss' -- mkCoLet* requires PlainCore... + ] + + poly_binds = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss + + in + returnLvl (ctxt_lvl, [CoRec poly_binds], d_rhss) + -- The new right-hand sides, just a type application, aren't worth floating + -- so pin it with ctxt_lvl + + | otherwise + = -- Let it float freely + let + ids_w_lvls = ids `zip` repeat expr_lvl + new_envs = (growIdEnvList venv ids_w_lvls, tenv) + in + mapLvl (lvlExpr (unTopify expr_lvl) new_envs) rhss `thenLvl` \ rhss' -> + returnLvl (expr_lvl, [], rhss') + + where + tys = map getIdUniType ids + + fvs = unionManyUniqSets [freeVarsOf rhs | rhs <- rhss] `minusUniqSet` mkUniqSet ids + tfvs = unionManyUniqSets [freeTyVarsOf rhs | rhs <- rhss] + fv_list = uniqSetToList fvs + tv_list = uniqSetToList tfvs + + ids_only_lvl = foldr (maxLvl . idLevel venv) tOP_LEVEL fv_list + tyvars_only_lvl = foldr (maxLvl . tyvarLevel tenv) tOP_LEVEL tv_list + expr_lvl = ids_only_lvl `maxLvl` tyvars_only_lvl + + offending_tyvars + | ids_only_lvl `ltLvl` tyvars_only_lvl = filter offending tv_list + | otherwise = [] + + offending_tyvar_tys = map mkTyVarTy offending_tyvars + poly_tys = [ snd (quantifyTy offending_tyvars ty) + | ty <- tys + ] + + offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar +\end{code} + + +\begin{code} +{- ******** OMITTED NOW + +isWorthFloating :: Bool -- True <=> already let-bound + -> PlainCoreExpr -- The expression + -> Bool + +isWorthFloating alreadyLetBound expr + + | alreadyLetBound = isWorthFloatingExpr expr + + | otherwise = -- No point in adding a fresh let-binding for a WHNF, because + -- floating it isn't beneficial enough. + isWorthFloatingExpr expr && + not (manifestlyWHNF expr || manifestlyBottom expr) +********** -} + +isWorthFloatingExpr :: PlainCoreExpr -> Bool +isWorthFloatingExpr (CoVar v) = False +isWorthFloatingExpr (CoLit lit) = False +isWorthFloatingExpr (CoCon con tys []) = False -- Just a type application +isWorthFloatingExpr (CoTyApp expr ty) = isWorthFloatingExpr expr +isWorthFloatingExpr other = True + +canFloatToTop :: (UniType, CoreExprWithFVs) -> Bool + +canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True +canFloatToTop (ty, (FVInfo _ _ MightLeak, expr)) = isLeakFreeType [] ty + +valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr +\end{code} + + + +%************************************************************************ +%* * +\subsection{Help functions} +%* * +%************************************************************************ + +\begin{code} +idLevel :: IdEnv Level -> Id -> Level +idLevel venv v + = case lookupIdEnv venv v of + Just level -> level + Nothing -> ASSERT(toplevelishId v) + tOP_LEVEL + +tyvarLevel :: TyVarEnv Level -> TyVar -> Level +tyvarLevel tenv tyvar + = case lookupTyVarEnv tenv tyvar of + Just level -> level + Nothing -> tOP_LEVEL +\end{code} + +%************************************************************************ +%* * +\subsection{Free-To-Level Monad} +%* * +%************************************************************************ + +\begin{code} +type LvlM result + = (GlobalSwitch -> Bool) -> SplitUniqSupply -> result + +thenLvl m k sw us + = case splitUniqSupply us of { (s1, s2) -> + case m sw s1 of { m_result -> + k m_result sw s2 }} + +returnLvl v sw us = v + +mapLvl f [] = returnLvl [] +mapLvl f (x:xs) + = f x `thenLvl` \ r -> + mapLvl f xs `thenLvl` \ rs -> + returnLvl (r:rs) + +mapAndUnzipLvl f [] = returnLvl ([], []) +mapAndUnzipLvl f (x:xs) + = f x `thenLvl` \ (r1, r2) -> + mapAndUnzipLvl f xs `thenLvl` \ (rs1, rs2) -> + returnLvl (r1:rs1, r2:rs2) + +mapAndUnzip3Lvl f [] = returnLvl ([], [], []) +mapAndUnzip3Lvl f (x:xs) + = f x `thenLvl` \ (r1, r2, r3) -> + mapAndUnzip3Lvl f xs `thenLvl` \ (rs1, rs2, rs3) -> + returnLvl (r1:rs1, r2:rs2, r3:rs3) +\end{code} + +We create a let-binding for `interesting' (non-utterly-trivial) +applications, to give them a fighting chance of being floated. + +\begin{code} +newLvlVar :: UniType -> LvlM Id + +newLvlVar ty sw us + = id + where + id = mkSysLocal SLIT("lvl") uniq ty mkUnknownSrcLoc + uniq = getSUnique us +\end{code} diff --git a/ghc/compiler/simplCore/SimplCase.hi b/ghc/compiler/simplCore/SimplCase.hi new file mode 100644 index 0000000..79ec6cd --- /dev/null +++ b/ghc/compiler/simplCore/SimplCase.hi @@ -0,0 +1,14 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplCase where +import BinderInfo(BinderInfo) +import CoreSyn(CoreBinding, CoreCaseAlternatives, CoreExpr) +import Id(Id) +import SimplEnv(SimplEnv) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import UniType(UniType) +bindLargeRhs :: SimplEnv -> [(Id, BinderInfo)] -> UniType -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> SplitUniqSupply -> SimplCount -> ((CoreBinding Id Id, CoreExpr (Id, BinderInfo) Id), SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 212222 _N_ _S_ "LSLS" _N_ _N_ #-} +simplCase :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> CoreCaseAlternatives (Id, BinderInfo) Id -> (SimplEnv -> CoreExpr (Id, BinderInfo) Id -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount) + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LSLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs new file mode 100644 index 0000000..ed57249 --- /dev/null +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -0,0 +1,941 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[SimplCase]{Simplification of `case' expression} + +Support code for @Simplify@. + +\begin{code} +#include "HsVersions.h" + +module SimplCase ( simplCase, bindLargeRhs ) where + +IMPORT_Trace +import Pretty -- these are for debugging only +import Outputable + +import SimplMonad +import SimplEnv +import TaggedCore +import PlainCore + +import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp, + voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( splitType, splitTyArgs, glueTyArgs, + getTyConFamilySize, isPrimType, + getUniDataTyCon_maybe + ) +import BasicLit ( isNoRepLit, BasicLit, PrimKind ) +import CmdLineOpts ( SimplifierSwitch(..) ) +import Id +import IdInfo +import Maybes ( catMaybes, maybeToBool, Maybe(..) ) +import Simplify +import SimplUtils +import SimplVar ( completeVar ) +import Util +\end{code} + + + + + +Float let out of case. + +\begin{code} +simplCase :: SimplEnv + -> InExpr -- Scrutinee + -> InAlts -- Alternatives + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler + -> OutUniType -- Type of result expression + -> SmplM OutExpr + +simplCase env (CoLet bind body) alts rhs_c result_ty + = -- Float the let outside the case scrutinee + tick LetFloatFromCase `thenSmpl_` + simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty +\end{code} + +OK to do case-of-case if + +* we allow arbitrary code duplication + +OR + +* the inner case has one alternative + case (case e of (a,b) -> rhs) of + ... + pi -> rhsi + ... + ===> + case e of + (a,b) -> case rhs of + ... + pi -> rhsi + ... + +IF neither of these two things are the case, we avoid code-duplication +by abstracting the outer rhss wrt the pattern variables. For example + + case (case e of { p1->rhs1; ...; pn -> rhsn }) of + (x,y) -> body +===> + let b = \ x y -> body + in + case e of + p1 -> case rhs1 of (x,y) -> b x y + ... + pn -> case rhsn of (x,y) -> b x y + + +OK, so outer case expression gets duplicated, but that's all. Furthermore, + (a) the binding for "b" will be let-no-escaped, so no heap allocation + will take place; the "call" to b will simply be a stack adjustment + and a jump + (b) very commonly, at least some of the rhsi's will be constructors, which + makes life even simpler. + +All of this works equally well if the outer case has multiple rhss. + + +\begin{code} +simplCase env (CoCase inner_scrut inner_alts) outer_alts rhs_c result_ty + | switchIsSet env SimplCaseOfCase + = -- Ha! Do case-of-case + tick CaseOfCase `thenSmpl_` + + if no_need_to_bind_large_alts + then + simplCase env inner_scrut inner_alts + (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty + else + bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') -> + let + rhs_c' = \env rhs -> simplExpr env rhs [] + in + simplCase env inner_scrut inner_alts + (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty) + result_ty + `thenSmpl` \ case_expr -> + returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr) + + where + no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode || + isSingleton (nonErrorRHSs inner_alts) +\end{code} + +Case of an application of error. + +\begin{code} +simplCase env scrut alts rhs_c result_ty + | maybeToBool maybe_error_app + = -- Look for an application of an error id + tick CaseOfError `thenSmpl_` + rhs_c env retyped_error_app + where + alts_ty = typeOfCoreAlts (unTagBindersAlts alts) + maybe_error_app = maybeErrorApp scrut (Just alts_ty) + Just retyped_error_app = maybe_error_app +\end{code} + +Finally the default case + +\begin{code} +simplCase env other_scrut alts rhs_c result_ty + = -- Float the let outside the case scrutinee + simplExpr env other_scrut [] `thenSmpl` \ scrut' -> + completeCase env scrut' alts rhs_c +\end{code} + + +%************************************************************************ +%* * +\subsection[Simplify-case]{Completing case-expression simplification} +%* * +%************************************************************************ + +\begin{code} +completeCase + :: SimplEnv + -> OutExpr -- The already-simplified scrutinee + -> InAlts -- The un-simplified alternatives + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler + -> SmplM OutExpr -- The whole case expression +\end{code} + +Scrutinising a literal or constructor. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's an obvious win to do: + + case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q] + +and the similar thing for primitive case. If we have + + case x of ... + +and x is known to be of constructor form, then we'll already have +inlined the constructor to give (case (C a b) of ...), so we don't +need to check for the variable case separately. + +Sanity check: we don't have a good +story to tell about case analysis on NoRep things. ToDo. + +\begin{code} +completeCase env (CoLit lit) alts rhs_c + | not (isNoRepLit lit) + = -- Ha! Select the appropriate alternative + tick KnownBranch `thenSmpl_` + completePrimCaseWithKnownLit env lit alts rhs_c + +completeCase env expr@(CoCon con tys con_args) alts rhs_c + = -- Ha! Staring us in the face -- select the appropriate alternative + tick KnownBranch `thenSmpl_` + completeAlgCaseWithKnownCon env con tys con_args alts rhs_c +\end{code} + +Case elimination +~~~~~~~~~~~~~~~~ +Start with a simple situation: + + case x# of ===> e[x#/y#] + y# -> e + +(when x#, y# are of primitive type, of course). +We can't (in general) do this for algebraic cases, because we might +turn bottom into non-bottom! + +Actually, we generalise this idea to look for a case where we're +scrutinising a variable, and we know that only the default case can +match. For example: +\begin{verbatim} + case x of + 0# -> ... + other -> ...(case x of + 0# -> ... + other -> ...) ... +\end{code} +Here the inner case can be eliminated. This really only shows up in +eliminating error-checking code. + +Lastly, we generalise the transformation to handle this: + + case e of ===> r + True -> r + False -> r + +We only do this for very cheaply compared r's (constructors, literals +and variables). If pedantic bottoms is on, we only do it when the +scrutinee is a PrimOp which can't fail. + +We do it *here*, looking at un-simplified alternatives, because we +have to check that r doesn't mention the variables bound by the +pattern in each alternative, so the binder-info is rather useful. + +So the case-elimination algorithm is: + + 1. Eliminate alternatives which can't match + + 2. Check whether all the remaining alternatives + (a) do not mention in their rhs any of the variables bound in their pattern + and (b) have equal rhss + + 3. Check we can safely ditch the case: + * PedanticBottoms is off, + or * the scrutinee is an already-evaluated variable + or * the scrutinee is a primop which is ok for speculation + -- ie we want to preserve divide-by-zero errors, and + -- calls to error itself! + + or * [Prim cases] the scrutinee is a primitive variable + + or * [Alg cases] the scrutinee is a variable and + either * the rhs is the same variable + (eg case x of C a b -> x ===> x) + or * there is only one alternative, the default alternative, + and the binder is used strictly in its scope. + [NB this is helped by the "use default binder where + possible" transformation; see below.] + + +If so, then we can replace the case with one of the rhss. + +\begin{code} +completeCase env scrut alts rhs_c + | switchIsSet env SimplDoCaseElim && + + binders_unused && + + all_rhss_same && + + (not (switchIsSet env SimplPedanticBottoms) || + scrut_is_evald || + scrut_is_eliminable_primitive || + rhs1_is_scrutinee || + scrut_is_var_and_single_strict_default + ) + + = tick CaseElim `thenSmpl_` + rhs_c new_env rhs1 + where + -- Find the non-excluded rhss of the case; always at least one + (rhs1:rhss) = possible_rhss + all_rhss_same = all (cheap_eq rhs1) rhss + + -- Find the reduced set of possible rhss, along with an indication of + -- whether none of their binders are used + (binders_unused, possible_rhss, new_env) + = case alts of + CoPrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt + deflt_rhs ++ rhss, + new_env) + where + (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt + + -- Eliminate unused rhss if poss + rhss = case scrut_form of + OtherLiteralForm not_these -> [rhs | (alt_lit,rhs) <- alts, + not (alt_lit `is_elem` not_these) + ] + other -> [rhs | (_,rhs) <- alts] + + CoAlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts, + deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts], + new_env) + where + (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt + + -- Eliminate unused alts if poss + possible_alts = case scrut_form of + OtherConstructorForm not_these -> + -- Remove alts which can't match + [alt | alt@(alt_con,_,_) <- alts, + not (alt_con `is_elem` not_these)] + +#ifdef DEBUG +-- ConstructorForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts)) + -- ConstructorForm can't happen, since we'd have + -- inlined it, and be in completeCaseWithKnownCon by now +#endif + other -> alts + + alt_binders_unused (con, args, rhs) = all is_dead args + is_dead (_, DeadCode) = True + is_dead other_arg = False + + -- If the scrutinee is a variable, look it up to see what we know about it + scrut_form = case scrut of + CoVar v -> lookupUnfolding env v + other -> NoUnfoldingDetails + + -- If the scrut is already eval'd then there's no worry about + -- eliminating the case + scrut_is_evald = case scrut_form of + OtherLiteralForm _ -> True + ConstructorForm _ _ _ -> True + OtherConstructorForm _ -> True + other -> False + + + scrut_is_eliminable_primitive + = case scrut of + CoPrim op _ _ -> primOpOkForSpeculation op + CoVar _ -> case alts of + CoPrimAlts _ _ -> True -- Primitive, hence non-bottom + CoAlgAlts _ _ -> False -- Not primitive + other -> False + + -- case v of w -> e{strict in w} ===> e[v/w] + scrut_is_var_and_single_strict_default + = case scrut of + CoVar _ -> case alts of + CoAlgAlts [] (CoBindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v) + other -> False + other -> False + + elim_deflt_binder CoNoDefault -- No Binder + = (True, [], env) + elim_deflt_binder (CoBindDefault (id, DeadCode) rhs) -- Binder unused + = (True, [rhs], env) + elim_deflt_binder (CoBindDefault used_binder rhs) -- Binder used + = case scrut of + CoVar v -> -- Binder used, but can be eliminated in favour of scrut + (True, [rhs], extendIdEnvWithAtom env used_binder (CoVarAtom v)) + non_var -> -- Binder used, and can't be elimd + (False, [rhs], env) + + -- Check whether the chosen unique rhs (ie rhs1) is the same as + -- the scrutinee. Remember that the rhs is as yet unsimplified. + rhs1_is_scrutinee = case (scrut, rhs1) of + (CoVar scrut_var, CoVar rhs_var) + -> case lookupId env rhs_var of + Just (ItsAnAtom (CoVarAtom rhs_var')) + -> rhs_var' == scrut_var + other -> False + other -> False + + is_elem x ys = isIn "completeCase" x ys +\end{code} + +Scrutinising anything else. If it's a variable, it can't be bound to a +constructor or literal, because that would have been inlined + +\begin{code} +completeCase env scrut alts rhs_c + = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' -> + mkCoCase scrut alts' +\end{code} + + + + +\begin{code} +bindLargeAlts :: SimplEnv + -> InAlts + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler + -> OutUniType -- Result type + -> SmplM ([OutBinding], -- Extra bindings + InAlts) -- Modified alts + +bindLargeAlts env the_lot@(CoAlgAlts alts deflt) rhs_c rhs_ty + = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') -> + bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') -> + returnSmpl (deflt_bindings ++ alt_bindings, CoAlgAlts alts' deflt') + where + do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty + (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') -> + returnSmpl (bind, (con,args,rhs')) + +bindLargeAlts env the_lot@(CoPrimAlts alts deflt) rhs_c rhs_ty + = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') -> + bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') -> + returnSmpl (deflt_bindings ++ alt_bindings, CoPrimAlts alts' deflt') + where + do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty + (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') -> + returnSmpl (bind, (lit,rhs')) + +bindLargeDefault env CoNoDefault rhs_ty rhs_c + = returnSmpl ([], CoNoDefault) +bindLargeDefault env (CoBindDefault binder rhs) rhs_ty rhs_c + = bindLargeRhs env [binder] rhs_ty + (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') -> + returnSmpl ([bind], CoBindDefault binder rhs') +\end{code} + + bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c + | otherwise = (rhs_id = \x1..xn -> rhs_c rhs, + rhs_id x1 .. xn) + +\begin{code} +bindLargeRhs :: SimplEnv + -> [InBinder] -- The args wrt which the rhs should be abstracted + -> OutUniType + -> (SimplEnv -> SmplM OutExpr) -- Rhs handler + -> SmplM (OutBinding, -- New bindings (singleton or empty) + InExpr) -- Modified rhs + +bindLargeRhs env args rhs_ty rhs_c + | null used_args && isPrimType rhs_ty + -- If we try to lift a primitive-typed something out + -- for let-binding-purposes, we will *caseify* it (!), + -- with potentially-disastrous strictness results. So + -- instead we turn it into a function: \v -> e + -- where v::VoidPrim. Since arguments of type + -- VoidPrim don't generate any code, this gives the + -- desired effect. + -- + -- The general structure is just the same as for the common "otherwise~ case + = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id -> + newId voidPrimTy `thenSmpl` \ void_arg_id -> + rhs_c env `thenSmpl` \ prim_new_body -> + + returnSmpl (CoNonRec prim_rhs_fun_id (mkCoLam [void_arg_id] prim_new_body), + CoApp (CoVar prim_rhs_fun_id) (CoVarAtom voidPrimId)) + + | otherwise + = -- Make the new binding Id. NB: it's an OutId + newId rhs_fun_ty `thenSmpl` \ rhs_fun_id -> + + -- Generate its rhs + cloneIds env used_args `thenSmpl` \ used_args' -> + let + new_env = extendIdEnvWithClones env used_args used_args' + in + rhs_c new_env `thenSmpl` \ rhs' -> + let + final_rhs + = (if switchIsSet new_env SimplDoEtaReduction + then mkCoLamTryingEta + else mkCoLam) used_args' rhs' + in + returnSmpl (CoNonRec rhs_fun_id final_rhs, + foldl CoApp (CoVar rhs_fun_id) used_arg_atoms) + -- This is slightly wierd. We're retuning an OutId as part of the + -- modified rhs, which is meant to be an InExpr. However, that's ok, because when + -- it's processed the OutId won't be found in the environment, so it + -- will be left unmodified. + where + rhs_fun_ty :: OutUniType + rhs_fun_ty = glueTyArgs [simplTy env (getIdUniType id) | (id,_) <- used_args] rhs_ty + + used_args = [arg | arg@(_,usage) <- args, not (dead usage)] + used_arg_atoms = [CoVarAtom arg_id | (arg_id,_) <- used_args] + dead DeadCode = True + dead other = False + + prim_rhs_fun_ty = mkFunTy voidPrimTy rhs_ty +\end{code} + +Case alternatives when we don't know the scrutinee +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A special case for case default. If we have +\begin{verbatim} +case x of + p1 -> e1 + y -> default_e +\end{verbatim} +it is best to make sure that \tr{default_e} mentions \tr{x} in +preference to \tr{y}. The code generator can do a cheaper job if it +doesn't have to come up with a binding for \tr{y}. + +\begin{code} +simplAlts :: SimplEnv + -> OutExpr -- Simplified scrutinee; + -- only of interest if its a var, + -- in which case we record its form + -> InAlts + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler + -> SmplM OutAlts + +simplAlts env scrut (CoAlgAlts alts deflt) rhs_c + = mapSmpl do_alt alts `thenSmpl` \ alts' -> + simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' -> + returnSmpl (CoAlgAlts alts' deflt') + where + deflt_form = OtherConstructorForm [con | (con,_,_) <- alts] + do_alt (con, con_args, rhs) + = cloneIds env con_args `thenSmpl` \ con_args' -> + let + env1 = extendIdEnvWithClones env con_args con_args' + new_env = case scrut of + CoVar var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args') + other -> env1 + in + rhs_c new_env rhs `thenSmpl` \ rhs' -> + returnSmpl (con, con_args', rhs') + +simplAlts env scrut (CoPrimAlts alts deflt) rhs_c + = mapSmpl do_alt alts `thenSmpl` \ alts' -> + simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' -> + returnSmpl (CoPrimAlts alts' deflt') + where + deflt_form = OtherLiteralForm [lit | (lit,_) <- alts] + do_alt (lit, rhs) + = let + new_env = case scrut of + CoVar var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LiteralForm lit)) + other -> env + in + rhs_c new_env rhs `thenSmpl` \ rhs' -> + returnSmpl (lit, rhs') +\end{code} + +Use default binder where possible +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's one complication when simplifying the default clause of +a case expression. If we see + + case x of + x' -> ...x...x'... + +we'd like to convert it to + + case x of + x' -> ...x'...x'... + +Reason 1: then there might be just one occurrence of x, and it can be +inlined as the case scrutinee. So we spot this case when dealing with +the default clause, and add a binding to the environment mapping x to +x'. + +Reason 2: if the body is strict in x' then we can eliminate the +case altogether. By using x' in preference to x we give the max chance +of the strictness analyser finding that the body is strict in x'. + +On the other hand, if x does *not* get inlined, then we'll actually +get somewhat better code from the former expression. So when +doing Core -> STG we convert back! + +\begin{code} +simplDefault + :: SimplEnv + -> OutExpr -- Simplified scrutinee + -> InDefault -- Default alternative to be completed + -> UnfoldingDetails -- Gives form of scrutinee + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler + -> SmplM OutDefault + +simplDefault env scrut CoNoDefault form rhs_c + = returnSmpl CoNoDefault + +-- Special case for variable scrutinee; see notes above. +simplDefault env (CoVar scrut_var) (CoBindDefault binder rhs) form_from_this_case rhs_c + = cloneId env binder `thenSmpl` \ binder' -> + let + env1 = extendIdEnvWithAtom env binder (CoVarAtom binder') + + -- Add form details for the default binder + scrut_form = lookupUnfolding env scrut_var + final_form + = case (form_from_this_case, scrut_form) of + (OtherConstructorForm cs, OtherConstructorForm ds) -> OtherConstructorForm (cs++ds) + (OtherLiteralForm cs, OtherLiteralForm ds) -> OtherLiteralForm (cs++ds) + -- ConstructorForm, LiteralForm impossible + -- (ASSERT? ASSERT? Hello? WDP 95/05) + other -> form_from_this_case + + env2 = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' final_form) + + -- Change unfold details for scrut var. We now want to unfold it + -- to binder' + new_scrut_var_form = GeneralForm True {- OK to dup -} WhnfForm + (CoVar binder') UnfoldAlways + new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form + + in + rhs_c new_env rhs `thenSmpl` \ rhs' -> + returnSmpl (CoBindDefault binder' rhs') + +simplDefault env scrut (CoBindDefault binder rhs) form rhs_c + = cloneId env binder `thenSmpl` \ binder' -> + let + env1 = extendIdEnvWithAtom env binder (CoVarAtom binder') + new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form) + in + rhs_c new_env rhs `thenSmpl` \ rhs' -> + returnSmpl (CoBindDefault binder' rhs') +\end{code} + +Case alternatives when we know what the scrutinee is +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +\begin{code} +completePrimCaseWithKnownLit + :: SimplEnv + -> BasicLit + -> InAlts + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler + -> SmplM OutExpr + +completePrimCaseWithKnownLit env lit (CoPrimAlts alts deflt) rhs_c + = search_alts alts + where + search_alts :: [(BasicLit, InExpr)] -> SmplM OutExpr + + search_alts ((alt_lit, rhs) : _) + | alt_lit == lit + = -- Matching alternative! + rhs_c env rhs + + search_alts (_ : other_alts) + = -- This alternative doesn't match; keep looking + search_alts other_alts + + search_alts [] + = case deflt of + CoNoDefault -> -- Blargh! + panic "completePrimCaseWithKnownLit: No matching alternative and no default" + + CoBindDefault binder rhs -> -- OK, there's a default case + -- Just bind the Id to the atom and continue + let + new_env = extendIdEnvWithAtom env binder (CoLitAtom lit) + in + rhs_c new_env rhs +\end{code} + +@completeAlgCaseWithKnownCon@: We know the constructor, so we can +select one case alternative (or default). If we choose the default: +we do different things depending on whether the constructor was +staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}}) +[let-bind it] or we just know the \tr{y} is now the same as some other +var [substitute \tr{y} out of existence]. + +\begin{code} +completeAlgCaseWithKnownCon + :: SimplEnv + -> DataCon -> [UniType] -> [InAtom] + -- Scrutinee is (con, type, value arguments) + -> InAlts + -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler + -> SmplM OutExpr + +completeAlgCaseWithKnownCon env con tys con_args (CoAlgAlts alts deflt) rhs_c + = ASSERT(isDataCon con) + search_alts alts + where + search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr + + search_alts ((alt_con, alt_args, rhs) : _) + | alt_con == con + = -- Matching alternative! + let + new_env = extendIdEnvWithAtomList env (zip alt_args con_args) + in + rhs_c new_env rhs + + search_alts (_ : other_alts) + = -- This alternative doesn't match; keep looking + search_alts other_alts + + search_alts [] + = -- No matching alternative + case deflt of + CoNoDefault -> -- Blargh! + panic "completeAlgCaseWithKnownCon: No matching alternative and no default" + + CoBindDefault binder rhs -> -- OK, there's a default case + -- let-bind the binder to the constructor + cloneId env binder `thenSmpl` \ id' -> + let + env1 = extendIdEnvWithClone env binder id' + new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id' + (ConstructorForm con tys con_args)) + in + rhs_c new_env rhs `thenSmpl` \ rhs' -> + returnSmpl (CoLet (CoNonRec id' (CoCon con tys con_args)) rhs') +\end{code} + +Case absorption and identity-case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +\begin{code} +mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr +\end{code} + +@mkCoCase@ tries the following transformation (if possible): + +case v of ==> case v of + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn} + {or (prim) case v of d -> rhsn} + pn -> rhsn ... + ... po -> rhso[v/d] + po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd} + d' -> rhsd + +which merges two cases in one case when -- the default alternative of +the outer case scrutises the same variable as the outer case This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. + +There's a closely-related transformation: + +case e of ==> case e of + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + d -> case d of pn -> let d = pn in rhsn + pn -> rhsn ... + ... po -> let d = po in rhso + po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd} + d' -> rhsd + +Here, the let's are essential, because d isn't in scope any more. +Sigh. Of course, they may be unused, in which case they'll be +eliminated on the next round. Unfortunately, we can't figure out +whether or not they are used at this juncture. + +NB: The binder in a CoBindDefault USED TO BE guaranteed unused if the +scrutinee is a variable, because it'll be mapped to the scrutinised +variable. Hence the [v/d] substitions can be omitted. + +ALAS, now the default binder is used by preference, so we have to +generate trivial lets to express the substitutions, which will be +eliminated on the next pass. + +The following code handles *both* these transformations (one +equation for AlgAlts, one for PrimAlts): + +\begin{code} +mkCoCase scrut (CoAlgAlts outer_alts + (CoBindDefault deflt_var + (CoCase (CoVar scrut_var') + (CoAlgAlts inner_alts inner_deflt)))) + | (scrut_is_var && scrut_var == scrut_var') -- First transformation + || deflt_var == scrut_var' -- Second transformation + = -- Aha! The default-absorption rule applies + tick CaseMerge `thenSmpl_` + returnSmpl (CoCase scrut (CoAlgAlts (outer_alts ++ munged_reduced_inner_alts) + (munge_alg_deflt deflt_var inner_deflt))) + -- NB: see comment in this location for the CoPrimAlts case + where + -- Check scrutinee + scrut_is_var = case scrut of {CoVar v -> True; other -> False} + scrut_var = case scrut of CoVar v -> v + + -- Eliminate any inner alts which are shadowed by the outer ones + reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts, + not (con `is_elem` outer_cons)] + outer_cons = [con | (con,_,_) <- outer_alts] + is_elem = isIn "mkAlgAlts" + + -- Add the lets if necessary + munged_reduced_inner_alts = map munge_alt reduced_inner_alts + + munge_alt (con, args, rhs) = (con, args, CoLet (CoNonRec deflt_var v) rhs) + where + v | scrut_is_var = CoVar scrut_var + | otherwise = CoCon con arg_tys (map CoVarAtom args) + + arg_tys = case getUniDataTyCon_maybe (getIdUniType deflt_var) of + Just (_, arg_tys, _) -> arg_tys + +mkCoCase scrut (CoPrimAlts + outer_alts + (CoBindDefault deflt_var (CoCase + (CoVar scrut_var') + (CoPrimAlts inner_alts inner_deflt)))) + | (scrut_is_var && scrut_var == scrut_var') || + deflt_var == scrut_var' + = -- Aha! The default-absorption rule applies + tick CaseMerge `thenSmpl_` + returnSmpl (CoCase scrut (CoPrimAlts (outer_alts ++ munged_reduced_inner_alts) + (munge_prim_deflt deflt_var inner_deflt))) + + -- Nota Bene: we don't recurse to mkCoCase again, because the + -- default will now have a binding in it that prevents + -- mkCoCase doing anything useful. Much worse, in this + -- PrimAlts case the binding in the default branch is another + -- CoCase, so if we recurse to mkCoCase we will get into an + -- infinite loop. + -- + -- ToDo: think of a better way to do this. At the moment + -- there is at most one case merge per round. That's probably + -- plenty but it seems unclean somehow. + where + -- Check scrutinee + scrut_is_var = case scrut of {CoVar v -> True; other -> False} + scrut_var = case scrut of CoVar v -> v + + -- Eliminate any inner alts which are shadowed by the outer ones + reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts, + not (lit `is_elem` outer_lits)] + outer_lits = [lit | (lit,_) <- outer_alts] + is_elem = isIn "mkPrimAlts" + + -- Add the lets (well cases actually) if necessary + -- The munged alternative looks like + -- lit -> case lit of d -> rhs + -- The next pass will certainly eliminate the inner case, but + -- it isn't easy to do so right away. + munged_reduced_inner_alts = map munge_alt reduced_inner_alts + + munge_alt (lit, rhs) + | scrut_is_var = (lit, CoCase (CoVar scrut_var) + (CoPrimAlts [] (CoBindDefault deflt_var rhs))) + | otherwise = (lit, CoCase (CoLit lit) + (CoPrimAlts [] (CoBindDefault deflt_var rhs))) +\end{code} + +Now the identity-case transformation: + + case e of ===> e + True -> True; + False -> False + +and similar friends. + +\begin{code} +mkCoCase scrut alts + | identity_alts alts + = tick CaseIdentity `thenSmpl_` + returnSmpl scrut + where + identity_alts (CoAlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt + identity_alts (CoPrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt + + identity_alg_alt (con, args, CoCon con' _ args') + = con == con' && and (zipWith eq_arg args args') + identity_alg_alt other + = False + + identity_prim_alt (lit, CoLit lit') = lit == lit' + identity_prim_alt other = False + + -- For the default case we want to spot both + -- x -> x + -- and + -- case y of { ... ; x -> y } + -- as "identity" defaults + identity_deflt CoNoDefault = True + identity_deflt (CoBindDefault binder (CoVar x)) = x == binder || + case scrut of + CoVar y -> y == x + other -> False + identity_deflt _ = False + + eq_arg binder (CoVarAtom x) = binder == x + eq_arg _ _ = False +\end{code} + +The catch-all case + +\begin{code} +mkCoCase other_scrut other_alts = returnSmpl (CoCase other_scrut other_alts) +\end{code} + +Boring local functions used above. They simply introduce a trivial binding +for the binder, d', in an inner default; either + let d' = deflt_var in rhs +or + case deflt_var of d' -> rhs +depending on whether it's an algebraic or primitive case. + +\begin{code} +munge_prim_deflt _ CoNoDefault = CoNoDefault + +munge_prim_deflt deflt_var (CoBindDefault d' rhs) + = CoBindDefault deflt_var (CoCase (CoVar deflt_var) + (CoPrimAlts [] (CoBindDefault d' rhs))) + +munge_alg_deflt _ CoNoDefault = CoNoDefault + +munge_alg_deflt deflt_var (CoBindDefault d' rhs) + = CoBindDefault deflt_var (CoLet (CoNonRec d' (CoVar deflt_var)) rhs) + +-- This line caused a generic version of munge_deflt (ie one used for +-- both alg and prim) to space leak massively. No idea why. +-- = CoBindDefault deflt_var (mkCoLetUnboxedToCase (CoNonRec d' (CoVar deflt_var)) rhs) +\end{code} + +\begin{code} + -- A cheap equality test which bales out fast! +cheap_eq :: InExpr -> InExpr -> Bool +cheap_eq (CoVar v1) (CoVar v2) = v1==v2 +cheap_eq (CoLit l1) (CoLit l2) = l1==l2 +cheap_eq (CoCon con1 tys1 args1) (CoCon con2 tys2 args2) = (con1==con2) && + (args1 `eq_args` args2) + -- Types bound to be equal +cheap_eq (CoPrim op1 tys1 args1) (CoPrim op2 tys2 args2) = (op1==op2) && + (args1 `eq_args` args2) + -- Types bound to be equal +cheap_eq (CoApp f1 a1) (CoApp f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2) +cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2) +cheap_eq _ _ = False + +-- ToDo: make CoreAtom an instance of Eq +eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2) +eq_args [] [] = True +eq_args other1 other2 = False + +eq_atom (CoLitAtom l1) (CoLitAtom l2) = l1==l2 +eq_atom (CoVarAtom v1) (CoVarAtom v2) = v1==v2 +eq_atom other1 other2 = False +\end{code} diff --git a/ghc/compiler/simplCore/SimplCore.hi b/ghc/compiler/simplCore/SimplCore.hi new file mode 100644 index 0000000..2dadf40 --- /dev/null +++ b/ghc/compiler/simplCore/SimplCore.hi @@ -0,0 +1,30 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplCore where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo) +import CmdLineOpts(CoreToDo, GlobalSwitch, SwitchResult) +import CoreSyn(CoreAtom, CoreBinding, CoreExpr) +import FiniteMap(FiniteMap) +import Id(Id) +import IdEnv(IdEnv(..)) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance) +import Specialise(SpecialiseData(..)) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type IdEnv a = UniqFM a +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +data SpecialiseData = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [[Labda UniType]]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType])) +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +core2core :: [CoreToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> [CoreBinding Id Id] -> _State _RealWorld -> (([CoreBinding Id Id], UniqFM UnfoldingDetails, SpecialiseData), _State _RealWorld) + {-# GHC_PRAGMA _A_ 9 _U_ 222222222 _N_ _S_ "SLLLLLLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs new file mode 100644 index 0000000..69f5393 --- /dev/null +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -0,0 +1,602 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[SimplCore]{Driver for simplifying @Core@ programs} + +\begin{code} +#include "HsVersions.h" + +module SimplCore ( + core2core, + + IdEnv(..), + UnfoldingDetails, + SpecialiseData(..), + UniqFM, Unique, Bag + ) where + +IMPORT_Trace +import Outputable +import Pretty + +import PlainCore + +import AbsUniType ( getTyConDataCons, alpha_ty, alpha_tyvar, beta_ty, beta_tyvar ) +--SAVE:import ArityAnal ( arityAnalProgram ) +import Bag +import BinderInfo ( BinderInfo) -- instances only +import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD, + uNFOLDING_USE_THRESHOLD, + uNFOLDING_OVERRIDE_THRESHOLD, + uNFOLDING_CON_DISCOUNT_WEIGHT + ) +import CmdLineOpts +import CoreLint ( lintCoreBindings ) +import FloatIn ( floatInwards ) +import FloatOut ( floatOutwards ) +import Id ( getIdUnfolding, + getIdUniType, toplevelishId, + idWantsToBeINLINEd, + unfoldingUnfriendlyId, isWrapperId, + mkTemplateLocals + IF_ATTACK_PRAGMAS(COMMA getIdStrictness) + ) +import IdEnv +import IdInfo +import LiberateCase ( liberateCase ) +import MainMonad +import Maybes +import SAT ( doStaticArgs ) +import SCCauto +import SimplEnv ( UnfoldingGuidance(..), SwitchChecker(..) ) -- instances +--ANDY: +--import SimplHaskell ( coreToHaskell ) +import SimplMonad ( zeroSimplCount, showSimplCount, TickType, SimplCount ) +import SimplPgm ( simplifyPgm ) +import SimplVar ( leastItCouldCost ) +import Specialise +import SpecTyFuns ( pprSpecErrs ) +import StrictAnal ( saWwTopBinds ) +#if ! OMIT_FOLDR_BUILD +import FoldrBuildWW +import AnalFBWW +#endif +#if ! OMIT_DEFORESTER +import Deforest ( deforestProgram ) +import DefUtils ( deforestable ) +#endif +import TyVarEnv ( nullTyVarEnv ) +import SplitUniq +import Unique +import Util +\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) + -> SplitUniqSupply -- a name supply + -> [TyCon] -- local data tycons and tycon specialisations + -> FiniteMap TyCon [[Maybe UniType]] + -> [PlainCoreBinding] -- input... + -> MainIO + ([PlainCoreBinding], -- results: program, plus... + 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 + = 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) + ) + else + (if do_verbose_core2core then + writeMn stderr "VERBOSE CORE-TO-CORE:\n" + else returnMn ()) `thenMn_` + + -- better do the main business + foldl_mn do_core_pass + (binds, us, nullIdEnv, init_specdata, zeroSimplCount) + core_todos + `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) -> + + (if switch_is_on D_simplifier_stats + then trace ("Simplifier Stats:\n" ++ showSimplCount simpl_stats) (returnMn ()) + else returnMn () + ) `thenMn_` + +{- LATER: + (if do_dump_core_passes + then trace (unlines ( + (nOfThem 78 '-' + : "Core2Core" + : "+------------------------------+" + : reverse [ " " ++ take (30::Int) (what ++ repeat ' ') ++ "|" + | what <- simpl_whats ]) + ++ ["+------------------------------+"])) + else \x -> x) -- to the end +-} + returnMn (processed_binds, inline_env, spec_data) + ESCC + where + init_specdata = initSpecData local_tycons tycon_specs + + switch_is_on = switchIsOn sw_chkr + + do_dump_core_passes = switch_is_on D_dump_core_passes -- an Andy flag + do_verbose_core2core = switch_is_on 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 + Nothing -> 4 * uNFOLDING_USE_THRESHOLD + Just xx -> 4 * xx + + ------------- + core_linter = if switch_is_on DoCoreLinting + then lintCoreBindings ppr_style + else ( \ whodunnit spec_done binds -> binds ) + + -------------- + do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do + = let + (us1, us2) = splitUniqSupply us + in + case to_do of + CoreDoSimplify simpl_sw_chkr + -> BSCC("CoreSimplify") + case (simplifyPgm binds sw_chkr simpl_sw_chkr simpl_stats us1) of + (p, it_cnt, simpl_stats2) + -> end_pass us2 p inline_env spec_data simpl_stats2 ("Simplify (" ++ show it_cnt ++ ")") + ESCC + + CoreDoFoldrBuildWorkerWrapper +#if OMIT_FOLDR_BUILD + -> error "ERROR: CoreDoFoldrBuildWorkerWrapper: not built into compiler\n" +#else + -> BSCC("CoreDoFoldrBuildWorkerWrapper") + end_pass us2 (mkFoldrBuildWW switch_is_on us1 binds) inline_env spec_data simpl_stats "FBWW" + ESCC +#endif + + CoreDoFoldrBuildWWAnal +#if OMIT_FOLDR_BUILD + -> error "ERROR: CoreDoFoldrBuildWWAnal: not built into compiler\n" +#else + -> BSCC("CoreDoFoldrBuildWWAnal") + end_pass us2 (analFBWW switch_is_on binds) inline_env spec_data simpl_stats "AnalFBWW" + ESCC +#endif + + CoreLiberateCase + -> BSCC("LiberateCase") + case (liberateCase lib_case_threshold binds) of { binds2 -> + end_pass us2 binds2 inline_env spec_data simpl_stats "LiberateCase" + } + ESCC + + CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres + -> BSCC("CoreInlinings1") + case (calcInlinings False sw_chkr inline_env binds) of { inline_env2 -> + end_pass us2 binds inline_env2 spec_data simpl_stats "Calc Inlinings" + } ESCC + + CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres + -> BSCC("CoreInlinings2") + case (calcInlinings True sw_chkr inline_env binds) of { inline_env2 -> + end_pass us2 binds inline_env2 spec_data simpl_stats "Calc Inlinings" + } ESCC + + CoreDoFloatInwards + -> BSCC("FloatInwards") + end_pass us2 (floatInwards binds) inline_env spec_data simpl_stats "FloatIn" + ESCC + + CoreDoFullLaziness + -> BSCC("CoreFloating") + case (floatOutwards switch_is_on us1 binds) of { p -> + end_pass us2 p inline_env spec_data simpl_stats "FloatOut" + } ESCC + + CoreDoPrintCore -> + let + printed = ppShow 80 (ppr ppr_style binds) + strict [] a = a + strict (s:ss) a | ord s == 0 = error "0 in output string" + | otherwise = strict ss a + in + end_pass us2 (strict printed (trace ("PrintCore:\n" ++ printed) binds)) inline_env spec_data simpl_stats "Print" + +{- ANDY: + CoreDoHaskPrint -> + let + printed = coreToHaskell binds + strict [] a = a + strict (s:ss) a | ord s == 0 = error "0 in output string" + | otherwise = strict ss a + in + strict printed (trace ("PrintCore:\n" ++ printed) binds), inline_env, spec_data, simpl_stats, "PrintHask" +-} + + CoreDoStaticArgs + -> BSCC("CoreStaticArgs") + end_pass us2 (doStaticArgs binds us1) inline_env spec_data simpl_stats "SAT" + -- Binds really should be dependency-analysed for static- + -- arg transformation... Not to worry, they probably are. + -- (I don't think it *dies* if they aren't [WDP 94/04/15]) + ESCC + + CoreDoStrictness + -> BSCC("CoreStranal") + end_pass us2 (saWwTopBinds us1 switch_is_on binds) inline_env spec_data simpl_stats "StrAnal" + ESCC + + CoreDoSpecialising + -> BSCC("Specialise") + case (specProgram switch_is_on 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 + writeMn stderr (ppShow 1000 {-pprCols-} + (pprSpecErrs PprForUser spec_errs spec_warn spec_tyerrs)) + `thenMn_` writeMn stderr "\n" + else + returnMn ()) `thenMn_` + + (if not spec_noerrs then -- Stop here if specialisation errors occured + exitMn 1 + else + returnMn ()) `thenMn_` + + end_pass us2 p inline_env spec_data2 simpl_stats "Specialise" + } + ESCC + + CoreDoDeforest +#if OMIT_DEFORESTER + -> error "ERROR: CoreDoDeforest: not built into compiler\n" +#else + -> BSCC("Deforestation") + case (deforestProgram sw_chkr binds us1) of { binds -> + end_pass us2 binds inline_env spec_data simpl_stats "Deforestation" + } + ESCC +#endif + + CoreDoAutoCostCentres + -> BSCC("AutoSCCs") + end_pass us2 (addAutoCostCentres sw_chkr module_name binds) inline_env spec_data simpl_stats "AutoSCCs" + ESCC + + ------------------------------------------------- + + end_pass us2 binds2 inline_env2 + spec_data2@(SpecData spec_done _ _ _ _ _ _ _) + simpl_stats2 what + = -- report verbosely, if required + (if do_verbose_core2core then + writeMn stderr ("\n*** "++what++":\n") + `thenMn_` + writeMn stderr (ppShow 1000 + (ppAboves (map (pprPlainCoreBinding ppr_style) binds2))) + `thenMn_` + writeMn stderr "\n" + else + returnMn ()) `thenMn_` + let + linted_binds = core_linter what spec_done binds2 + in + returnMn + (linted_binds, -- processed binds, possibly run thru CoreLint + us2, -- UniqueSupply for the next guy + inline_env2, -- possibly-updated inline env + spec_data2, -- possibly-updated specialisation info + simpl_stats2 -- accumulated simplifier stats + ) + +-- here so it can be inlined... +foldl_mn f z [] = returnMn z +foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> + foldl_mn f zz xs +\end{code} + +--- ToDo: maybe move elsewhere --- + +For top-level, exported binders that either (a)~have been INLINEd by +the programmer or (b)~are sufficiently ``simple'' that they should be +inlined, we want to record this info in a suitable IdEnv. + +But: if something has a ``wrapper unfolding,'' we do NOT automatically +give it a regular unfolding (exception below). We usually assume its +worker will get a ``regular'' unfolding. We can then treat these two +levels of unfolding separately (we tend to be very friendly towards +wrapper unfoldings, for example), giving more fine-tuned control. + +The exception is: If the ``regular unfolding'' mentions no other +global Ids (i.e., it's all PrimOps and cases and local Ids) then we +assume it must be really good and we take it anyway. + +We also need to check that everything in the RHS (values and types) +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 + -> [PlainCoreBinding] + -> IdEnv UnfoldingDetails + +calcInlinings scc_s_OK sw_chkr inline_env_so_far top_binds + = let + result = foldl calci inline_env_so_far top_binds + in + --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result))) + result + where + pp_item (binder, details) + = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details] + where + pp_det NoUnfoldingDetails = ppStr "_N_" + pp_det (IWantToBeINLINEd _) = ppStr "INLINE" + pp_det (GeneralForm _ _ 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) + then trace + else \ msg stuff -> stuff + + (unfolding_creation_threshold, explicit_creation_threshold) + = case (intSwitchSet sw_chkr UnfoldingCreationThreshold) of + Nothing -> (uNFOLDING_CREATION_THRESHOLD, False) + Just xx -> (xx, True) + + unfold_use_threshold + = case (intSwitchSet sw_chkr UnfoldingUseThreshold) of + Nothing -> uNFOLDING_USE_THRESHOLD + Just xx -> xx + + unfold_override_threshold + = case (intSwitchSet sw_chkr UnfoldingOverrideThreshold) of + Nothing -> uNFOLDING_OVERRIDE_THRESHOLD + Just xx -> xx + + con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT + + calci inline_env (CoRec pairs) + = foldl (calc True{-recursive-}) inline_env pairs + + calci inline_env bind@(CoNonRec binder rhs) + = calc False{-not recursive-} inline_env (binder, rhs) + + --------------------------------------- + + calc is_recursive inline_env (binder, rhs) + | not (toplevelishId binder) + = --pprTrace "giving up on not top-level:" (ppr PprDebug binder) + ignominious_defeat + + | rhs_mentions_an_unmentionable + || (not explicit_INLINE_requested + && (guidance_says_don't || guidance_size_just_too_big)) + = let + my_my_trace + = if explicit_INLINE_requested + && not (isWrapperId binder) -- these always claim to be INLINEd + && not have_inlining_already + then trace -- we'd better have a look... + else my_trace + + 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, guidance_says_don't, guidance_size_just_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 + +#if ! OMIT_DEFORESTER + -- For the deforester: bypass the barbed wire for recursive + -- functions that want to be inlined and are tagged deforestable + -- by the user, allowing these things to be communicated + -- across module boundaries. + + | is_recursive && + explicit_INLINE_requested && + deforestable binder && + scc_s_OK -- hack, only get them in + -- calc_inlinings2 + = glorious_success UnfoldAlways +#endif + + | is_recursive && not rhs_looks_like_a_data_val_to_me + -- The only recursive defns we are prepared to tolerate at the + -- moment is top-level very-obviously-a-data-value ones. + -- We *need* these for dictionaries to be exported! + = --pprTrace "giving up on rec:" (ppr PprDebug binder) + ignominious_defeat + + -- Not really interested unless it's exported, but doing it + -- this way (not worrying about export-ness) gets us all the + -- workers/specs, etc., too; which we will need for generating + -- interfaces. We are also not interested if this binder is + -- in the environment we already have (perhaps from a previous + -- run of calcInlinings -- "earlier" is presumed to mean + -- "better"). + + | explicit_INLINE_requested + = glorious_success UnfoldAlways + + | otherwise + = glorious_success guidance + + where + guidance + = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs + where + max_out_threshold = if explicit_INLINE_requested + then 100000 -- you asked for it, you got it + else unfolding_creation_threshold + + guidance_says_don't = case guidance of { UnfoldNever -> True; _ -> False } + + guidance_size + = case guidance of + UnfoldAlways -> 0 -- *extremely* small + EssentialUnfolding -> 0 -- ditto + UnfoldIfGoodArgs _ _ _ size -> size + + guidance_size_just_too_big + -- Does the guidance suggest that this unfolding will + -- be of no use *no matter* the arguments given to it? + -- Could be more sophisticated... + = case guidance of + UnfoldNever -> False -- debugging only (ToDo:rm) + UnfoldAlways -> False + EssentialUnfolding -> False + UnfoldIfGoodArgs _ no_val_args arg_info_vec size + + -> if explicit_creation_threshold then + False -- user set threshold; don't second-guess... + + else if no_val_args == 0 && rhs_looks_like_a_data_val_to_me then + False -- probably a data value; we'd like the + -- other guy to see the value, even if + -- s/he doesn't unfold it. + else + let + cost + = leastItCouldCost con_discount_weight size no_val_args + arg_info_vec rhs_arg_tys + in +-- (if (unfold_use_threshold < cost) then (pprTrace "cost:" (ppInt cost)) else \x->x ) ( + unfold_use_threshold < cost +-- ) + + + rhs_arg_tys + = let + (_, val_binders, _) = digForLambdas rhs + in + map getIdUniType val_binders + + rhs_looks_like_a_data_val_to_me + = let + (_,val_binders,body) = digForLambdas rhs + in + case (val_binders, body) of + ([], CoCon _ _ _) -> True + other -> False + + (mentioned_ids, _, _, mentions_litlit) + = 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 + || mentions_litlit + --) + -- ToDo: probably need to chk tycons/classes... + + mentions_no_other_ids = null mentioned_ids + + explicit_INLINE_requested + -- did it come from a user {-# INLINE ... #-}? + -- (Warning: must avoid including wrappers.) + = idWantsToBeINLINEd binder + && not (rhs `isWrapperFor` binder) + + have_inlining_already = maybeToBool (lookupIdEnv inline_env binder) + + ignominious_defeat = inline_env -- just give back what we got + + {- + "glorious_success" is ours if we've found a suitable unfolding. + + But we check for a couple of fine points. + + (1) If this Id already has an inlining in the inline_env, + we don't automatically take it -- the earlier one is + "likely" to be better. + + But if the new one doesn't mention any other global + Ids, and it's pretty small (< UnfoldingOverrideThreshold), + then we take the chance that the new one *is* better. + + (2) If we have an Id w/ a worker/wrapper split (with + an unfolding for the wrapper), we tend to want to keep + it -- and *nuke* any inlining that we conjured up + earlier. + + But, again, if this unfolding doesn't mention any + other global Ids (and small enough), then it is + probably better than the worker/wrappery, so we take + it. + -} + glorious_success guidance + = let + new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs) + + foldr_building = switch_is_on FoldrBuildOn + in + if (not have_inlining_already) then + -- Not in env: we take it no matter what + -- NB: we could check for worker/wrapper-ness, + -- but the truth is we probably haven't run + -- the strictness analyser yet. + new_env + + else if explicit_INLINE_requested then + -- If it was a user INLINE, then we know it's already + -- in the inline_env; we stick with what we already + -- have. + --pprTrace "giving up on INLINE:" (ppr PprDebug binder) + ignominious_defeat + + else if isWrapperId binder then + -- It's in the env, but we have since worker-wrapperised; + -- we either take this new one (because it's so good), + -- or we *undo* the one in the inline_env, so the + -- wrapper-inlining will take over. + + if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then + new_env + else + delOneFromIdEnv inline_env binder + + else + -- It's in the env, nothing to do w/ worker wrapper; + -- we'll take it if it is better. + + if not foldr_building -- ANDY hates us... (see below) + && mentions_no_other_ids + && guidance_size <= unfold_override_threshold then + new_env + else + --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold]) + ignominious_defeat -- and at the last hurdle, too! +\end{code} + +ANDY, on the hatred of the check above; why obliterate it? Consider + + head xs = foldr (\ x _ -> x) (_|_) xs + +This then is exported via a pragma. However, +*if* you include the extra code above, you will +export the non-foldr/build version. diff --git a/ghc/compiler/simplCore/SimplEnv.hi b/ghc/compiler/simplCore/SimplEnv.hi new file mode 100644 index 0000000..f97c5ba --- /dev/null +++ b/ghc/compiler/simplCore/SimplEnv.hi @@ -0,0 +1,163 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplEnv where +import BasicLit(BasicLit) +import BinderInfo(BinderInfo(..), DuplicationDanger, FunOrArg, InsideSCC) +import Class(Class) +import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult) +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr) +import CostCentre(CostCentre) +import FiniteMap(FiniteMap) +import Id(Id, IdDetails, applyTypeEnvToId) +import IdEnv(IdEnv(..), lookupIdEnv) +import IdInfo(IdInfo, StrictnessInfo) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda) +import NameTypes(ShortName) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TyVarEnv(..), nullTyVarEnv) +import UniTyFuns(applyTypeEnvToTy) +import UniType(UniType) +import UniqFM(UniqFM, emptyUFM, lookupUFM) +import Unique(Unique) +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int +data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-} +data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-} +data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data EnclosingCcDetails = NoEnclosingCcDetails | EnclosingCC CostCentre +data FormSummary = WhnfForm | BottomForm | OtherForm +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data IdVal = InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id) +type InAlts = CoreCaseAlternatives (Id, BinderInfo) Id +type InArg = CoreArg Id +type InAtom = CoreAtom Id +type InBinder = (Id, BinderInfo) +type InBinding = CoreBinding (Id, BinderInfo) Id +type InDefault = CoreCaseDefault (Id, BinderInfo) Id +type InExpr = CoreExpr (Id, BinderInfo) Id +type InId = Id +type InIdEnv = UniqFM IdVal +type InType = UniType +type InTypeEnv = UniqFM UniType +type InUniType = UniType +data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type OutAlts = CoreCaseAlternatives Id Id +type OutArg = CoreArg Id +type OutAtom = CoreAtom Id +type OutBinder = Id +type OutBinding = CoreBinding Id Id +type OutDefault = CoreCaseDefault Id Id +type OutExpr = CoreExpr Id Id +type OutId = Id +type OutType = UniType +type OutUniType = UniType +data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-} +type SwitchChecker a = a -> SwitchResult +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +type TyVarEnv a = UniqFM a +data UnfoldConApp {-# GHC_PRAGMA UCA Id [UniType] [CoreAtom Id] #-} +data UnfoldEnv {-# GHC_PRAGMA UFE (UniqFM UnfoldItem) (UniqFM Id) (FiniteMap UnfoldConApp Id) #-} +data UnfoldItem {-# GHC_PRAGMA UnfoldItem Id UnfoldingDetails EnclosingCcDetails #-} +data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance +data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +applyTypeEnvToId :: UniqFM UniType -> Id -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +applyTypeEnvToTy :: UniqFM UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +extendIdEnvWithAtom :: SimplEnv -> (Id, BinderInfo) -> CoreAtom Id -> SimplEnv + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(LLLLL)U(LL)S" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +extendIdEnvWithAtomList :: SimplEnv -> [((Id, BinderInfo), CoreAtom Id)] -> SimplEnv + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +extendIdEnvWithClone :: SimplEnv -> (Id, BinderInfo) -> Id -> SimplEnv + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(LLLLL)U(LA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +extendIdEnvWithClones :: SimplEnv -> [(Id, BinderInfo)] -> [Id] -> SimplEnv + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "U(LLLLL)LL" _N_ _N_ #-} +extendIdEnvWithInlining :: SimplEnv -> SimplEnv -> (Id, BinderInfo) -> CoreExpr (Id, BinderInfo) Id -> SimplEnv + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "U(LLLLL)LU(LA)L" {_A_ 4 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(LLLLL)LL" _N_ _N_ #-} +extendTyEnvList :: SimplEnv -> [(TyVar, UniType)] -> SimplEnv + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLLL)L" _N_ _N_ #-} +extendUnfoldEnvGivenConstructor :: SimplEnv -> Id -> Id -> [Id] -> SimplEnv + {-# GHC_PRAGMA _A_ 4 _U_ 1221 _N_ _S_ "U(LLLLL)LLL" _N_ _N_ #-} +extendUnfoldEnvGivenFormDetails :: SimplEnv -> Id -> UnfoldingDetails -> SimplEnv + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(LLLLL)LS" _N_ _N_ #-} +extendUnfoldEnvGivenRhs :: SimplEnv -> (Id, BinderInfo) -> Id -> CoreExpr Id Id -> SimplEnv + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "U(LLLLL)U(AL)LL" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLLA)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSwitchChecker :: SimplEnv -> SimplifierSwitch -> SwitchResult + {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(SAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SimplifierSwitch -> SwitchResult) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: SimplEnv) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u1 :: SimplifierSwitch -> SwitchResult) (u2 :: EnclosingCcDetails) (u3 :: UniqFM UniType) (u4 :: UniqFM IdVal) (u5 :: UnfoldEnv) -> u1; _NO_DEFLT_ } _N_ #-} +lookForConstructor :: SimplEnv -> Id -> [UniType] -> [CoreAtom Id] -> Labda Id + {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAU(AAL))LLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupId :: SimplEnv -> Id -> Labda IdVal + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAASA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupIdEnv :: UniqFM a -> Id -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAL)U(LALS)" {_A_ 4 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkFormSummary :: StrictnessInfo -> CoreExpr a Id -> FormSummary + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-} +nullInEnvs :: (UniqFM UniType, UniqFM IdVal) + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +nullSimplEnv :: (SimplifierSwitch -> SwitchResult) -> SimplEnv + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +nullTyVarEnv :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +pprSimplEnv :: SimplEnv -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(AAAAU(LAA))" {_A_ 1 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +replaceInEnvs :: SimplEnv -> (UniqFM UniType, UniqFM IdVal) -> SimplEnv + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLAAL)U(LL)" {_A_ 5 _U_ 22222 _N_ _N_ _F_ _IF_ARGS_ 0 5 XXXXX 6 \ (u0 :: SimplifierSwitch -> SwitchResult) (u1 :: EnclosingCcDetails) (u2 :: UnfoldEnv) (u3 :: UniqFM UniType) (u4 :: UniqFM IdVal) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u0, u1, u3, u4, u2] _N_} _F_ _ALWAYS_ \ (u0 :: SimplEnv) (u1 :: (UniqFM UniType, UniqFM IdVal)) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> case u1 of { _ALG_ _TUP_2 (u7 :: UniqFM UniType) (u8 :: UniqFM IdVal) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u2, u3, u7, u8, u6]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LALLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _F_ _IF_ARGS_ 0 5 XXXXX 6 \ (u0 :: SimplifierSwitch -> SwitchResult) (u1 :: UniqFM UniType) (u2 :: UniqFM IdVal) (u3 :: UnfoldEnv) (u4 :: EnclosingCcDetails) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u0, u4, u1, u2, u3] _N_} _F_ _ALWAYS_ \ (u0 :: SimplEnv) (u1 :: EnclosingCcDetails) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u2, u1, u4, u5, u6]; _NO_DEFLT_ } _N_ #-} +simplTy :: SimplEnv -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AALAA)S" {_A_ 2 _U_ 21 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns applyTypeEnvToTy _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: SimplEnv) (u1 :: UniType) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> _APP_ _ORIG_ UniTyFuns applyTypeEnvToTy [ u4, u1 ]; _NO_DEFLT_ } _N_ #-} +simplTyInId :: SimplEnv -> Id -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AALAA)U(LLLS)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(SAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ CmdLineOpts switchIsOn { SimplifierSwitch } _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: SimplEnv) (u1 :: SimplifierSwitch) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> _APP_ _TYAPP_ _ORIG_ CmdLineOpts switchIsOn { SimplifierSwitch } [ u2, u1 ]; _NO_DEFLT_ } _N_ #-} +instance Eq UnfoldConApp + {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool)] [_CONSTM_ Eq (==) (UnfoldConApp), _CONSTM_ Eq (/=) (UnfoldConApp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord UnfoldConApp + {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq UnfoldConApp}}, (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> UnfoldConApp), (UnfoldConApp -> UnfoldConApp -> UnfoldConApp), (UnfoldConApp -> UnfoldConApp -> _CMP_TAG)] [_DFUN_ Eq (UnfoldConApp), _CONSTM_ Ord (<) (UnfoldConApp), _CONSTM_ Ord (<=) (UnfoldConApp), _CONSTM_ Ord (>=) (UnfoldConApp), _CONSTM_ Ord (>) (UnfoldConApp), _CONSTM_ Ord max (UnfoldConApp), _CONSTM_ Ord min (UnfoldConApp), _CONSTM_ Ord _tagCmp (UnfoldConApp)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable FormSummary + {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FormSummary) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable UnfoldingGuidance + {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (UnfoldingGuidance) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs new file mode 100644 index 0000000..c06e976 --- /dev/null +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -0,0 +1,1056 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplEnv]{Environment stuff for the simplifier} + +\begin{code} +#include "HsVersions.h" + +module SimplEnv ( + nullSimplEnv, + pprSimplEnv, -- debugging only + +--UNUSED: getInEnvs, + replaceInEnvs, nullInEnvs, + + nullTyVarEnv, + extendTyEnv, extendTyEnvList, + simplTy, simplTyInId, + + extendIdEnvWithAtom, extendIdEnvWithAtomList, + extendIdEnvWithInlining, + extendIdEnvWithClone, extendIdEnvWithClones, + lookupId, + + extendUnfoldEnvGivenRhs, +--OLD: extendUnfoldEnvWithRecInlinings, + extendUnfoldEnvGivenFormDetails, + extendUnfoldEnvGivenConstructor, + lookForConstructor, + lookupUnfolding, filterUnfoldEnvForInlines, + + getSwitchChecker, switchIsSet, + +--UNUSED: getEnclosingCC, + setEnclosingCC, + + mkFormSummary, + + -- Types + SwitchChecker(..), + SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..), + FormSummary(..), EnclosingCcDetails(..), + InIdEnv(..), IdVal(..), InTypeEnv(..), + UnfoldEnv, UnfoldItem, UnfoldConApp, + + -- re-exported from BinderInfo + BinderInfo(..), + FunOrArg, DuplicationDanger, InsideSCC, -- sigh + + InId(..), InBinder(..), InType(..), InBinding(..), InUniType(..), + OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..), + + InExpr(..), InAtom(..), InAlts(..), InDefault(..), InArg(..), + OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..), + + -- and to make the interface self-sufficient... + BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom, + CoreCaseAlternatives, CoreExpr, Id, + IdEnv(..), UniqFM, Unique, + MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType + + IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId) + IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling + ) where + +IMPORT_Trace + +import AbsPrel ( buildId ) +import AbsUniType ( applyTypeEnvToTy, getUniDataTyCon, cmpUniType ) +import Bag ( emptyBag, Bag ) +import BasicLit ( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only +import BinderInfo +import CmdLineOpts ( switchIsOn, intSwitchSet, + SimplifierSwitch(..), SwitchResult + ) +import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) +import CostCentre +import FiniteMap +import Id ( getIdUnfolding, eqId, cmpId, applyTypeEnvToId, + getIdUniType, getIdStrictness, isWorkerId, + isBottomingId + ) +import IdEnv +import IdInfo +import MagicUFs +import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) +import OccurAnal ( occurAnalyseExpr ) +import PlainCore -- for the "Out*" types and things +import Pretty -- debugging only +import SimplUtils ( simplIdWantsToBeINLINEd ) +import TaggedCore -- for the "In*" types and things +import TyVarEnv +import UniqFM ( lookupDirectlyUFM, addToUFM_Directly, ufmToList ) +import UniqSet +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Simplify-types]{Type declarations} +%* * +%************************************************************************ + + +%************************************************************************ +%* * +\subsubsection{The @SimplEnv@ type} +%* * +%************************************************************************ + + +INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT +this? WDP 94/06) This allows us to neglect keeping everything paired +with its static environment. + +The environment contains bindings for all + {\em in-scope,} + {\em locally-defined} +things. + +For such things, any unfolding is found in the environment, not in the +Id. Unfoldings in the Id itself are used only for imported things +(otherwise we get trouble because we have to simplify the unfoldings +inside the Ids, etc.). + +\begin{code} +data SimplEnv + = SimplEnv + (SwitchChecker SimplifierSwitch) + + EnclosingCcDetails -- the enclosing cost-centre (when profiling) + + InTypeEnv -- For cloning types + -- Domain is all in-scope type variables + + InIdEnv -- IdEnv + -- Domain is + -- *all* + -- *in-scope*, + -- *locally-defined* + -- *InIds* + -- (Could omit the exported top-level guys, + -- since their names mustn't change; and ditto + -- the non-exported top-level guys which you + -- don't want to macro-expand, since their + -- names need not change.) + -- + -- Starts off empty + + UnfoldEnv -- Domain is any *OutIds*, including imports + -- where we know something more than the + -- interface file tells about their value (see + -- below) + +nullSimplEnv :: SwitchChecker SimplifierSwitch -> SimplEnv + +nullSimplEnv sw_chkr + = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env + +pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _)) + = ppAboves [ + ppStr "** Type Env ** ????????", -- ppr PprDebug ty_env, + ppSP, ppStr "** Id Env ** ?????????", +-- ppAboves [ pp_id_entry x | x <- getIdEnvMapping id_env ], + ppSP, ppStr "** Unfold Env **", + ppAboves [ pp_uf_entry x | x <- rngIdEnv unfold_env ] + ] + where + pp_id_entry (v, idval) + = ppCat [ppr PprDebug v, ppStr "=>", + case idval of + InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e] + ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a] + ] + + pp_uf_entry (UnfoldItem v form encl_cc) + = ppCat [ppr PprDebug v, ppStr "=>", + case form of + NoUnfoldingDetails -> ppStr "NoUnfoldingDetails" + LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] + OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]] + ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] + OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") + [ppr PprDebug c | c <- cs]] + GeneralForm t w e g -> ppCat [ppStr "UF:", + ppr PprDebug t, + ppr PprDebug w, + ppr PprDebug g, ppr PprDebug e] + MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s] + IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd" + ] +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @IdVal@ type (for the ``IdEnv'')} +%* * +%************************************************************************ + +The unfoldings for imported things are mostly kept within the Id +itself; nevertheless, they {\em can} get into the @UnfoldEnv@. For +example, suppose \tr{x} is imported, and we have +\begin{verbatim} + case x of + (p,q) -> +\end{verbatim} +Then within \tr{}, we know that \tr{x} is a pair with components +\tr{p} and \tr{q}. + +\begin{code} +type InIdEnv = IdEnv IdVal -- Maps InIds to their value + +data IdVal + = InlineIt InIdEnv InTypeEnv InExpr + -- No binding of the Id is left; + -- You *have* to replace any occurences + -- of the id with this expression. + -- Rather like a macro, really + -- NB: the InIdEnv/InTypeEnv is necessary to prevent + -- name caputure. Consider: + -- let y = ... + -- x = ...y... + -- y = ... + -- in ...x... + -- If x gets an InlineIt, we must remember + -- the correct binding for y. + + | ItsAnAtom OutAtom -- Used either (a) to record the cloned Id + -- or (b) if the orig defn is a let-binding, and + -- the RHS of the let simplifies to an atom, + -- we just bind the variable to that atom, and + -- elide the let. +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UnfoldEnv@, @UnfoldingDetails@, and @UnfoldingGuidance@ types} +%* * +%************************************************************************ + +The @UnfoldEnv@ contains information about the value of some of the +in-scope identifiers. It obeys the following invariant: + + If the @UnfoldEnv@ contains information, it is safe to use it! + +In particular, if the @UnfoldEnv@ contains details of an unfolding of +an Id, then it's safe to use the unfolding. If, for example, the Id +is used many times, then its unfolding won't be put in the UnfoldEnv +at all. + +The @UnfoldEnv@ (used to be [WDP 94/06]) a simple association list +because (a)~it's small, and (b)~we need to search its {\em range} as +well as its domain. + +\begin{code} +data UnfoldItem -- a glorified triple... + = UnfoldItem OutId -- key: used in lookForConstructor + UnfoldingDetails -- for that Id + EnclosingCcDetails -- so that if we do an unfolding, + -- we can "wrap" it in the CC + -- that was in force. + +data UnfoldConApp -- yet another glorified triple + = UCA OutId -- same fields as ConstructorForm; + [UniType] -- a new type so we can make + [OutAtom] -- Ord work on it (instead of on + -- UnfoldingDetails). + +data UnfoldEnv -- yup, a glorified triple... + = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem + IdSet -- The Ids in the domain of the env + -- which have details (GeneralForm True ...) + -- i.e., they claim they are duplicatable. + -- These are the ones we have to worry + -- about when adding new items to the + -- unfold env. + (FiniteMap UnfoldConApp OutId) + -- Maps applications of constructors (to + -- types & atoms) back to OutIds that are + -- bound to them; i.e., this is a reversed + -- mapping for (part of) the main IdEnv + -- (1st part of UFE) + +null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM +\end{code} + +The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will +be small, because it contains bindings only for those things whose +form or unfolding is known. Basically it maps @Id@ to their +@UnfoldingDetails@ (and @EnclosingCcDetails@---boring...), but we also +need to search it associatively, to look for @Id@s which have a given +constructor form. + +We implement it with @IdEnvs@, possibly overkill, but sometimes these +things silently grow quite big.... Here are some local functions used +elsewhere in the module: + +\begin{code} +grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv +lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails +lookup_unfold_env_encl_cc + :: UnfoldEnv -> OutId -> EnclosingCcDetails + +grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env + +grow_unfold_env (UFE u_env interesting_ids con_apps) id + uf_details@(GeneralForm True _ _ _) encl_cc + -- Only interested in Ids which have a "dangerous" unfolding; that is + -- one that claims to have a single occurrence. + = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) + (interesting_ids `unionUniqSets` singletonUniqSet id) + con_apps + +grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc + = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) + interesting_ids + new_con_apps + where + new_con_apps + = case uf_details of + ConstructorForm con targs vargs + -> case (lookupFM con_apps entry) of + Just _ -> con_apps -- unchanged; we hang onto what we have + Nothing -> addToFM con_apps entry id + where + entry = UCA con targs vargs + + not_a_constructor -> con_apps -- unchanged + +addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items + = ASSERT(not (any constructor_form_in_those extra_items)) + -- otherwise, we'd need to change con_apps + UFE (growIdEnvList u_env extra_items) interesting_ids con_apps + where + constructor_form_in_those (_, UnfoldItem _ (ConstructorForm _ _ _) _) = True + constructor_form_in_those _ = False + +rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env + +get_interesting_ids (UFE _ interesting_ids _) = interesting_ids + +foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff + = UFE (foldr fun u_env stuff) interesting_ids con_apps + +lookup_unfold_env (UFE u_env _ _) id + = case (lookupIdEnv u_env id) of + Nothing -> NoUnfoldingDetails + Just (UnfoldItem _ uf _) -> uf + +lookup_unfold_env_encl_cc (UFE u_env _ _) id + = case (lookupIdEnv u_env id) of + Nothing -> NoEnclosingCcDetails + Just (UnfoldItem _ _ encl_cc) -> encl_cc + +lookup_conapp (UFE _ _ con_apps) con ty_args con_args + = lookupFM con_apps (UCA con ty_args con_args) + +modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id + = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps + +-- If the current binding claims to be a "unique" one, then +-- we modify it. +modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem + +modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) + = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc +\end{code} + +The main thing about @UnfoldConApp@ is that it has @Ord@ defined on +it, so we can use it for a @FiniteMap@ key. +\begin{code} +instance Eq UnfoldConApp where + a == b = case cmp_app a b of { EQ_ -> True; _ -> False } + a /= b = case cmp_app a b of { EQ_ -> False; _ -> True } + +instance Ord UnfoldConApp where + a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif + +cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2) + = case cmpId c1 c2 of + LT_ -> LT_ + GT_ -> GT_ + _ -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of + LT_ -> LT_ + GT_ -> GT_ + _ -> cmp_lists cmp_atom as1 as2 + where + cmp_lists cmp_item [] [] = EQ_ + cmp_lists cmp_item (x:xs) [] = GT_ + cmp_lists cmp_item [] (y:ys) = LT_ + cmp_lists cmp_item (x:xs) (y:ys) + = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other } + + cmp_atom (CoVarAtom x) (CoVarAtom y) = x `cmpId` y + cmp_atom (CoVarAtom _) _ = LT_ + cmp_atom (CoLitAtom x) (CoLitAtom y) +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } +#else + = if x == y then EQ_ elsid if x < y then LT_ else GT_ +#endif + cmp_atom (CoLitAtom _) _ = GT_ +\end{code} + +\begin{code} +data UnfoldingDetails + = NoUnfoldingDetails + + | LiteralForm + BasicLit + + | OtherLiteralForm + [BasicLit] -- It is a literal, but definitely not one of these + + | ConstructorForm + Id -- The constructor + [UniType] -- Type args + [OutAtom] -- Value arguments; NB OutAtoms, already cloned + + | OtherConstructorForm + [Id] -- It definitely isn't one of these constructors + -- This captures the situation in the default branch of + -- a case: case x of + -- c1 ... -> ... + -- c2 ... -> ... + -- v -> default-rhs + -- Then in default-rhs we know that v isn't c1 or c2. + -- + -- NB. In the degenerate: case x of {v -> default-rhs} + -- x will be bound to + -- OtherConstructorForm [] + -- which captures the idea that x is eval'd but we don't + -- know which constructor. + + + | GeneralForm + Bool -- True <=> At most one textual occurrence of the + -- binder in its scope, *or* + -- if we are happy to duplicate this + -- binding. + FormSummary -- Tells whether the template is a WHNF or bottom + TemplateOutExpr -- The template + UnfoldingGuidance -- Tells about the *size* of the template. + + | MagicForm + FAST_STRING + MagicUnfoldingFun + + {-OLD? Nukable? ("Also turgid" SLPJ)-} + | IWantToBeINLINEd -- Means this has an INLINE pragma; + -- Used for things which have a defn in this module + UnfoldingGuidance -- Guidance from the pragma; usually UnfoldAlways. + +data FormSummary + = WhnfForm -- Expression is WHNF + | BottomForm -- Expression is guaranteed to be bottom. We're more gung + -- ho about inlining such things, because it can't waste work + | OtherForm -- Anything else + +instance Outputable FormSummary where + ppr sty WhnfForm = ppStr "WHNF" + ppr sty BottomForm = ppStr "Bot" + ppr sty OtherForm = ppStr "Other" + +mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary +mkFormSummary si expr + | manifestlyWHNF expr = WhnfForm + | bottomIsGuaranteed si = BottomForm + + -- Chances are that the Id will be decorated with strictness info + -- telling that the RHS is definitely bottom. This *might* not be the + -- case, if it's been a while since strictness analysis, but leaving out + -- the test for manifestlyBottom makes things a little more efficient. + -- We can always put it back... + -- | manifestlyBottom expr = BottomForm + + | otherwise = OtherForm +\end{code} + +\begin{code} +data UnfoldingGuidance + = UnfoldNever -- Don't do it! + + | UnfoldAlways -- There is no "original" definition, + -- so you'd better unfold. Or: something + -- so cheap to unfold (e.g., 1#) that + -- you should do it absolutely always. + + | EssentialUnfolding -- Like UnfoldAlways, but you *must* do + -- it absolutely always. + -- This is what we use for data constructors + -- and PrimOps, because we don't feel like + -- generating curried versions "just in case". + + | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and + Int -- those val args are manifestly data constructors + [Bool] -- the val-arg positions marked True + -- (i.e., a simplification will definitely + -- be possible). + Int -- The "size" of the unfolding; to be elaborated + -- later. ToDo +\end{code} + +\begin{code} +instance Outputable UnfoldingGuidance where + ppr sty UnfoldNever = ppStr "_N_" + ppr sty UnfoldAlways = ppStr "_ALWAYS_" + ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface + ppr sty (UnfoldIfGoodArgs t v cs size) + = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v, + if null cs -- always print *something* + then ppChar 'X' + else ppBesides (map pp_c cs), + ppInt size ] + where + pp_c False = ppChar 'X' + pp_c True = ppChar 'C' +\end{code} + +%************************************************************************ +%* * +\subsection{@mkGenForm@ and @modifyUnfoldingDetails@} +%* * +%************************************************************************ + +\begin{code} +mkGenForm :: Bool -- Ok to Dup code down different case branches, + -- because of either a flag saying so, + -- or alternatively the object is *SMALL* + -> BinderInfo -- + -> FormSummary + -> TemplateOutExpr -- Template + -> UnfoldingGuidance -- Tells about the *size* of the template. + -> UnfoldingDetails + +mkGenForm safe_to_dup occ_info WhnfForm template guidance + = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance + +mkGenForm safe_to_dup occ_info form_summary template guidance + | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences + = GeneralForm True form_summary template guidance + + | otherwise -- Not a WHNF, many occurrences + = NoUnfoldingDetails +\end{code} + +\begin{code} +modifyUnfoldingDetails + :: Bool -- OK to dup + -> BinderInfo -- New occurrence info for the thing + -> UnfoldingDetails + -> UnfoldingDetails + +modifyUnfoldingDetails ok_to_dup occ_info + (GeneralForm only_one form_summary template guidance) + | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance + +{- OLD: + | otherwise = NoUnfoldingDetails + I can't see why we zap bindings which don't claim to be unique +-} + +modifyUnfoldingDetails ok_to_dup occ_info other = other +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @EnclosingCcDetails@ type} +%* * +%************************************************************************ + +\begin{code} +data EnclosingCcDetails + = NoEnclosingCcDetails + | EnclosingCC CostCentre +\end{code} + +%************************************************************************ +%* * +\subsubsection{The ``InXXX'' and ``OutXXX'' type synonyms} +%* * +%************************************************************************ + +\begin{code} +type InId = Id -- Not yet cloned +type InBinder = (InId, BinderInfo) +type InType = UniType -- Ditto +type InBinding = SimplifiableCoreBinding +type InExpr = SimplifiableCoreExpr +type InAtom = SimplifiableCoreAtom -- same as PlainCoreAtom +type InAlts = SimplifiableCoreCaseAlternatives +type InDefault = SimplifiableCoreCaseDefault +type InArg = CoreArg InId +type InUniType = UniType + +type OutId = Id -- Cloned +type OutBinder = Id +type OutType = UniType -- Cloned +type OutBinding = PlainCoreBinding +type OutExpr = PlainCoreExpr +type OutAtom = PlainCoreAtom +type OutAlts = PlainCoreCaseAlternatives +type OutDefault = PlainCoreCaseDefault +type OutArg = CoreArg OutId +type OutUniType = UniType + +type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId + -- An OutExpr with occurrence info attached + -- This is used as a template in GeneralForms. +\end{code} + +\begin{code} +type SwitchChecker switch = switch -> SwitchResult +\end{code} + +%************************************************************************ +%* * +\subsection{@SimplEnv@ handling} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection{Command-line switches} +%* * +%************************************************************************ + +\begin{code} +getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch +getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr + +switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool +switchIsSet (SimplEnv chkr _ _ _ _) switch + = switchIsOn chkr switch +\end{code} + +%************************************************************************ +%* * +\subsubsection{The ``enclosing cost-centre''} +%* * +%************************************************************************ + +\begin{code} +-- UNUSED: +--getEnclosingCC :: SimplEnv -> EnclosingCcDetails +--getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc + +setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv + +setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc + = SimplEnv chkr encl_cc ty_env id_env unfold_env +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @TypeEnv@ part} +%* * +%************************************************************************ + +\begin{code} +type InTypeEnv = TypeEnv -- Maps InTyVars to OutUniTypes + +extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv +extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty + = SimplEnv chkr encl_cc new_ty_env id_env unfold_env + where + new_ty_env = addOneToTyVarEnv ty_env tyvar ty + +extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv +extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs + = SimplEnv chkr encl_cc new_ty_env id_env unfold_env + where + 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} + +@replaceInEnvs@ is used to install saved type and id envs +when pulling an un-simplified expression out of the environment, which +was saved with its environments. + +\begin{code} +nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv) + +-- UNUSED: +--getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) +--getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env) + +replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv +replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) + (new_ty_env, new_id_env) + = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env +\end{code} + +%************************************************************************ +%* * +\subsubsection{The ``Id env'' part} +%* * +%************************************************************************ + +\begin{code} +extendIdEnvWithAtom + :: SimplEnv + -> InBinder -> OutAtom + -> SimplEnv + +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit) + = SimplEnv chkr encl_cc ty_env new_id_env unfold_env + where + new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) + +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) + (in_id, occ_info) atom@(CoVarAtom out_id) + = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env + where + new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) + + new_unfold_env = modify_unfold_env + unfold_env + (modifyItem ok_to_dup occ_info) + out_id + -- Modify binding for in_id + -- NO! modify out_id, because its the info on the + -- atom that interest's us. + + ok_to_dup = switchIsOn chkr SimplOkToDupCode + +extendIdEnvWithAtomList + :: SimplEnv + -> [(InBinder, OutAtom)] + -> SimplEnv +extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) + +extendIdEnvWithInlining + :: SimplEnv -- The Env to modify + -> SimplEnv -- The Env to record in the inlining. Usually the + -- same as the previous one, except in the recursive case + -> InBinder -> InExpr + -> SimplEnv + +extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env) + ~(SimplEnv _ _ inline_ty_env inline_id_env _ ) + (in_id,occ_info) + expr + = SimplEnv chkr encl_cc ty_env new_id_env unfold_env + where + new_id_env = addOneToIdEnv id_env in_id (InlineIt inline_id_env inline_ty_env expr) + +extendIdEnvWithClone + :: SimplEnv + -> InBinder -- Old binder; binderinfo ignored + -> OutId -- Its new clone, as an Id + -> SimplEnv + +extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env) + (in_id,_) out_id + = SimplEnv chkr encl_cc ty_env new_id_env unfold_env + where + new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id)) + +extendIdEnvWithClones -- Like extendIdEnvWithClone + :: SimplEnv + -> [InBinder] + -> [OutId] + -> SimplEnv + +extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env) + in_binders out_ids + = SimplEnv chkr encl_cc ty_env new_id_env unfold_env + where + new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals) + in_ids = [id | (id,_) <- in_binders] + out_vals = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids] + +lookupId :: SimplEnv -> Id -> Maybe IdVal + +lookupId (SimplEnv _ _ _ id_env _) id +#ifndef DEBUG + = lookupIdEnv id_env id +#else + = case (lookupIdEnv id_env id) of + xxx@(Just _) -> xxx + xxx -> --false!: ASSERT(not (isLocallyDefined id)) + xxx +#endif +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UnfoldEnv@} +%* * +%************************************************************************ + +\begin{code} +extendUnfoldEnvGivenFormDetails + :: SimplEnv + -> OutId + -> UnfoldingDetails + -> SimplEnv + +extendUnfoldEnvGivenFormDetails + env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) + id details + = case details of + NoUnfoldingDetails -> env + good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env + where + new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc + +extendUnfoldEnvGivenConstructor -- specialised variant + :: SimplEnv + -> OutId -- bind this to... + -> Id -> [OutId] -- "con args" + -> SimplEnv + +extendUnfoldEnvGivenConstructor env var con args + = let + -- conjure up the types to which the con should be applied + scrut_ty = getIdUniType var + (_, ty_args, _) = getUniDataTyCon scrut_ty + in + extendUnfoldEnvGivenFormDetails + env var (ConstructorForm con ty_args (map CoVarAtom args)) +\end{code} + + +@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS +of a new binding. There is a horrid case we have to take care about, +due to Andr\'e Santos: +@ + type Array_type b = Array Int b; + type Descr_type = (Int,Int); + + tabulate :: (Int -> x) -> Descr_type -> Array_type x; + tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]]; + + f_iaamain a_xs= + let { + f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; + f_aareorder a_index a_ar= + let { + f_aareorder' a_i= a_ar ! (a_index ! a_i) + } in tabulate f_aareorder' (bounds a_ar); + r_index=tabulate ((+) 1) (1,1); + arr = listArray (1,1) a_xs; + arg = f_aareorder r_index arr + } in elems arg +@ +Now, when the RHS of arg gets simplified, we inline f_aareorder to get +@ + arg = let f_aareorder' a_i = arr ! (r_index ! a_i) + in tabulate f_aareorder' (bounds arr) +@ +Note that r_index is not inlined, because it was bound to a_index which +occurs inside a lambda. + +Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...), +then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence +analyse it, we won't spot the inside-lambda property of r_index, so r_index +will get inlined inside the lambda. AARGH. + +Solution: when we occurrence-analyse the new RHS we have to go back +and modify the info recorded in the UnfoldEnv for the free vars +of the RHS. In the example we'd go back and record that r_index is now used +inside a lambda. + +\begin{code} +extendUnfoldEnvGivenRhs + :: SimplEnv + -> InBinder + -> OutId -- Note: *must* be an "out" Id (post-cloning) + -> OutExpr -- Its rhs (*simplified*) + -> SimplEnv + +extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) + binder@(_,occ_info) out_id rhs + = SimplEnv chkr encl_cc ty_env id_env new_unfold_env + where + -- Occurrence-analyse the RHS + (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs + + interesting_fvs = get_interesting_ids unfold_env + + -- Compute unfolding details + details = case rhs of + CoVar v -> panic "CoVars already dealt with" + CoLit lit | isNoRepLit lit -> LiteralForm lit + | otherwise -> panic "non-noRep CoLits already dealt with" + + CoCon con tys args -> ConstructorForm con tys args + + other -> mkGenForm ok_to_dup occ_info + (mkFormSummary (getIdStrictness out_id) rhs) + template guidance + + -- Compute resulting unfold env + new_unfold_env = case details of + NoUnfoldingDetails -> unfold_env + GeneralForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} + other -> unfold_env1 + + -- Add unfolding to unfold env + unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc + + -- Modify unfoldings of free vars of rhs, based on their + -- occurrence info in the rhs [see notes above] + unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info) + + modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem + modify (u, occ_info) env + = case (lookupDirectlyUFM env u) of + Nothing -> env -- ToDo: can this happen? + Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) + + -- Compute unfolding guidance + guidance = if simplIdWantsToBeINLINEd out_id env + then UnfoldAlways + else calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs + + bOMB_OUT_SIZE = case (intSwitchSet chkr SimplUnfoldingCreationThreshold) of + Nothing -> uNFOLDING_CREATION_THRESHOLD + Just xx -> xx + + ok_to_dup = switchIsOn chkr SimplOkToDupCode + || exprSmallEnoughToDup rhs + -- [Andy] added, Jun 95 + +{- Reinstated AJG Jun 95; This is needed + --example that does not (currently) work + --without this extention + + --let f = g x + --in + -- case of + -- True -> h i f + -- False -> f + -- ==> + -- case of + -- True -> h i f + -- False -> g x +-} +{- OLD: + Omitted SLPJ Feb 95; should, I claim, be unnecessary + -- is_really_small looks for things like f a b c + -- but making sure there are not *too* many arguments. + -- (This is brought to you by *ANDY* Magic Constants, Inc.) + is_really_small + = case collectArgs new_rhs of + (CoVar _, xs) -> length xs < 10 + _ -> False +-} + + +{- UNUSED: +extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv + +extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) + new_ids old_rhss + = SimplEnv chkr encl_cc ty_env id_env new_unfold_env + where + extra_unfold_items + = [ (new_id, UnfoldItem new_id + (GeneralForm True + (mkFormSummary (getIdStrictness new_id) old_rhs) + old_rhs UnfoldAlways) + encl_cc) + | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss, + simplIdWantsToBeINLINEd new_id env + ] + + new_unfold_env = addto_unfold_env unfold_env extra_unfold_items +-} +\end{code} + +\begin{code} +lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails + +lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var + | not (isLocallyDefined var) -- Imported, so look inside the id + = getIdUnfolding var + + | otherwise -- Locally defined, so look in the envt. + -- There'll be nothing inside the Id. + = lookup_unfold_env unfold_env var +\end{code} + +We need to remove any @GeneralForm@ bindings from the UnfoldEnv for +the RHS of an Id which has an INLINE pragma. + +\begin{code} +filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv + +filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) + = SimplEnv chkr encl_cc ty_env id_env new_unfold_env + where + new_unfold_env = null_unfold_env + -- This version is really simple. INLINEd things are going to + -- be inlined wherever they are used, and then all the + -- UnfoldEnv stuff will take effect. Meanwhile, there isn't + -- much point in doing anything to the as-yet-un-INLINEd rhs. + + -- Andy disagrees! Example: + -- all xs = foldr (&&) True xs + -- any p = all . map p {-# INLINE any #-} + -- + -- Problem: any won't get deforested, and so if it's exported and + -- the importer doesn't use the inlining, (eg passes it as an arg) + -- then we won't get deforestation at all. + -- + -- So he'd like not to filter the unfold env at all. But that's a disaster: + -- Suppose we have: + -- + -- let f = \pq -> BIG + -- in + -- let g = \y -> f y y + -- {-# INLINE g #-} + -- in ...g...g...g...g...g... + -- + -- Now, if that's the ONLY occurrence of f, it will be inlined inside g, + -- and thence copied multiple times when g is inlined. +\end{code} + +====================== + +In @lookForConstructor@ we used (before Apr 94) to have a special case +for nullary constructors: + +\begin{verbatim} + = -- Don't re-use nullary constructors; it's a waste. Consider + -- let + -- a = leInt#! p q + -- in + -- case a of + -- True -> ... + -- False -> False + -- + -- Here the False in the second case will get replace by "a", hardly + -- a good idea + Nothing +\end{verbatim} + +but now we only do constructor re-use in let-bindings the special +case isn't necessary any more. + +\begin{code} +lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args + = lookup_conapp unfold_env con ty_args con_args +\end{code} diff --git a/ghc/compiler/simplCore/SimplHaskell.lhs b/ghc/compiler/simplCore/SimplHaskell.lhs new file mode 100644 index 0000000..d6d5027 --- /dev/null +++ b/ghc/compiler/simplCore/SimplHaskell.lhs @@ -0,0 +1,249 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[SimplHaskell]{Printing Core that looks like Haskell} + +\begin{code} +#include "HsVersions.h" + +module SimplHaskell ( coreToHaskell ) where + +IMPORT_Trace +import Outputable +import Pretty + +import BasicLit ( BasicLit ) +import PlainCore +import IdEnv +import IdInfo +import Maybes +import Util +import AbsPrel ( PrimOp, nilDataCon, consDataCon ) +\end{code} + +\begin{code} +coreToHaskell :: PlainCoreProgram -> String {- 0 -} +coreToHaskell binds = ("[Haskell:\n\n" ++ ppShow 80 (pprHaskFuns (transformCoreProg binds)) ++ "\n\n]\n") +\end{code} + +\begin{code} +data HaskFun = HaskFun Id [([HaskExp],HaskExp)] + +data HaskExp + = HaskVar Bool Id -- true of used many times + | HaskLit BasicLit + | HaskWild + | HaskCon Id [HaskExp] + | HaskPrim PrimOp [HaskExp] + | HaskLam [HaskExp] HaskExp + | HaskApp HaskExp HaskExp + | HaskCase HaskExp [(HaskExp,HaskExp)] + | HaskIf HaskExp HaskExp HaskExp + | HaskLet [HaskFun] HaskExp +\end{code} + +Here is where the fun begins, you transform Core into Haskell! + +\begin{code} +type InEnv = IdEnv HaskExp +type OutEnv = IdEnv (Int,Bool) -- number of times used, and if save to inline + + +mkHaskPatVar :: OutEnv -> Id -> HaskExp +mkHaskPatVar env id = case lookupIdEnv env id of + Nothing -> HaskWild + Just (n,_) -> HaskVar (n > 1) id + +transformCoreProg :: PlainCoreProgram -> [HaskFun] +transformCoreProg prog = mergeCasesBindings funs + where + (_,_,funs) = transformCoreBindings nullIdEnv nullIdEnv prog + +transformCoreBindings :: InEnv -> OutEnv -> [PlainCoreBinding] -> (InEnv,OutEnv,[HaskFun]) +transformCoreBindings in_env out_env [bnd] = transformCoreBinding in_env out_env bnd +transformCoreBindings in_env out_env (bnd:bnds) = (in_env'',out_env',hask_bnd ++ hask_bnds) + where + (in_env',out_env',hask_bnd) = transformCoreBinding in_env out_env'' bnd + (in_env'',out_env'',hask_bnds) = transformCoreBindings in_env' out_env bnds + +transformCoreBinding :: InEnv -> OutEnv -> PlainCoreBinding -> (InEnv,OutEnv,[HaskFun]) +transformCoreBinding in_env out_env (CoNonRec v expr) = (in_env',out_env'',[HaskFun v rhs]) + where + out_env'' = merge out_env out_env' + (out_env',rhs) = transformCoreRhs in_env expr + in_env' = in_env `growIdEnvList` [ (v,exp) | [([],exp)] <- [rhs], False ] + +transformCoreBinding in_env out_env (CoRec bnds) = (in_env,out_env'',hask_bnds) + where + out_env'' = foldl merge out_env out_envs + (out_envs,hask_bnds) = unzip + [ (out_env',HaskFun v rhs) | + (v,exp) <- bnds, + (out_env',rhs) <- [transformCoreRhs in_env exp]] + + +transformCoreRhs :: InEnv -> PlainCoreExpr -> (OutEnv,[([HaskExp],HaskExp)]) +transformCoreRhs in_env exp = (out_env,[(vars',hask_exp)]) + where + vars' = [ mkHaskPatVar out_env v | v <- vars ] + (vars,exp') = getLambdaVars exp + (out_env,hask_exp) = transformCoreExp in_env exp' + getLambdaVars (CoTyLam _ e) = getLambdaVars e + getLambdaVars (CoLam xs e) = (xs ++ xs',e') + where (xs',e') = getLambdaVars e + getLambdaVars e = ([],e) + +transformCoreExp :: InEnv -> PlainCoreExpr -> (OutEnv,HaskExp) +transformCoreExp _ (CoVar v) = (unitIdEnv v (1,True),HaskVar False v) -- lookup Env ? +transformCoreExp _ (CoLit i) = (nullIdEnv,HaskLit i) +transformCoreExp in_env (CoCon i _ atoms) = (out_env,HaskCon i hask_exps) + where + (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms) +transformCoreExp in_env (CoPrim i _ atoms) = (out_env,HaskPrim i hask_exps) + where + (out_env,hask_exps) = transformCoreExps in_env (map atomToExpr atoms) +-- CoLam +-- CoTyLam +transformCoreExp in_env (CoLam args exp) = (out_env,HaskLam args' h_exp) + where -- modify the env !!!!! + args' = [ mkHaskPatVar out_env v | v <- args ] + (out_env,h_exp) = transformCoreExp in_env exp +transformCoreExp in_env (CoTyLam _ exp) = transformCoreExp in_env exp +transformCoreExp in_env (CoApp fun atom) = (merge o1 o2,HaskApp h_fun h_arg) + where + (o1,h_fun) = transformCoreExp in_env fun + (o2,h_arg) = transformCoreExp in_env (atomToExpr atom) +transformCoreExp in_env (CoTyApp fun _) = transformCoreExp in_env fun +transformCoreExp in_env (CoCase e alts) = (foldl merge o1 o2,HaskCase h_e h_alts) + where + (o1,h_e) = transformCoreExp in_env e + (o2,h_alts) = unzip [ (out_env,(pat,h_e)) | (out_env,pat,h_e) <- transformCoreAlts in_env alts ] + +transformCoreExp in_env exp@(CoLet _ _) = (o1,HaskLet h_binds h_exp) + where + (binds,exp') = getLets exp + (in_env',o1,h_binds) = transformCoreBindings in_env o2 binds + (o2,h_exp) = transformCoreExp in_env' exp' + getLets (CoLet bind exp) = (bind:binds,exp') + where (binds,exp') = getLets exp + getLets exp = ([],exp) + +transformCoreExp _ _ = (nullIdEnv,HaskWild) + +transformCoreExps :: InEnv -> [PlainCoreExpr] -> (OutEnv,[HaskExp]) +transformCoreExps _ [] = (nullIdEnv,[]) +transformCoreExps in_env (e:es) = (merge o1 o2,h_e:hs_e) + where + (o1,h_e) = transformCoreExp in_env e + (o2,hs_e) = transformCoreExps in_env es + +transformCoreAlts :: InEnv -> PlainCoreCaseAlternatives -> [(OutEnv,HaskExp,HaskExp)] +transformCoreAlts in_env (CoAlgAlts alts def) = map trans alts ++ mkdef def + where + trans (id,ids,e) = (o1,HaskCon id (map (mkHaskPatVar o1) ids),h_e) + where + (o1,h_e) = transformCoreExp in_env e + mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)] + where + (o1,h_e) = transformCoreExp in_env e + mkdef _ = [] +transformCoreAlts in_env (CoPrimAlts alts def) = map trans alts ++ mkdef def + where + trans (lit,e) = (o1,HaskLit lit,h_e) + where + (o1,h_e) = transformCoreExp in_env e + mkdef (CoBindDefault bnd e) = [(o1,mkHaskPatVar o1 bnd,h_e)] + where + (o1,h_e) = transformCoreExp in_env e + mkdef _ = [] +\end{code} + +\begin{code} +merge :: OutEnv -> OutEnv -> OutEnv +merge e1 e2 = combineIdEnvs fn e1 e2 + where + fn (n,_) (m,_) = (n+m,False) +\end{code} + + +\begin{code} +mergeCasesBindings = map mergeCasesFun + +mergeCasesFun (HaskFun id rhss) = HaskFun id (concat (map mergeCasesRhs rhss)) + +mergeCasesRhs (pats,exp) = [(pats,exp)] + +{- +case v of + A x -> e1 , v ==> Branch v [ (A x,e1), (B y,e2) ] + B y -> e2 OR + NoBranches (case v of + A x -> ... + B y -> ...) + +-} +--mergeCases :: HaskExp -> Set Id -> [(Id,HaskExp,HaskExp)] +--mergeCases _ _ = [] +\end{code} + + + +Maybe ??? + +type SM a = OutEnv Z +returnSH a s = (a,s) +thenSH m k s = case m s of + (r,s') -> k r s +thenSH_ m k s = case m s of + (_,s') -> k s + +\begin{code} +pprHaskFuns xs = ppAboves (map pprHaskFun xs) + +pprHaskFun (HaskFun id stuff) = + ppAboves [ + ppSep [ ppCat ([ppr PprForUser id] ++ map (pprHaskExp True) pats), + ppNest 2 (ppCat [ppStr "=",pprHaskExp False rhs])] + | (pats,rhs) <- stuff] + +pprHaskExp :: Bool -> HaskExp -> Pretty +pprHaskExp _ (HaskVar _ id) = ppr PprForUser id +pprHaskExp _ (HaskLit i) = ppr PprForUser i +pprHaskExp _ (HaskWild) = ppStr "_" +pprHaskExp True exp = ppBesides [ppLparen,pprHaskExp False exp,ppRparen] +pprHaskExp _ (HaskCon con []) | con == nilDataCon = ppStr "[]" +pprHaskExp _ (HaskCon con [e1,e2]) | con == consDataCon = + ppCat [pprHaskExp True e1,ppStr ":",pprHaskExp True e2] +pprHaskExp _ (HaskCon con exps) = + ppCat (ppr PprForUser con:map (pprHaskExp True) exps) +pprHaskExp _ (HaskPrim prim exps) = + ppCat (ppr PprForUser prim:map (pprHaskExp True) exps) +pprHaskExp _ app@(HaskLam xs e) = -- \ xs -> e + ppSep [ ppCat ([ppStr "\\"] ++ map (pprHaskExp True) xs), + ppNest 2 (ppCat [ppStr "->",pprHaskExp False e])] +pprHaskExp _ app@(HaskApp _ _) = pprHaskApp app +pprHaskExp _ (HaskCase e opts) + = ppAboves [ppCat [ppStr "case", pprHaskExp False e,ppStr "of"], + ppNest 2 ( + ppAboves [ + (ppSep [ppCat [pprHaskExp False pat,ppStr "->"], + ppNest 2 (pprHaskExp False exp)]) + | (pat,exp) <- opts])] +pprHaskExp _ (HaskIf i t e) = ppAboves + [ppCat [ppStr "if",pprHaskExp False i], + ppCat [ppStr "then",pprHaskExp False t], + ppCat [ppStr "else",pprHaskExp False e]] +pprHaskExp _ (HaskLet binds e) + = ppAboves [ppStr "let", + ppNest 2 (pprHaskFuns binds), + ppCat [ppStr "in",ppNest 1 (pprHaskExp False e)]] +pprHaskExp _ _ = panic "pprHaskExp failed" + + +pprHaskApp (HaskApp fun arg) = ppCat [pprHaskApp fun,pprHaskExp True arg] +pprHaskApp e = pprHaskExp True e +\end{code} + + + +pprHaskExp n exp = ppr diff --git a/ghc/compiler/simplCore/SimplMonad.hi b/ghc/compiler/simplCore/SimplMonad.hi new file mode 100644 index 0000000..4e523f9 --- /dev/null +++ b/ghc/compiler/simplCore/SimplMonad.hi @@ -0,0 +1,95 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplMonad where +import BasicLit(BasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import Class(Class) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import NameTypes(ShortName) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SimplEnv(SimplEnv) +import SplitUniq(SplitUniqSupply, splitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +infixr 9 `thenSmpl` +infixr 9 `thenSmpl_` +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-} +type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount) +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data TickType = UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +cloneId :: SimplEnv -> (Id, BinderInfo) -> SplitUniqSupply -> SimplCount -> (Id, SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "LU(LA)LL" {_A_ 4 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cloneIds :: SimplEnv -> [(Id, BinderInfo)] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +cloneTyVarSmpl :: TyVar -> SplitUniqSupply -> SimplCount -> (TyVar, SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _N_ _N_ _N_ #-} +combineSimplCounts :: SimplCount -> SimplCount -> SimplCount + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(PL)U(PA)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: Int#) (u1 :: [(TickType, Int)]) (u2 :: Int#) -> case _#_ plusInt# [] [u0, u2] of { _PRIM_ (u3 :: Int#) -> _!_ _ORIG_ SimplMonad SimplCount [] [u3, u1] } _N_} _F_ _IF_ARGS_ 0 2 CC 6 \ (u0 :: SimplCount) (u1 :: SimplCount) -> case u0 of { _ALG_ _ORIG_ SimplMonad SimplCount (u2 :: Int#) (u3 :: [(TickType, Int)]) -> case u1 of { _ALG_ _ORIG_ SimplMonad SimplCount (u4 :: Int#) (u5 :: [(TickType, Int)]) -> case _#_ plusInt# [] [u2, u4] of { _PRIM_ (u6 :: Int#) -> _!_ _ORIG_ SimplMonad SimplCount [] [u6, u3] }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +detailedSimplCount :: SplitUniqSupply -> SimplCount -> (SimplCount, SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: SimplCount) -> _!_ _TUP_2 [SimplCount, SimplCount] [u0, u0] _N_} _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: SplitUniqSupply) (u1 :: SimplCount) -> _!_ _TUP_2 [SimplCount, SimplCount] [u1, u1] _N_ #-} +initSmpl :: SplitUniqSupply -> (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a, SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: SplitUniqSupply) (u2 :: SplitUniqSupply -> SimplCount -> (u0, SimplCount)) -> _APP_ u2 [ u1, _ORIG_ SimplMonad zeroSimplCount ] _N_ #-} +mapAndUnzipSmpl :: (a -> SplitUniqSupply -> SimplCount -> ((b, c), SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> (([b], [c]), SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +mapSmpl :: (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> ([b], SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +newId :: UniType -> SplitUniqSupply -> SimplCount -> (Id, SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _N_ _N_ _N_ #-} +newIds :: [UniType] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +returnSmpl :: a -> SplitUniqSupply -> SimplCount -> (a, SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) (u3 :: SimplCount) -> _!_ _TUP_2 [u0, SimplCount] [u1, u3] _N_ #-} +showSimplCount :: SimplCount -> [Char] + {-# GHC_PRAGMA _A_ 0 _U_ 1 _N_ _N_ _N_ _N_ #-} +simplCount :: SplitUniqSupply -> SimplCount -> (Int, SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(PL)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +thenSmpl :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> SimplCount -> (u0, SimplCount)) (u3 :: u0 -> SplitUniqSupply -> SimplCount -> (u1, SimplCount)) (u4 :: SplitUniqSupply) (u5 :: SimplCount) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> case _APP_ u2 [ u7, u5 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: SimplCount) -> _APP_ u3 [ u9, u8, ua ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +thenSmpl_ :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> SimplCount -> (u0, SimplCount)) (u3 :: SplitUniqSupply -> SimplCount -> (u1, SimplCount)) (u4 :: SplitUniqSupply) (u5 :: SimplCount) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> case _APP_ u2 [ u7, u5 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: SimplCount) -> _APP_ u3 [ u8, ua ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +tick :: TickType -> SplitUniqSupply -> SimplCount -> ((), SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 001 _N_ _S_ "AAU(PL)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +tickN :: TickType -> Int -> SplitUniqSupply -> SimplCount -> ((), SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 0101 _N_ _S_ "AU(P)AU(PL)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +zeroSimplCount :: SimplCount + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq TickType + {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TickType -> TickType -> Bool), (TickType -> TickType -> Bool)] [_CONSTM_ Eq (==) (TickType), _CONSTM_ Eq (/=) (TickType)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ix TickType + {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [{{Ord TickType}}, ((TickType, TickType) -> [TickType]), ((TickType, TickType) -> TickType -> Int), ((TickType, TickType) -> TickType -> Bool)] [_DFUN_ Ord (TickType), _CONSTM_ Ix range (TickType), _CONSTM_ Ix index (TickType), _CONSTM_ Ix inRange (TickType)] _N_ + range = _A_ 1 _U_ 1 _N_ _S_ "U(EE)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + index = _A_ 2 _U_ 12 _N_ _S_ "U(EE)E" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_, + inRange = _A_ 2 _U_ 11 _N_ _S_ "U(EE)E" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord TickType + {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TickType}}, (TickType -> TickType -> Bool), (TickType -> TickType -> Bool), (TickType -> TickType -> Bool), (TickType -> TickType -> Bool), (TickType -> TickType -> TickType), (TickType -> TickType -> TickType), (TickType -> TickType -> _CMP_TAG)] [_DFUN_ Eq (TickType), _CONSTM_ Ord (<) (TickType), _CONSTM_ Ord (<=) (TickType), _CONSTM_ Ord (>=) (TickType), _CONSTM_ Ord (>) (TickType), _CONSTM_ Ord max (TickType), _CONSTM_ Ord min (TickType), _CONSTM_ Ord _tagCmp (TickType)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Text TickType + {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(TickType, [Char])]), (Int -> TickType -> [Char] -> [Char]), ([Char] -> [([TickType], [Char])]), ([TickType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (TickType), _CONSTM_ Text showsPrec (TickType), _CONSTM_ Text readList (TickType), _CONSTM_ Text showList (TickType)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(TickType, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs new file mode 100644 index 0000000..e4b312f --- /dev/null +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -0,0 +1,330 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplMonad]{The simplifier Monad} + +\begin{code} +#include "HsVersions.h" + +module SimplMonad ( + SmplM(..), + initSmpl, returnSmpl, thenSmpl, thenSmpl_, + mapSmpl, mapAndUnzipSmpl, + + -- Counting + SimplCount{-abstract-}, TickType(..), tick, tickN, + simplCount, detailedSimplCount, + zeroSimplCount, showSimplCount, combineSimplCounts, + + -- Cloning + cloneId, cloneIds, cloneTyVarSmpl, newIds, newId, + + -- and to make the interface self-sufficient... + BinderInfo, CoreExpr, Id, PrimOp, TyVar, UniType, + SplitUniqSupply + + IF_ATTACK_PRAGMAS(COMMA splitUniqSupply) + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import TaggedCore +import PlainCore + +import AbsUniType ( cloneTyVar ) +import CmdLineOpts +import Id ( mkIdWithNewUniq, mkSysLocal ) +import IdInfo +import SimplEnv +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import SplitUniq +import Unique +import Util + +infixr 9 `thenSmpl`, `thenSmpl_` +\end{code} + +%************************************************************************ +%* * +\subsection[Monad]{Monad plumbing} +%* * +%************************************************************************ + +For the simplifier monad, we want to {\em thread} a unique supply and a counter. +(Command-line switches move around through the explicitly-passed SimplEnv.) + +\begin{code} +type SmplM result + = SplitUniqSupply + -> SimplCount -- things being threaded + -> (result, SimplCount) +\end{code} + +\begin{code} +initSmpl :: SplitUniqSupply -- no init count; set to 0 + -> SmplM a + -> (a, SimplCount) + +initSmpl us m = m us zeroSimplCount + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenSmpl #-} +{-# INLINE thenSmpl_ #-} +{-# INLINE returnSmpl #-} +#endif + +returnSmpl :: a -> SmplM a +returnSmpl e us sc = (e, sc) + +thenSmpl :: SmplM a -> (a -> SmplM b) -> SmplM b +thenSmpl_ :: SmplM a -> SmplM b -> SmplM b + +thenSmpl m k us sc0 + = case splitUniqSupply us of { (s1, s2) -> + case (m s1 sc0) of { (m_result, sc1) -> + k m_result s2 sc1 }} + +thenSmpl_ m k us sc0 + = case splitUniqSupply us of { (s1, s2) -> + case (m s1 sc0) of { (_, sc1) -> + k s2 sc1 }} + +mapSmpl :: (a -> SmplM b) -> [a] -> SmplM [b] +mapAndUnzipSmpl :: (a -> SmplM (b, c)) -> [a] -> SmplM ([b],[c]) + +mapSmpl f [] = returnSmpl [] +mapSmpl f (x:xs) + = f x `thenSmpl` \ x' -> + mapSmpl f xs `thenSmpl` \ xs' -> + returnSmpl (x':xs') + +mapAndUnzipSmpl f [] = returnSmpl ([],[]) +mapAndUnzipSmpl f (x:xs) + = f x `thenSmpl` \ (r1, r2) -> + mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) -> + returnSmpl (r1:rs1, r2:rs2) +\end{code} + + +%************************************************************************ +%* * +\subsection[SimplCount]{Counting up what we've done} +%* * +%************************************************************************ + +The assoc list isn't particularly costly, because we only use +the number of ticks in ``real life.'' + +The right thing to do, if you want that to go fast, is thread +a mutable array through @SimplM@. + +\begin{code} +data SimplCount + = SimplCount FAST_INT -- number of ticks + [(TickType, Int)] -- assoc list of all diff kinds of ticks + +data TickType + = UnfoldingDone {-UNUSED: | Unused -} + | FoldrBuild | MagicUnfold | ConReused + | CaseFloatFromLet | CaseOfCase {-UNUSED: | CaseFloatFromApp -} + | LetFloatFromLet | LetFloatFromCase {-UNUSED: | LetFloatFromApp -} + | KnownBranch | Let2Case {-UNUSED: | UnboxingLet2Case -} + | CaseMerge {-UNUSED: | CaseToLet-} | CaseElim + | CaseIdentity + | AtomicRhs -- Rhs of a let-expression was an atom + | EtaExpansion {-UNUSED: | ArityExpand-} + {-UNUSED: | ConstantFolding-} | CaseOfError {-UNUSED: | InlineRemoved -} + | FoldrConsNil + | Foldr_Nil + | FoldrFoldr + | Foldr_List + | FoldrCons + | FoldrInline + | TyBetaReduction + | BetaReduction + deriving (Eq, Ord, Ix) + +instance Text TickType where + showsPrec p UnfoldingDone = showString "UnfoldingDone " +--UNUSED: showsPrec p Unused = showString "Unused " + showsPrec p FoldrBuild = showString "FoldrBuild " + showsPrec p MagicUnfold = showString "MagicUnfold " + showsPrec p ConReused = showString "ConReused " + showsPrec p CaseFloatFromLet= showString "CaseFloatFromLet " + showsPrec p CaseOfCase = showString "CaseOfCase " +--UNUSED: showsPrec p CaseFloatFromApp= showString "CaseFloatFromApp " + showsPrec p LetFloatFromLet = showString "LetFloatFromLet " + showsPrec p LetFloatFromCase= showString "LetFloatFromCase " +--UNUSED: showsPrec p LetFloatFromApp = showString "LetFloatFromApp " + showsPrec p KnownBranch = showString "KnownBranch " + showsPrec p Let2Case = showString "Let2Case " +--UNUSED: showsPrec p UnboxingLet2Case= showString "UnboxingLet2Case " + showsPrec p CaseMerge = showString "CaseMerge " +--UNUSED: showsPrec p CaseToLet = showString "CaseToLet " + showsPrec p CaseElim = showString "CaseElim " + showsPrec p CaseIdentity = showString "CaseIdentity " + showsPrec p AtomicRhs = showString "AtomicRhs " + showsPrec p EtaExpansion = showString "EtaExpansion " +--UNUSED: showsPrec p ArityExpand = showString "ArityExpand " +--UNUSED: showsPrec p ConstantFolding = showString "ConstantFolding " + showsPrec p CaseOfError = showString "CaseOfError " +--UNUSED: showsPrec p InlineRemoved = showString "InlineRemoved " + showsPrec p FoldrConsNil = showString "FoldrConsNil " + showsPrec p Foldr_Nil = showString "Foldr_Nil " + showsPrec p FoldrFoldr = showString "FoldrFoldr " + showsPrec p Foldr_List = showString "Foldr_List " + showsPrec p FoldrCons = showString "FoldrCons " + showsPrec p FoldrInline = showString "FoldrInline " + showsPrec p TyBetaReduction = showString "TyBetaReduction " + showsPrec p BetaReduction = showString "BetaReduction " + +showSimplCount :: SimplCount -> String + +showSimplCount (SimplCount _ stuff) + = shw stuff + where + shw [] = "" + shw ((t,n):tns) | n /= 0 = show t ++ ('\t' : show n) ++ ('\n' : shw tns) + | otherwise = shw tns + +zeroSimplCount :: SimplCount +zeroSimplCount + = SimplCount ILIT(0) + [(UnfoldingDone, 0), +--UNUSED: (Unused, 0), + (FoldrBuild, 0), + (MagicUnfold, 0), + (ConReused, 0), + (CaseFloatFromLet, 0), + (CaseOfCase, 0), +--UNUSED: (CaseFloatFromApp, 0), + (LetFloatFromLet, 0), + (LetFloatFromCase, 0), +--UNUSED: (LetFloatFromApp, 0), + (KnownBranch, 0), + (Let2Case, 0), +--UNUSED: (UnboxingLet2Case, 0), + (CaseMerge, 0), +--UNUSED: (CaseToLet, 0), + (CaseElim, 0), + (CaseIdentity, 0), + (AtomicRhs, 0), + (EtaExpansion, 0), +--UNUSED: (ArityExpand,0), +--UNUSED: (ConstantFolding, 0), + (CaseOfError, 0), +--UNUSED: (InlineRemoved,0), + (FoldrConsNil,0), + (Foldr_Nil,0), + (FoldrFoldr,0), + (Foldr_List,0), + (FoldrCons,0), + (FoldrInline,0), + (TyBetaReduction,0), + (BetaReduction,0) ] +-- +--= array (con2tag_TickType UnfoldingDone, con2tag_TickType FoldrInline) +-- [ i := 0 | i <- indices zeroSimplCount ] +\end{code} + +Counting-related monad functions: +\begin{code} +tick :: TickType -> SmplM () + +tick tick_type us (SimplCount n stuff) + = ((), SimplCount (n _ADD_ ILIT(1)) +#ifdef OMIT_SIMPL_COUNTS + stuff -- don't change anything +#else + (inc_tick stuff) +#endif + ) + where + inc_tick [] = panic "couldn't inc_tick!" + inc_tick (x@(ttype, cnt) : xs) + = if ttype == tick_type then + let + incd = cnt + 1 + in + (ttype, incd) : xs + else + x : inc_tick xs + +tickN :: TickType -> Int -> SmplM () + +tickN tick_type IBOX(increment) us (SimplCount n stuff) + = ((), SimplCount (n _ADD_ increment) +#ifdef OMIT_SIMPL_COUNTS + stuff -- don't change anything +#else + (inc_tick stuff) +#endif + ) + where + inc_tick [] = panic "couldn't inc_tick!" + inc_tick (x@(ttype, cnt) : xs) + = if ttype == tick_type then + let + incd = cnt + IBOX(increment) + in + (ttype, incd) : xs + else + x : inc_tick xs + +simplCount :: SmplM Int +simplCount us sc@(SimplCount n _) = (IBOX(n), sc) + +detailedSimplCount :: SmplM SimplCount +detailedSimplCount us sc = (sc, sc) + +combineSimplCounts :: SimplCount -> SimplCount -> SimplCount + +#ifdef OMIT_SIMPL_COUNTS +combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) + = SimplCount (n1 _ADD_ n2) + stuff1 -- just pick one +#else +combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) + = SimplCount (n1 _ADD_ n2) + (zipWith (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Monad primitives} +%* * +%************************************************************************ + +\begin{code} +newId :: UniType -> SmplM Id +newId ty us sc + = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc) + where + uniq = getSUnique us + +newIds :: [UniType] -> SmplM [Id] +newIds tys us sc + = (zipWith mk_id tys uniqs, sc) + where + uniqs = getSUniques (length tys) us + mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc + +cloneTyVarSmpl :: TyVar -> SmplM TyVar + +cloneTyVarSmpl tyvar us sc + = (new_tyvar, sc) + where + uniq = getSUnique us + new_tyvar = cloneTyVar tyvar uniq + +cloneId :: SimplEnv -> InBinder -> SmplM OutId +cloneId env (id,_) us sc + = (mkIdWithNewUniq id_with_new_ty uniq, sc) + where + id_with_new_ty = simplTyInId env id + uniq = getSUnique us + +cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId] +cloneIds env binders = mapSmpl (cloneId env) binders +\end{code} diff --git a/ghc/compiler/simplCore/SimplPgm.hi b/ghc/compiler/simplCore/SimplPgm.hi new file mode 100644 index 0000000..047e784 --- /dev/null +++ b/ghc/compiler/simplCore/SimplPgm.hi @@ -0,0 +1,10 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplPgm where +import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult) +import CoreSyn(CoreBinding) +import Id(Id) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +simplifyPgm :: [CoreBinding Id Id] -> (GlobalSwitch -> SwitchResult) -> (SimplifierSwitch -> SwitchResult) -> SimplCount -> SplitUniqSupply -> ([CoreBinding Id Id], Int, SimplCount) + {-# GHC_PRAGMA _A_ 5 _U_ 12211 _N_ _S_ "LSSLU(ALL)" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs new file mode 100644 index 0000000..8b81877 --- /dev/null +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -0,0 +1,256 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplPgm]{Interface to the ``new'' simplifier} + +\begin{code} +#include "HsVersions.h" + +module SimplPgm ( simplifyPgm ) where + +import PlainCore +import TaggedCore + +import Pretty -- ToDo: rm debugging +IMPORT_Trace + +import AbsUniType ( getTyVarMaybe ) +import CmdLineOpts ( switchIsOn, intSwitchSet, + GlobalSwitch(..), SimplifierSwitch(..) + ) +import Id ( cmpId, externallyVisibleId ) +import IdEnv +import IdInfo +import Maybes ( catMaybes, Maybe(..) ) +import Outputable +import SimplEnv +import SimplMonad +import Simplify ( simplTopBinds ) +import OccurAnal -- occurAnalyseBinds +#if ! OMIT_FOLDR_BUILD +import NewOccurAnal -- newOccurAnalyseBinds +#endif +import TyVarEnv -- ( nullTyVarEnv ) +import SplitUniq +import Unique +import Util +\end{code} + +\begin{code} +simplifyPgm :: [PlainCoreBinding] -- input + -> (GlobalSwitch->SwitchResult) -- switch lookup fns (global + -> (SimplifierSwitch->SwitchResult) -- and this-simplification-specific) + -> SimplCount -- info about how many times + -- each transformation has occurred + -> SplitUniqSupply + -> ([PlainCoreBinding], -- output + Int, -- info about how much happened + SimplCount) -- accumulated simpl stats + +simplifyPgm binds g_sw_chkr 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 + +#if OMIT_FOLDR_BUILD + occur_anal = occurAnalyseBinds +#else + occur_anal = if simpl_switch_is_on SimplDoNewOccurAnal + then newOccurAnalyseBinds + else occurAnalyseBinds +#endif + + max_simpl_iterations + = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of + Nothing -> 1 -- default + Just max -> max + + simpl_pgm :: Int -> Int -> [PlainCoreBinding] -> SmplM ([PlainCoreBinding], Int, SimplCount) + + simpl_pgm 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 + in + -- do the business + simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm -> + + -- Quit if we didn't actually do anything; otherwise, + -- try again (if suitable flags) + + simplCount `thenSmpl` \ r -> + detailedSimplCount `thenSmpl` \ dr -> + let + show_status = pprTrace "NewSimpl: " (ppAboves [ + ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations], + ppStr (showSimplCount dr) +--DEBUG: , ppAboves (map (pprPlainCoreBinding PprDebug) new_pgm) + ]) + in + + (if global_switch_is_on D_verbose_core2core + || simpl_switch_is_on ShowSimplifierProgress + then show_status + else id) + + (let stop_now = r == n {-nothing happened-} + || (if iterations > max_simpl_iterations then + (if max_simpl_iterations > 1 {-otherwise too boring-} then + trace + ("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.") + else id) + True + else + False) + in + if stop_now then + (if global_switch_is_on D_verbose_core2core + then show_status + else id) + (returnSmpl (new_pgm, iterations, dr)) + else + simpl_pgm r (iterations + 1) new_pgm + ) + -- ) +\end{code} + +In @tidy_top@, we look for things at the top-level of the form... +\begin{verbatim} +x_local = .... + +x_exported = x_local -- or perhaps... + +x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible +\end{verbatim} +In cases we find like this, we go {\em backwards} and replace +\tr{x_local} with \tr{x_exported}. This save a gratuitous jump +(from \tr{x_exported} to \tr{x_local}), and makes strictness +information propagate better. + +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then obviously we give up. + +Strategy: first collect the info; then make a \tr{Id -> Id} mapping. +Then blast the whole program (LHSs as well as RHSs) with it. + +\begin{code} +type BlastEnv = IdEnv Id -- domain is local Ids; range is exported Ids + +not_elem = isn'tIn "undup" + +tidy_top :: [PlainCoreBinding] -> SUniqSM [PlainCoreBinding] + +tidy_top binds_in + = if null blast_alist then + returnSUs binds_in -- no joy there + else + -- pprTrace "undup output length:" (ppInt (length blast_alist)) ( + mapSUs blast binds_in `thenSUs` \ binds_maybe -> + returnSUs (catMaybes binds_maybe) + -- ) + where + blast_alist = undup (foldl find_cand [] binds_in) + blast_id_env = mkIdEnv blast_alist + blast_val_env= mkIdEnv [ (l, CoVar e) | (l,e) <- blast_alist ] + blast_all_exps = map snd blast_alist + + --------- + find_cand blast_list (CoRec _) = blast_list -- recursively paranoid, as usual + + find_cand blast_list (CoNonRec binder rhs) + = if not (isExported binder) then + blast_list + else + case rhs_equiv_to_local_var rhs of + Nothing -> blast_list + Just local -> (local, binder) : blast_list -- tag it on + + ------------------------------------------ + -- if an Id appears >1 time in the domain, + -- *all* occurrences must be expunged. + undup :: [(Id, Id)] -> [(Id, Id)] + + undup blast_list + = -- pprTrace "undup input length:" (ppInt (length blast_list)) ( + let + (singles, dups) = removeDups cmp blast_list + list_of_dups = concat dups + in + [ s | s <- singles, s `not_elem` list_of_dups ] + -- ) + where + cmp (x,_) (y,_) = x `cmpId` y + + ------------------------------------------ + rhs_equiv_to_local_var (CoVar x) + = if externallyVisibleId x then Nothing else Just x + + rhs_equiv_to_local_var expr = Nothing +{- MAYBE NOT: + = case (digForLambdas expr) of { (tyvars, binders, body) -> + case (collectArgs body) of { (fun, args) -> + case fun of + CoVar x -> if null binders + && not (isExported x) + && tylams_match_tyargs tyvars args then + -- may need to chk for "tyvars" occurring in "x"'s type + Just x + else + Nothing + _ -> Nothing + }} + where + -- looking for a very restricted special case: + -- /\ tv1 tv2 ... -> var tv1 tv2 ... + + tylams_match_tyargs [] [] = True + tylams_match_tyargs (tv:tvs) (TypeArg ty : args) + = ASSERT(not (isPrimType ty)) + case (getTyVarMaybe ty) of + Nothing -> False + Just tyvar -> tv == tyvar + tylams_match_tyargs _ _ = False +-} + + ------------------------------------------ + -- "blast" does the substitution: + -- returns Nothing if a binding goes away + -- returns "Just b" to give back a fixed-up binding + + blast :: PlainCoreBinding -> SUniqSM (Maybe PlainCoreBinding) + + blast (CoRec pairs) + = mapSUs blast_pr pairs `thenSUs` \ blasted_pairs -> + returnSUs (Just (CoRec blasted_pairs)) + where + blast_pr (binder, rhs) + = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs -> + returnSUs ( + case lookupIdEnv blast_id_env binder of + Just exportee -> (exportee, blasted_rhs) + Nothing -> (binder, blasted_rhs) + ) + + blast (CoNonRec binder rhs) + = if binder `is_elem` blast_all_exps then + returnSUs Nothing -- this binding dies! + else + subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs -> + returnSUs (Just ( + case lookupIdEnv blast_id_env binder of + Just exportee -> CoNonRec exportee blasted_rhs + Nothing -> CoNonRec binder blasted_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.hi b/ghc/compiler/simplCore/SimplUtils.hi new file mode 100644 index 0000000..e908c64 --- /dev/null +++ b/ghc/compiler/simplCore/SimplUtils.hi @@ -0,0 +1,25 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplUtils where +import BinderInfo(BinderInfo) +import CoreSyn(CoreCaseAlternatives, CoreExpr) +import Id(Id) +import SimplEnv(SimplEnv) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import TyVar(TyVar) +import UniType(UniType) +etaExpandCount :: CoreExpr a Id -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +floatExposesHNF :: Bool -> Bool -> Bool -> CoreExpr a Id -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LLLS" _N_ _N_ #-} +mkCoLamTryingEta :: [Id] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +mkCoTyLamTryingEta :: [TyVar] -> CoreExpr Id Id -> CoreExpr Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkIdentityAlts :: UniType -> SplitUniqSupply -> SimplCount -> (CoreCaseAlternatives (Id, BinderInfo) Id, SimplCount) + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LU(SAAAA)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +type_ok_for_let_to_case :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs new file mode 100644 index 0000000..e0ac4aa --- /dev/null +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -0,0 +1,456 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplUtils]{The simplifier utilities} + +\begin{code} +#include "HsVersions.h" + +module SimplUtils ( + + floatExposesHNF, + + mkCoTyLamTryingEta, mkCoLamTryingEta, + + etaExpandCount, + + mkIdentityAlts, + + simplIdWantsToBeINLINEd, + + type_ok_for_let_to_case + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty + +import TaggedCore +import PlainCore +import SimplEnv +import SimplMonad + +import BinderInfo + +import AbsPrel ( primOpIsCheap, realWorldStateTy, buildId + IF_ATTACK_PRAGMAS(COMMA realWorldTy) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( extractTyVarsFromTy, getTyVarMaybe, isPrimType, + splitTypeWithDictsAsArgs, getUniDataTyCon_maybe, + applyTy, isFunType, TyVar, TyVarTemplate + IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass) + ) +import Id ( getInstantiatedDataConSig, isDataCon, getIdUniType, + getIdArity, isBottomingId, idWantsToBeINLINEd, + DataCon(..), Id + ) +import IdInfo +import CmdLineOpts ( SimplifierSwitch(..) ) +import Maybes ( maybeToBool, Maybe(..) ) +import Outputable -- isExported ... +import Util +\end{code} + + +Floating +~~~~~~~~ +The function @floatExposesHNF@ tells whether let/case floating will +expose a head normal form. It is passed booleans indicating the +desired strategy. + +\begin{code} +floatExposesHNF + :: Bool -- Float let(rec)s out of rhs + -> Bool -- Float cheap primops out of rhs + -> Bool -- OK to duplicate code + -> CoreExpr bdr Id + -> Bool + +floatExposesHNF float_lets float_primops ok_to_dup rhs + = try rhs + where + try (CoCase (CoPrim _ _ _) (CoPrimAlts alts deflt) ) + | float_primops && (null alts || ok_to_dup) + = or (try_deflt deflt : map try_alt alts) + + try (CoLet bind body) | float_lets = try body + + -- `build g' + -- is like a HNF, + -- because it *will* become one. + try (CoApp (CoTyApp (CoVar bld) _) _) | bld == buildId = True + + try other = manifestlyWHNF other + {- but *not* necessarily "manifestlyBottom other"... + + We may want to float a let out of a let to expose WHNFs, + but to do that to expose a "bottom" is a Bad Idea: + let x = let y = ... + in ...error ...y... -- manifestly bottom using y + in ... + =/=> + let y = ... + in let x = ...error ...y... + in ... + + as y is only used in case of an error, we do not want + to allocate it eagerly as that's a waste. + -} + + try_alt (lit,rhs) = try rhs + + try_deflt CoNoDefault = False + try_deflt (CoBindDefault _ rhs) = try rhs +\end{code} + + +Eta reduction on ordinary lambdas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have a go at doing + + \ x y -> f x y ===> f + +But we only do this if it gets rid of a whole lambda, not part. +The idea is that lambdas are often quite helpful: they indicate +head normal forms, so we don't want to chuck them away lightly. +But if they expose a simple variable then we definitely win. Even +if they expose a type application we win. So we check for this special +case. + +It does arise: + + f xs = [y | (y,_) <- xs] + +gives rise to a recursive function for the list comprehension, and +f turns out to be just a single call to this recursive function. + +\begin{code} +mkCoLamTryingEta :: [Id] -- Args to the lambda + -> PlainCoreExpr -- Lambda body + -> PlainCoreExpr + +mkCoLamTryingEta [] body = body + +mkCoLamTryingEta orig_ids body + = reduce_it (reverse orig_ids) body + where + bale_out = mkCoLam orig_ids body + + reduce_it [] residual + | residual_ok residual = residual + | otherwise = bale_out + + reduce_it (id:ids) (CoApp fun (CoVarAtom arg)) + | id == arg + && getIdUniType id /= realWorldStateTy + -- *never* eta-reduce away a PrimIO state token! (WDP 94/11) + = reduce_it ids fun + + reduce_it ids other = bale_out + + is_elem = isIn "mkCoLamTryingEta" + + ----------- + residual_ok :: PlainCoreExpr -> Bool -- Checks for type application + -- and function not one of the + -- bound vars + residual_ok (CoTyApp fun ty) = residual_ok fun + residual_ok (CoVar v) = not (v `is_elem` orig_ids) -- Fun mustn't be one of + -- the bound ids + residual_ok other = False +\end{code} + +Eta expansion +~~~~~~~~~~~~~ +@etaExpandCount@ takes an expression, E, and returns an integer n, +such that + + E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn) + +is a safe transformation. In particular, the transformation should not +cause work to be duplicated, unless it is ``cheap'' (see @manifestlyCheap@ below). + +@etaExpandCount@ errs on the conservative side. It is always safe to return 0. + +An application of @error@ is special, because it can absorb as many +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 :: CoreExpr bdr Id + -> Int -- Number of extra args you can safely abstract + +etaExpandCount (CoLam ids body) + = length ids + etaExpandCount body + +etaExpandCount (CoLet bind body) + | all manifestlyCheap (rhssOfBind bind) + = etaExpandCount body + +etaExpandCount (CoCase scrut alts) + | manifestlyCheap scrut + = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts] + +etaExpandCount (CoApp fun _) = case etaExpandCount fun of + 0 -> 0 + n -> n-1 -- Knock off one + +etaExpandCount fun@(CoTyApp _ _) = eta_fun fun +etaExpandCount fun@(CoVar _) = eta_fun fun + +etaExpandCount other = 0 -- Give up + -- CoLit, CoCon, CoPrim, + -- CoTyLam, + -- CoScc (pessimistic; ToDo), + -- CoLet with non-whnf rhs(s), + -- CoCase with non-whnf scrutinee + +eta_fun :: CoreExpr bdr Id -- The function + -> Int -- How many args it can safely be applied to + +eta_fun (CoTyApp fun ty) = eta_fun fun + +eta_fun expr@(CoVar v) + | isBottomingId v -- Bottoming ids have "infinite arity" + = 10000 -- Blargh. Infinite enough! + +eta_fun expr@(CoVar v) + | maybeToBool arity_maybe -- We know the arity + = arity + where + arity_maybe = arityMaybe (getIdArity v) + arity = case arity_maybe of { Just arity -> arity } + +eta_fun other = 0 -- Give up +\end{code} + +@manifestlyCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +By ``cheap'' we mean a computation we're willing to duplicate in order +to bring a couple of lambdas together. The main examples of things +which aren't WHNF but are ``cheap'' are: + + * case e of + pi -> ei + + where e, and all the ei are cheap; and + + * let x = e + in b + + where e and b are cheap; and + + * op x1 ... xn + + where op is a cheap primitive operator + +\begin{code} +manifestlyCheap :: CoreExpr bndr Id -> Bool + +manifestlyCheap (CoVar _) = True +manifestlyCheap (CoLit _) = True +manifestlyCheap (CoCon _ _ _) = True +manifestlyCheap (CoLam _ _) = True +manifestlyCheap (CoTyLam _ e) = manifestlyCheap e +manifestlyCheap (CoSCC _ e) = manifestlyCheap e + +manifestlyCheap (CoPrim op _ _) = primOpIsCheap op + +manifestlyCheap (CoLet bind body) + = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind) + +manifestlyCheap (CoCase scrut alts) + = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts) + +manifestlyCheap other_expr -- look for manifest partial application + = case (collectArgs other_expr) of { (fun, args) -> + case fun of + + CoVar f | isBottomingId f -> True -- Application of a function which + -- always gives bottom; we treat this as + -- a WHNF, because it certainly doesn't + -- need to be shared! + + CoVar f -> let + num_val_args = length [ a | (ValArg a) <- args ] + in + num_val_args == 0 || -- Just a type application of + -- a variable (f t1 t2 t3) + -- counts as WHNF + case (arityMaybe (getIdArity f)) of + Nothing -> False + Just arity -> num_val_args < arity + + _ -> False + } + + +-- ToDo: Move to CoreFuns + +rhssOfBind :: CoreBinding bndr bdee -> [CoreExpr bndr bdee] + +rhssOfBind (CoNonRec _ rhs) = [rhs] +rhssOfBind (CoRec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfAlts :: CoreCaseAlternatives bndr bdee -> [CoreExpr bndr bdee] + +rhssOfAlts (CoAlgAlts alts deflt) = rhssOfDeflt deflt ++ + [rhs | (_,_,rhs) <- alts] +rhssOfAlts (CoPrimAlts alts deflt) = rhssOfDeflt deflt ++ + [rhs | (_,rhs) <- alts] +rhssOfDeflt CoNoDefault = [] +rhssOfDeflt (CoBindDefault _ rhs) = [rhs] +\end{code} + +Eta reduction on type lambdas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have a go at doing + + /\a -> a ===> + +where doesn't mention a. +This is sometimes quite useful, because we can get the sequence: + + f ab d = let d1 = ...d... in + letrec f' b x = ...d...(f' b)... in + f' b +specialise ==> + + f.Int b = letrec f' b x = ...dInt...(f' b)... in + f' b + +float ==> + + f' b x = ...dInt...(f' b)... + f.Int b = f' b + +Now we really want to simplify to + + f.Int = f' + +and then replace all the f's with f.Ints. + +N.B. We are careful not to partially eta-reduce a sequence of type +applications since this breaks the specialiser: + + /\ a -> f Char# a =NO=> f Char# + +\begin{code} +mkCoTyLamTryingEta :: [TyVar] -> PlainCoreExpr -> PlainCoreExpr + +mkCoTyLamTryingEta tyvars tylam_body + = if + tyvars == tyvar_args && -- Same args in same order + check_fun fun -- Function left is ok + then + -- Eta reduction worked + fun + else + -- The vastly common case + mkCoTyLam tyvars tylam_body + where + (tyvar_args, fun) = strip_tyvar_args [] tylam_body + + strip_tyvar_args args_so_far tyapp@(CoTyApp fun ty) + = case getTyVarMaybe ty of + Just tyvar_arg -> strip_tyvar_args (tyvar_arg:args_so_far) fun + Nothing -> (args_so_far, tyapp) + + strip_tyvar_args args_so_far fun + = (args_so_far, fun) + + check_fun (CoVar f) = True -- Claim: tyvars not mentioned by type of f + check_fun other = False + +{- OLD: +mkCoTyLamTryingEta :: TyVar -> PlainCoreExpr -> PlainCoreExpr + +mkCoTyLamTryingEta tyvar body + = case body of + CoTyApp fun ty -> + case getTyVarMaybe ty of + Just tyvar' | tyvar == tyvar' && + ok fun -> fun + -- Ha! So it's /\ a -> fun a, and fun is "ok" + + other -> CoTyLam tyvar body + other -> CoTyLam tyvar body + where + is_elem = isIn "mkCoTyLamTryingEta" + + ok :: PlainCoreExpr -> Bool -- Returns True iff the expression doesn't + -- mention tyvar + + ok (CoVar v) = True -- Claim: tyvar not mentioned by type of v + ok (CoApp fun arg) = ok fun -- Claim: tyvar not mentioned by type of arg + ok (CoTyApp fun ty) = not (tyvar `is_elem` extractTyVarsFromTy ty) && + ok fun + ok other = False +-} +\end{code} + +Let to case +~~~~~~~~~~~ + +Given a type generate the case alternatives + + C a b -> C a b + +if there's one constructor, or + + x -> x + +if there's many, or if it's a primitive type. + + +\begin{code} +mkIdentityAlts + :: UniType -- type of RHS + -> SmplM InAlts -- result + +mkIdentityAlts rhs_ty + | isPrimType rhs_ty + = newId rhs_ty `thenSmpl` \ binder -> + returnSmpl (CoPrimAlts [] (CoBindDefault (binder, bad_occ_info) (CoVar binder))) + + | otherwise + = case getUniDataTyCon_maybe rhs_ty of + Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking + let + (_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args + in + newIds inst_con_arg_tys `thenSmpl` \ new_bindees -> + let + new_binders = [ (b, bad_occ_info) | b <- new_bindees ] + in + returnSmpl ( + CoAlgAlts + [(data_con, new_binders, CoCon data_con ty_args (map CoVarAtom new_bindees))] + CoNoDefault + ) + + _ -> -- Multi-constructor or abstract algebraic type + newId rhs_ty `thenSmpl` \ binder -> + returnSmpl (CoAlgAlts [] (CoBindDefault (binder,bad_occ_info) (CoVar binder))) + where + bad_occ_info = ManyOcc 0 -- Non-committal! +\end{code} + +\begin{code} +simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool + +simplIdWantsToBeINLINEd id env + = if switchIsSet env IgnoreINLINEPragma + then False + else idWantsToBeINLINEd id + +type_ok_for_let_to_case :: UniType -> Bool + +type_ok_for_let_to_case ty + = case getUniDataTyCon_maybe ty of + Nothing -> False + Just (tycon, ty_args, []) -> False + Just (tycon, ty_args, non_null_data_cons) -> True + -- Null data cons => type is abstract +\end{code} diff --git a/ghc/compiler/simplCore/SimplVar.hi b/ghc/compiler/simplCore/SimplVar.hi new file mode 100644 index 0000000..3edcc2e --- /dev/null +++ b/ghc/compiler/simplCore/SimplVar.hi @@ -0,0 +1,13 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplVar where +import CoreSyn(CoreArg, CoreExpr) +import Id(Id) +import SimplEnv(SimplEnv) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import UniType(UniType) +completeVar :: SimplEnv -> Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "U(LLLLL)U(LLLS)L" _N_ _N_ #-} +leastItCouldCost :: Int -> Int -> Int -> [Bool] -> [UniType] -> Int + {-# GHC_PRAGMA _A_ 5 _U_ 21111 _N_ _S_ "LLLSL" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs new file mode 100644 index 0000000..9cbbe56 --- /dev/null +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -0,0 +1,317 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplVar]{Simplifier stuff related to variables} + +\begin{code} +#include "HsVersions.h" + +module SimplVar ( + completeVar, + leastItCouldCost + ) where + +IMPORT_Trace + +import SimplMonad +import SimplEnv +import PlainCore +import TaggedCore +import BasicLit ( isNoRepLit ) + +import AbsUniType ( getUniDataTyCon, getUniDataTyCon_maybe, + getTyConFamilySize, isPrimType + ) +import BinderInfo ( oneTextualOcc, oneSafeOcc ) +import CgCompInfo ( uNFOLDING_USE_THRESHOLD, + uNFOLDING_CON_DISCOUNT_WEIGHT + ) +import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..) ) +import Id ( getIdUniType, getIdInfo ) +import IdInfo +import Maybes ( maybeToBool, Maybe(..) ) +import Simplify ( simplExpr ) +import SimplUtils ( simplIdWantsToBeINLINEd ) +import MagicUFs +import Pretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Simplify-var]{Completing variables} +%* * +%************************************************************************ + +This where all the heavy-duty unfolding stuff comes into its own. + +\begin{code} +completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr + +completeVar env var args + = let + boring_result = applyToArgs (CoVar var) args + in + case (lookupUnfolding env var) of + + LiteralForm lit + | not (isNoRepLit lit) + -- Inline literals, if they aren't no-repish things + -> ASSERT( null args ) + returnSmpl (CoLit lit) + + ConstructorForm con ty_args val_args + -- Always inline constructors. + -- See comments before completeLetBinding + -> ASSERT( null args ) + returnSmpl (CoCon con ty_args val_args) + + GeneralForm txt_occ form_summary template guidance + -> considerUnfolding env var args + txt_occ form_summary template guidance + + MagicForm str magic_fun + -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result -> + case result of + Nothing -> returnSmpl boring_result + Just magic_result -> + {- pprTrace "MagicForm:- " (ppAbove + (ppBesides [ + ppr PprDebug var, + ppr PprDebug args]) + (ppBesides [ + ppStr "AFTER :- ", + ppr PprDebug magic_result])) (returnSmpl ()) `thenSmpl` \ () -> + -} + tick MagicUnfold `thenSmpl_` + returnSmpl magic_result + + IWantToBeINLINEd _ -> returnSmpl boring_result + + other -> returnSmpl boring_result +\end{code} + + +%************************************************************************ +%* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +%* * +%************************************************************************ + +We have very limited information about an unfolding expression: (1)~so +many type arguments and so many value arguments expected---for our +purposes here, we assume we've got those. (2)~A ``size'' or ``cost,'' +a single integer. (3)~An ``argument info'' vector. For this, what we +have at the moment is a Boolean per argument position that says, ``I +will look with great favour on an explicit constructor in this +position.'' + +Assuming we have enough type- and value arguments (if not, we give up +immediately), then we see if the ``discounted size'' is below some +(semi-arbitrary) threshold. It works like this: for every argument +position where we're looking for a constructor AND WE HAVE ONE in our +hands, we get a (again, semi-arbitrary) discount [proportion to the +number of constructors in the type being scrutinized]. + +\begin{code} +considerUnfolding + :: SimplEnv + -> OutId -- Id we're thinking about + -> [OutArg] -- Applied to these + -> Bool -- If True then *always* inline, + -- because it's the only one + -> FormSummary + -> InExpr -- Template for unfolding; + -> UnfoldingGuidance -- To help us decide... + -> SmplM PlainCoreExpr -- Result! + +considerUnfolding env var args txt_occ form_summary template guidance + | switchIsOn sw_chkr EssentialUnfoldingsOnly + = dont_go_for_it -- we're probably in a hurry in this simpl round... + + | do_deforest + = pprTrace "" (ppBesides [ppStr "not attempting to unfold `", + ppr PprDebug var, + ppStr "' due to DEFOREST pragma"]) + dont_go_for_it + + | txt_occ + = go_for_it + + | (case form_summary of {BottomForm -> True; other -> False} && + not (any isPrimType [ ty | (TypeArg ty) <- args ])) + -- Always inline bottoming applications, unless + -- there's a primitive type lurking around... + = go_for_it + + | otherwise + = + -- If this is a deforestable Id, then don't unfold it (the deforester + -- will do it). + + case getInfo (getIdInfo var) of { + DoDeforest -> pprTrace "" (ppBesides [ppStr "not unfolding `", + ppr PprDebug var, + ppStr "' due to DEFOREST pragma"]) + dont_go_for_it; + Don'tDeforest -> + + case guidance of + UnfoldNever -> dont_go_for_it + + UnfoldAlways -> go_for_it + + EssentialUnfolding -> go_for_it + + UnfoldIfGoodArgs m_tys_wanted n_vals_wanted is_con_vec size + -> if m_tys_wanted > no_tyargs + || n_vals_wanted > no_valargs then + --pprTrace "dont_go_for_it1:" (ppAbove (ppr PprDebug guidance) (ppr PprDebug var)) + dont_go_for_it + + else if n_vals_wanted == 0 + && looks_like_a_data_val_to_me then + -- we are very keen on inlining data values + -- (see comments elsewhere); we ignore any size issues! + go_for_it + + else -- we try the fun stuff + let + discounted_size + = discountedCost env con_discount size no_valargs is_con_vec valargs + in + if discounted_size <= unfold_use_threshold then + go_for_it + else + --pprTrace "dont_go_for_it2:" (ppCat [ppr PprDebug var, ppInt size, ppInt discounted_size, ppInt unfold_use_threshold, ppr PprDebug guidance]) + dont_go_for_it + } + where + sw_chkr = getSwitchChecker env + + unfold_use_threshold + = case (intSwitchSet sw_chkr SimplUnfoldingUseThreshold) of + Nothing -> uNFOLDING_USE_THRESHOLD + Just xx -> xx + + con_discount -- ToDo: ************ get from a switch ********* + = uNFOLDING_CON_DISCOUNT_WEIGHT + + (tyargs, valargs, args_left) = decomposeArgs args + no_tyargs = length tyargs + no_valargs = length valargs + + looks_like_a_data_val_to_me + = let + (_,val_binders,body) = digForLambdas template + in + case (val_binders, body) of + ([], CoCon _ _ _) -> True + other -> False + + dont_go_for_it = returnSmpl (applyToArgs (CoVar var) args) + + go_for_it = --pprTrace "unfolding:" (ppCat [ppr PprDebug var, ppChar ':', ppr PprDebug template]) ( + tick UnfoldingDone `thenSmpl_` + simplExpr env template args + --) + +#if OMIT_DEFORESTER + do_deforest = False +#else + do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False } +#endif +\end{code} + +\begin{code} +type ArgInfoVector = [Bool] + +discountedCost + :: SimplEnv -- so we can look up things about the args + -> Int -- the discount for a "constructor" hit; + -- we multiply by the # of cons in the type. + -> 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*! + -> Int + + -- If we apply an expression (usually a function) of given "costs" + -- to a particular set of arguments (possibly none), what will + -- the resulting expression "cost"? + +discountedCost env con_discount_weight size no_args is_con_vec args + = ASSERT(no_args == length args) + disc (size - no_args) is_con_vec args + -- we start w/ a "discount" equal to the # of args... + where + disc size [] _ = size + disc size _ [] = size + + disc size (want_con_here:want_cons) (arg:rest_args) + = let + full_price = disc size + take_something_off v = let + (tycon, _, _) = getUniDataTyCon (getIdUniType v) + no_cons = case (getTyConFamilySize tycon) of + Just n -> n + reduced_size + = size - (no_cons * con_discount_weight) + in + disc reduced_size + in + (if not want_con_here then + full_price + else + case arg of + CoLitAtom _ -> full_price + CoVarAtom v -> case lookupUnfolding env v of + ConstructorForm _ _ _ -> take_something_off v + other_form -> full_price + + ) want_cons rest_args +\end{code} + +We use this one to avoid exporting inlinings that we ``couldn't possibly +use'' on the other side. Can be overridden w/ flaggery. +\begin{code} +leastItCouldCost + :: Int + -> Int -- the size/cost of the expr + -> Int -- number of value args + -> ArgInfoVector -- what we know about the *use* of the arguments + -> [UniType] -- NB: actual arguments *not* looked at; + -- but we know their types + -> Int + +leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys + = ASSERT(no_val_args == length arg_tys) + disc (size - no_val_args) is_con_vec arg_tys + -- we start w/ a "discount" equal to the # of args... + where + -- ToDo: rather sad that this isn't commoned-up w/ the one above... + + disc size [] _ = size + disc size _ [] = size + + disc size (want_con_here:want_cons) (arg_ty:rest_arg_tys) + = let + take_something_off tycon + = let + no_cons = case (getTyConFamilySize tycon) of { Just n -> n } + + reduced_size + = size - (no_cons * con_discount_weight) + in + reduced_size + in + if not want_con_here then + disc size want_cons rest_arg_tys + else + case (getUniDataTyCon_maybe arg_ty, isPrimType arg_ty) of + (Just (tycon, _, _), False) -> + disc (take_something_off tycon) want_cons rest_arg_tys + + other -> disc size want_cons rest_arg_tys +\end{code} + diff --git a/ghc/compiler/simplCore/Simplify.hi b/ghc/compiler/simplCore/Simplify.hi new file mode 100644 index 0000000..5e8effe --- /dev/null +++ b/ghc/compiler/simplCore/Simplify.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Simplify where +import BinderInfo(BinderInfo) +import CoreSyn(CoreArg, CoreBinding, CoreExpr) +import Id(Id) +import SimplEnv(SimplEnv) +import SimplMonad(SimplCount) +import SplitUniq(SplitUniqSupply) +import UniType(UniType) +simplBind :: SimplEnv -> CoreBinding (Id, BinderInfo) Id -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount) + {-# GHC_PRAGMA _A_ 4 _U_ 212222 _N_ _S_ "LSLL" _N_ _N_ #-} +simplExpr :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount) + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-} +simplTopBinds :: SimplEnv -> [CoreBinding (Id, BinderInfo) Id] -> SplitUniqSupply -> SimplCount -> ([CoreBinding Id Id], SimplCount) + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs new file mode 100644 index 0000000..7c21e22 --- /dev/null +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -0,0 +1,1222 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[Simplify]{The main module of the simplifier} + +\begin{code} +#include "HsVersions.h" + +module Simplify ( simplTopBinds, simplExpr, simplBind ) where + +import Pretty -- these are for debugging only +import Outputable + +import SimplMonad +import SimplEnv +import TaggedCore +import PlainCore + +import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..), + primOpOkForSpeculation, PrimOp(..), PrimKind, + realWorldStateTy + IF_ATTACK_PRAGMAS(COMMA realWorldTy) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType ( getUniDataTyCon_maybe, mkTyVarTy, applyTy, + splitTyArgs, splitTypeWithDictsAsArgs, + maybeUnpackFunTy, isPrimType + ) +import BasicLit ( isNoRepLit, BasicLit(..) ) +import BinderInfo +import CmdLineOpts ( SimplifierSwitch(..) ) +import ConFold ( completePrim ) +import Id +import IdInfo +import Maybes ( Maybe(..), catMaybes, maybeToBool ) +import SimplCase +import SimplUtils +import SimplVar ( completeVar ) +import Util +\end{code} + +The controlling flags, and what they do +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +passes: +------ +-fsimplify = run the simplifier +-ffloat-inwards = runs the float lets inwards pass +-ffloat = runs the full laziness pass + (ToDo: rename to -ffull-laziness) +-fupdate-analysis = runs update analyser +-fstrictness = runs strictness analyser +-fsaturate-apps = saturates applications (eta expansion) + +options: +------- +-ffloat-past-lambda = OK to do full laziness. + (ToDo: remove, as the full laziness pass is + useless without this flag, therefore + it is unnecessary. Just -ffull-laziness + should be kept.) + +-ffloat-lets-ok = OK to float lets out of lets if the enclosing + let is strict or if the floating will expose + a WHNF [simplifier]. + +-ffloat-primops-ok = OK to float out of lets cases whose scrutinee + is a primop that cannot fail [simplifier]. + +-fcode-duplication-ok = allows the previous option to work on cases with + multiple branches [simplifier]. + +-flet-to-case = does let-to-case transformation [simplifier]. + +-fcase-of-case = does case of case transformation [simplifier]. + +-fpedantic-bottoms = does not allow: + case x of y -> e ===> e[x/y] + (which may turn bottom into non-bottom) + + + NOTES ON INLINING + ~~~~~~~~~~~~~~~~~ + +Inlining is one of the delicate aspects of the simplifier. By +``inlining'' we mean replacing an occurrence of a variable ``x'' by +the RHS of x's definition. Thus + + let x = e in ...x... ===> let x = e in ...e... + +We have two mechanisms for inlining: + +1. Unconditional. The occurrence analyser has pinned an (OneOcc +FunOcc NoDupDanger NotInsideSCC n) flag on the variable, saying ``it's +certainly safe to inline this variable, and to drop its binding''. +(...Umm... if n <= 1; if n > 1, it is still safe, provided you are +happy to be duplicating code...) When it encounters such a beast, the +simplifer binds the variable to its RHS (in the id_env) and continues. +It doesn't even look at the RHS at that stage. It also drops the +binding altogether. + +2. Conditional. In all other situations, the simplifer simplifies +the RHS anyway, and keeps the new binding. It also binds the new +(cloned) variable to a ``suitable'' UnfoldingDetails in the UnfoldEnv. + +Here, ``suitable'' might mean NoUnfoldingDetails (if the occurrence +info is ManyOcc and the RHS is not a manifest HNF, or UnfoldAlways (if +the variable has an INLINE pragma on it). The idea is that anything +in the UnfoldEnv is safe to use, but also has an enclosing binding if +you decide not to use it. + +Head normal forms +~~~~~~~~~~~~~~~~~ +We *never* put a non-HNF unfolding in the UnfoldEnv except in the +INLINE-pragma case. + +At one time I thought it would be OK to put non-HNF unfoldings in for +variables which occur only once [if they got inlined at that +occurrence the RHS of the binding would become dead, so no duplication +would occur]. But consider: +@ + let x = + 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@. + +Becuase of this, the "unconditional-inline" mechanism above is the only way +in which non-HNFs can get inlined. + +INLINE pragmas +~~~~~~~~~~~~~~ + +When a variable has an INLINE pragma on it --- which includes wrappers +produced by the strictness analyser --- we treat it rather carefully. + +For a start, we are careful not to substitute into its RHS, because +that might make it BIG, and the user said "inline exactly this", not +"inline whatever you get after inlining other stuff inside me". For +example + + let f = BIG + in {-# INLINE y #-} y = f 3 + in ...y...y... + +Here we don't want to substitute BIG for the (single) occurrence of f, +because then we'd duplicate BIG when we inline'd y. (Exception: +things in the UnfoldEnv with UnfoldAlways flags, which originated in +other INLINE pragmas.) + +So, we clean out the UnfoldEnv of all GeneralForm inlinings before +going into such an RHS. + +What about imports? They don't really matter much because we only +inline relatively small things via imports. + +We augment the the UnfoldEnv with UnfoldAlways guidance if there's an +INLINE pragma. We also do this for the RHSs of recursive decls, +before looking at the recursive decls. That way we achieve the effect +of inlining a wrapper in the body of its worker, in the case of a +mutually-recursive worker/wrapper split. + + +%************************************************************************ +%* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +%* * +%************************************************************************ + +At the top level things are a little different. + + * No cloning (not allowed for exported Ids, unnecessary for the others) + + * No floating. Case floating is obviously out. Let floating is + theoretically OK, but dangerous because of space leaks. + The long-distance let-floater lifts these lets. + +\begin{code} +simplTopBinds :: SimplEnv -> [InBinding] -> SmplM [OutBinding] + +simplTopBinds env [] = returnSmpl [] + +-- Dead code is now discarded by the occurrence analyser, + +simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds) + | inlineUnconditionally ok_to_dup_code occ_info + = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) ( + let + new_env = extendIdEnvWithInlining env env binder rhs + in + simplTopBinds new_env binds + --) + where + ok_to_dup_code = switchIsSet env SimplOkToDupCode + +simplTopBinds env (CoNonRec binder@(in_id,occ_info) rhs : binds) + = -- No cloning necessary at top level + -- Process the binding + simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> + let + new_env = case rhs' of + CoVar var -> extendIdEnvWithAtom env binder (CoVarAtom var) + CoLit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (CoLitAtom lit) + other -> extendUnfoldEnvGivenRhs env binder in_id rhs' + in + --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) ( + + -- Process the other bindings + simplTopBinds new_env binds `thenSmpl` \ binds' -> + + -- Glue together and return ... + -- We leave it to susequent occurrence analysis to throw away + -- an unused atom binding. This localises the decision about + -- discarding top-level bindings. + returnSmpl (CoNonRec in_id rhs' : binds') + --) + +simplTopBinds env (CoRec 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 +\end{code} + +%************************************************************************ +%* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +%* * +%************************************************************************ + + +\begin{code} +simplExpr :: SimplEnv + -> InExpr -> [OutArg] + -> SmplM OutExpr +\end{code} + +The expression returned has the same meaning as the input expression +applied to the specified arguments. + + +Variables +~~~~~~~~~ +Check if there's a macro-expansion, and if so rattle on. Otherwise +do the more sophisticated stuff. + +\begin{code} +simplExpr env (CoVar v) args + = --pprTrace "simplExpr:Var:" (ppr PprDebug v) ( + case lookupId env v of + Nothing -> let + new_v = simplTyInId env v + in + completeVar env new_v args + + Just info -> + case info of + ItsAnAtom (CoLitAtom lit) -- A boring old literal + -- Paranoia check for args empty + -> case args of + [] -> returnSmpl (CoLit lit) + other -> panic "simplExpr:coVar" + + ItsAnAtom (CoVarAtom var) -- More interesting! An id! + -- No need to substitute the type env here, + -- because we already have! + -> completeVar env var 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 (CoLit l) [] = returnSmpl (CoLit l) +simplExpr env (CoLit l) _ = panic "simplExpr:CoLit with argument" +\end{code} + +Primitive applications are simple. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +NB: CoPrim expects an empty argument list! (Because it should be +saturated and not higher-order. ADR) + +\begin{code} +simplExpr env (CoPrim op tys prim_args) args + = ASSERT (null args) + let + tys' = [simplTy env ty | ty <- tys] + prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args] + op' = simpl_op op + in + completePrim env op' tys' prim_args' + where + -- PrimOps just need any types in them renamed. + + simpl_op (CCallOp label is_asm may_gc arg_tys result_ty) + = let + arg_tys' = map (simplTy env) arg_tys + result_ty' = simplTy env result_ty + in + CCallOp label is_asm may_gc arg_tys' result_ty' + + simpl_op other_op = other_op +\end{code} + +Constructor applications +~~~~~~~~~~~~~~~~~~~~~~~~ +Nothing to try here. We only reuse constructors when they appear as the +rhs of a let binding (see completeLetBinding). + +\begin{code} +simplExpr env (CoCon con tys con_args) args + = ASSERT( null args ) + returnSmpl (CoCon con tys' con_args') + where + con_args' = [simplAtom env con_arg | con_arg <- con_args] + tys' = [simplTy env ty | ty <- tys] +\end{code} + + +Applications are easy too: +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Just stuff 'em in the arg stack + +\begin{code} +simplExpr env (CoApp 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) +\end{code} + +Type lambdas +~~~~~~~~~~~~ + +We only eta-reduce a type lambda if all type arguments in the body can +be eta-reduced. This requires us to collect up all tyvar parameters so +we can pass them all to @mkCoTyLamTryingEta@. + +\begin{code} +simplExpr env (CoTyLam tyvar body) (TypeArg ty : args) + = ASSERT(not (isPrimType ty)) + let + new_env = extendTyEnv env tyvar ty + in + tick TyBetaReduction `thenSmpl_` + simplExpr new_env body args + +simplExpr env tylam@(CoTyLam tyvar body) [] + = do_tylambdas env [] tylam + where + do_tylambdas env tyvars' (CoTyLam tyvar body) + = -- Clone the type variable + cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> + let + new_env = extendTyEnv env tyvar (mkTyVarTy tyvar') + in + do_tylambdas new_env (tyvar':tyvars') body + + do_tylambdas env tyvars' body + = simplExpr env body [] `thenSmpl` \ body' -> + returnSmpl ( + (if switchIsSet env SimplDoEtaReduction + then mkCoTyLamTryingEta + else mkCoTyLam) (reverse tyvars') body' + ) + +simplExpr env (CoTyLam tyvar body) (ValArg _ : _) + = panic "simplExpr:CoTyLam ValArg" +\end{code} + + +Ordinary lambdas +~~~~~~~~~~~~~~~~ + +\begin{code} +simplExpr env (CoLam binders body) args + | null leftover_binders + = -- The lambda is saturated (or over-saturated) + tick BetaReduction `thenSmpl_` + simplExpr env_for_enough_args body leftover_args + + | otherwise + = -- Too few args to saturate the lambda + ASSERT( null leftover_args ) + + (if not (null args) -- ah, we must've gotten rid of some... + then tick BetaReduction + else returnSmpl (panic "BetaReduction") + ) `thenSmpl_` + + simplLam env_for_too_few_args leftover_binders body + 0 {- Guaranteed applied to at least 0 args! -} + + where + (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binders args + + env_for_enough_args = extendIdEnvWithAtomList env binder_args_pairs + + env_for_too_few_args = extendIdEnvWithAtomList env zapped_binder_args_pairs + + -- Since there aren't enough args the binders we are cancelling with + -- the args supplied are, in effect, ocurring inside a lambda. + -- So we modify their occurrence info to reflect this fact. + -- Example: (\ x y z -> e) p q + -- ==> (\z -> e[p/x, q/y]) + -- but we should behave as if x and y are marked "inside lambda". + -- The occurrence analyser does not mark them so itself because then we + -- do badly on the very common case of saturated lambdas applications: + -- (\ x y z -> e) p q r + -- ==> e[p/x, q/y, r/z] + -- + 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 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 CoLam +\end{code} + + +Let expressions +~~~~~~~~~~~~~~~ + +\begin{code} +simplExpr env (CoLet bind body) args + = simplBind env bind (\env -> simplExpr env body args) (computeResultType env body args) +\end{code} + +Case expressions +~~~~~~~~~~~~~~~~ + +\begin{code} +simplExpr env expr@(CoCase scrut alts) args + = simplCase env scrut alts (\env rhs -> simplExpr env rhs args) + (computeResultType env expr args) +\end{code} + + +Set-cost-centre +~~~~~~~~~~~~~~~ + +A special case we do: +\begin{verbatim} + scc "foo" (\x -> e) ===> \x -> scc "foo" e +\end{verbatim} +Simon thinks it's OK, at least for lexical scoping; and it makes +interfaces change less (arities). + +\begin{code} +simplExpr env (CoSCC cc (CoLam binders body)) args + = simplExpr env (CoLam binders (CoSCC cc body)) args + +simplExpr env (CoSCC cc (CoTyLam tyvar body)) args + = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args +\end{code} + +Some other slightly turgid SCC tidying-up cases: +\begin{code} +simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args + = simplExpr env expr args + -- the outer _scc_ serves no purpose + +simplExpr env (CoSCC cc expr) args + | squashableDictishCcExpr cc expr + = simplExpr env expr args + -- the DICT-ish CC is no longer serving any purpose +\end{code} + +NB: for other set-cost-centre we move arguments inside the body. +ToDo: check with Patrick that this is ok. + +\begin{code} +simplExpr env (CoSCC cost_centre body) args + = let + new_env = setEnclosingCC env (EnclosingCC cost_centre) + in + simplExpr new_env body args `thenSmpl` \ body' -> + returnSmpl (CoSCC cost_centre body') +\end{code} + +%************************************************************************ +%* * +\subsection{Simplify RHS of a Let/Letrec} +%* * +%************************************************************************ + +simplRhsExpr does arity-expansion. That is, given: + + * a right hand side /\ tyvars -> \a1 ... an -> e + * the information (stored in BinderInfo) that the function will always + be applied to at least k arguments + +it transforms the rhs to + + /\tyvars -> \a1 ... an b(n+1) ... bk -> (e b(n+1) ... bk) + +This is a Very Good Thing! + +\begin{code} +simplRhsExpr + :: SimplEnv + -> InBinder + -> InExpr + -> SmplM OutExpr + +simplRhsExpr env binder@(id,occ_info) rhs + | dont_eta_expand rhs + = simplExpr rhs_env rhs [] + + | otherwise -- Have a go at eta expansion + = -- Deal with the big lambda part + mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> + let + lam_env = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars')) + in + -- Deal with the little lambda part + -- Note that we call simplLam even if there are no binders, in case + -- it can do arity expansion. + simplLam lam_env binders body min_no_of_args `thenSmpl` \ lambda' -> + + -- Put it back together + returnSmpl ( + (if switchIsSet env SimplDoEtaReduction + then mkCoTyLamTryingEta + else mkCoTyLam) tyvars' lambda' + ) + where + -- Note from ANDY: + -- If you say {-# INLINE #-} then you get what's coming to you; + -- you are saying inline the rhs, please. + -- we might want a {-# INLINE UNSIMPLIFIED #-} option. + rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env + | otherwise = env + + (tyvars, binders, body) = digForLambdas rhs + + min_no_of_args | not (null binders) && -- It's not a thunk + switchIsSet env SimplDoArityExpand -- Arity expansion on + = getBinderInfoArity occ_info - length binders + + | otherwise -- Not a thunk + = 0 -- Play safe! + + -- dont_eta_expand prevents eta expansion in silly situations. + -- For example, consider the defn + -- x = y + -- It would be silly to eta expand the "y", because it would just + -- get eta-reduced back to y. Furthermore, if this was a top level defn, + -- and x was exported, then the defn won't be eliminated, so this + -- silly expand/reduce cycle will happen every time, which makes the + -- simplifier loop!. + -- The solution is to not even try eta expansion unless the rhs looks + -- non-trivial. + dont_eta_expand (CoLit _) = True + dont_eta_expand (CoVar _) = True + dont_eta_expand (CoTyApp f _) = dont_eta_expand f + dont_eta_expand (CoTyLam _ b) = dont_eta_expand b + dont_eta_expand (CoCon _ _ _) = True + dont_eta_expand _ = False +\end{code} + + +%************************************************************************ +%* * +\subsection{Simplify a lambda abstraction} +%* * +%************************************************************************ + +Simplify (\binders -> body) trying eta expansion and reduction, given that +the abstraction will always be applied to at least min_no_of_args. + +\begin{code} +simplLam env binders body min_no_of_args + | not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off + null potential_extra_binder_tys || -- or ain't a function + no_of_extra_binders == 0 -- or no extra binders needed + = cloneIds env binders `thenSmpl` \ binders' -> + let + new_env = extendIdEnvWithClones env binders binders' + in + simplExpr new_env body [] `thenSmpl` \ body' -> + returnSmpl ( + (if switchIsSet new_env SimplDoEtaReduction + then mkCoLamTryingEta + else mkCoLam) binders' body' + ) + + | otherwise -- Eta expansion possible + = tick EtaExpansion `thenSmpl_` + cloneIds env binders `thenSmpl` \ binders' -> + let + new_env = extendIdEnvWithClones env binders binders' + in + newIds extra_binder_tys `thenSmpl` \ extra_binders' -> + simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders') `thenSmpl` \ body' -> + returnSmpl ( + (if switchIsSet new_env SimplDoEtaReduction + then mkCoLamTryingEta + else mkCoLam) (binders' ++ extra_binders') body' + ) + + where + (potential_extra_binder_tys, res_ty) + = splitTyArgs (simplTy env (typeOfCoreExpr (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 + -- where wurble has a forall-type, but no big lambdas at the top. + -- We could be clever an insert new big lambdas, but we don't bother. + + extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys + + no_of_extra_binders = -- First, use the info about how many args it's + -- always applied to in its scope + min_no_of_args + + -- Next, try seeing if there's a lambda hidden inside + -- something cheap + `max` + etaExpandCount body + + -- Finally, see if it's a state transformer, in which + -- case we eta-expand on principle! This can waste work, + -- but usually doesn't + `max` + case potential_extra_binder_tys of + [ty] | ty == realWorldStateTy -> 1 + other -> 0 + +\end{code} + + +%************************************************************************ +%* * +\subsection[Simplify-let]{Let-expressions} +%* * +%************************************************************************ + +\begin{code} +simplBind :: SimplEnv + -> InBinding + -> (SimplEnv -> SmplM OutExpr) + -> OutUniType + -> SmplM OutExpr +\end{code} + +When floating cases out of lets, remember this: + + let x* = case e of alts + in + +where x* is sure to be demanded or e is a cheap operation that cannot +fail, e.g. unboxed addition. Here we should be prepared to duplicate +. A good example: + + let x* = case y of + p1 -> build e1 + p2 -> build e2 + in + foldr c n x* +==> + case y of + p1 -> foldr c n (build e1) + p2 -> foldr c n (build e2) + +NEW: We use the same machinery that we use for case-of-case to +*always* do case floating from let, that is we let bind and abstract +the original let body, and let the occurrence analyser later decide +whether the new let should be inlined or not. The example above +becomes: + +==> + let join_body x' = foldr c n x' + in case y of + p1 -> let x* = build e1 + in join_body x* + p2 -> let x* = build e2 + in join_body x* + +note that join_body is a let-no-escape. +In this particular example join_body will later be inlined, +achieving the same effect. +ToDo: check this is OK with andy + + + +\begin{code} +-- Dead code is now discarded by the occurrence analyser, + +simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty + | inlineUnconditionally ok_to_dup occ_info + = body_c (extendIdEnvWithInlining env env binder rhs) + +-- Try let-to-case +-- It's important to try let-to-case before floating. Consider +-- +-- let a*::Int = case v of {p1->e1; p2->e2} +-- in b +-- +-- (The * means that a is sure to be demanded.) +-- If we do case-floating first we get this: +-- +-- let k = \a* -> b +-- in case v of +-- p1-> let a*=e1 in k a +-- p2-> let a*=e2 in k a +-- +-- Now watch what happens if we do let-to-case first: +-- +-- case (case v of {p1->e1; p2->e2}) of +-- Int a# -> let a*=I# a# in b +-- ===> +-- let k = \a# -> let a*=I# a# in b +-- in case v of +-- p1 -> case e1 of I# a# -> k a# +-- p1 -> case e1 of I# a# -> k a# +-- +-- The latter is clearly better. (Remember the reboxing let-decl +-- for a is likely to go away, because after all b is strict in a.) + + | will_be_demanded && + try_let_to_case && + type_ok_for_let_to_case rhs_ty && + not (manifestlyWHNF rhs) + -- note: no "manifestlyBottom rhs" in there... (comment below) + = tick Let2Case `thenSmpl_` + mkIdentityAlts rhs_ty `thenSmpl` \ id_alts -> + simplCase env rhs id_alts (\env rhs -> done_float env rhs body_c) body_ty + {- + We do not do let to case for WHNFs, e.g. + + let x = a:b in ... + =/=> + case a:b of x in ... + + as this is less efficient. + but we don't mind doing let-to-case for "bottom", as that + will + allow us to remove more dead code, if anything: + let x = error in ... + ===> + case error of x -> ... + ===> + error + + Notice that let to case occurs only if x is used strictly in + its body (obviously). + -} + + | will_be_demanded || + always_float_let_from_let || + floatExposesHNF float_lets float_primops ok_to_dup rhs + = try_float env rhs body_c + + | otherwise + = done_float env rhs body_c + + where + will_be_demanded = willBeDemanded (getIdDemandInfo id) + rhs_ty = getIdUniType id + + float_lets = switchIsSet env SimplFloatLetsExposingWHNF + float_primops = switchIsSet env SimplOkToFloatPrimOps + ok_to_dup = switchIsSet env SimplOkToDupCode + always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets + try_let_to_case = switchIsSet env SimplLetToCase + + ------------------------------------------- + done_float env rhs body_c + = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> + completeLet env binder rhs rhs' body_c body_ty + + --------------------------------------- + try_float env (CoLet bind rhs) body_c + = tick LetFloatFromLet `thenSmpl_` + simplBind env (fix_up_demandedness will_be_demanded bind) + (\env -> try_float env rhs body_c) body_ty + + try_float env (CoCase scrut alts) body_c + | will_be_demanded || (float_primops && is_cheap_prim_app scrut) + = tick CaseFloatFromLet `thenSmpl_` + + -- First, bind large let-body if necessary + if no_need_to_bind_large_body then + simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty + else + bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) -> + let + body_c' = \env -> simplExpr env new_body [] + in + simplCase env scrut alts + (\env rhs -> try_float env rhs body_c') + body_ty `thenSmpl` \ case_expr -> + + returnSmpl (CoLet extra_binding case_expr) + where + no_need_to_bind_large_body + = ok_to_dup || isSingleton (nonErrorRHSs alts) + + try_float env other_rhs body_c = done_float env other_rhs body_c +\end{code} + +Letrec expressions +~~~~~~~~~~~~~~~~~~ + +Simplify each RHS, float any let(recs) from the RHSs (if let-floating is +on and it'll expose a HNF), and bang the whole resulting mess together +into a huge letrec. + +1. Any "macros" should be expanded. The main application of this +macro-expansion is: + + letrec + f = ....g... + g = ....f... + in + ....f... + +Here we would like the single call to g to be inlined. + +We can spot this easily, because g will be tagged as having just one +occurrence. The "inlineUnconditionally" predicate is just what we want. + +A worry: could this lead to non-termination? For example: + + letrec + f = ...g... + g = ...f... + h = ...h... + in + ..h.. + +Here, f and g call each other (just once) and neither is used elsewhere. +But it's OK: + +* the occurrence analyser will drop any (sub)-group that isn't used at + all. + +* If the group is used outside itself (ie in the "in" part), then there + can't be a cyle. + +** IMPORTANT: check that NewOccAnal has the property that a group of + bindings like the above has f&g dropped.! *** + + +2. We'd also like to pull out any top-level let(rec)s from the +rhs of the defns: + + letrec + f = let h = ... in \x -> ....h...f...h... + in + ...f... +====> + letrec + h = ... + f = \x -> ....h...f...h... + in + ...f... + +But floating cases is less easy? (Don't for now; ToDo?) + + +3. We'd like to arrange that the RHSs "know" about members of the +group that are bound to constructors. For example: + + let rec + d.Eq = (==,/=) + f a b c d = case d.Eq of (h,_) -> let x = (a,b); y = (c,d) in not (h x y) + /= a b = unpack tuple a, unpack tuple b, call f + in d.Eq + +here, by knowing about d.Eq in f's rhs, one could get rid of +the case (and break out the recursion completely). +[This occurred with more aggressive inlining threshold (4), +nofib/spectral/knights] + +How to do it? + 1: we simplify constructor rhss first. + 2: we record the "known constructors" in the environment + 3: we simplify the other rhss, with the knowledge about the constructors + + + +\begin{code} +simplBind env (CoRec pairs) body_c body_ty + = -- Do floating, if necessary + (if float_lets || always_float_let_from_let + then + mapSmpl float pairs `thenSmpl` \ floated_pairs_s -> + returnSmpl (concat floated_pairs_s) + else + returnSmpl pairs + ) `thenSmpl` \ floated_pairs -> + let + binders = map fst floated_pairs + in + cloneIds env binders `thenSmpl` \ ids' -> + let + env_w_clones = extendIdEnvWithClones env binders ids' + triples = ids' `zip` floated_pairs + in + + simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) -> + + body_c new_env `thenSmpl` \ body' -> + + returnSmpl (CoLet binding body') + + where + ------------ Floating stuff ------------------- + + float_lets = switchIsSet env SimplFloatLetsExposingWHNF + always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets + + float (binder,rhs) + = let + pairs_s = float_pair (binder,rhs) + in + case pairs_s of + [_] -> returnSmpl pairs_s + more_than_one + -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_` + -- It's important to increment the tick counts if we + -- do any floating. A situation where this turns out + -- to be important is this: + -- Float in produces: + -- letrec x = let y = Ey in Ex + -- in B + -- Now floating gives this: + -- letrec x = Ex + -- y = Ey + -- in B + --- We now want to iterate once more in case Ey doesn't + -- mention x, in which case the y binding can be pulled + -- out as an enclosing let(rec), which in turn gives + -- the strictness analyser more chance. + returnSmpl pairs_s + + float_pairs pairs = concat (map float_pair pairs) + + float_pair (binder, rhs) + | always_float_let_from_let || + floatExposesHNF True False False rhs + = (binder,rhs') : pairs' + + | otherwise + = [(binder,rhs)] + where + (pairs', rhs') = do_float rhs + + -- Float just pulls out any top-level let(rec) bindings + do_float :: InExpr -> ([(InBinder,InExpr)], InExpr) + do_float (CoLet (CoRec pairs) body) = (float_pairs pairs ++ pairs', body') + where + (pairs', body') = do_float body + do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body') + where + (pairs', body') = do_float body + do_float other = ([], other) + +simplRecursiveGroup env triples + = -- Toss out all the dead pairs? No, there shouldn't be any! + -- Dead code is discarded by the occurrence analyser + let + -- Separate the live triples into "inline"able and + -- "ordinary" We're paranoid about duplication! + (inline_triples, ordinary_triples) + = partition is_inline_triple triples + + is_inline_triple (_, ((_,occ_info),_)) + = inlineUnconditionally False {-not ok_to_dup-} occ_info + + -- Now add in the inline_pairs info (using "env_w_clones"), + -- so that we will save away suitably-clone-laden envs + -- inside the InlineIts...). + + -- NOTE ALSO that we tie a knot here, because the + -- saved-away envs must also include these very inlinings + -- (they aren't stored anywhere else, and a late one might + -- be used in an early one). + + env_w_inlinings = foldl add_inline env inline_triples + + add_inline env (id', (binder,rhs)) + = extendIdEnvWithInlining env env_w_inlinings binder rhs + + -- Separate the remaining bindings into the ones which + -- need to be dealt with first (the "early" ones) + -- and the others (the "late" ones) + (early_triples, late_triples) + = partition is_early_triple ordinary_triples + + is_early_triple (_, (_, CoCon _ _ _)) = 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' -> + + -- Now further extend the environment to record our knowledge + -- about the form of the binders bound in the constructor bindings + let + env_w_early_info = foldr add_early_info env_w_inlinings early_triples' + add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs' + in + -- Now process the non-constructor bindings + mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' -> + + -- Phew! We're done + let + binding = CoRec (map snd early_triples' ++ map snd late_triples') + in + returnSmpl (binding, env_w_early_info) + where + + do_one_binding env (id', (binder,rhs)) + = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> + returnSmpl (binder, (id', rhs')) +\end{code} + + +@completeLet@ looks at the simplified post-floating RHS of the +let-expression, and decides what to do. There's one interesting +aspect to this, namely constructor reuse. Consider +@ + f = \x -> case x of + (y:ys) -> y:ys + [] -> ... +@ +Is it a good idea to replace the rhs @y:ys@ with @x@? This depends a +bit on the compiler technology, but in general I believe not. For +example, here's some code from a real program: +@ +const.Int.max.wrk{-s2516-} = + \ upk.s3297# upk.s3298# -> + let { + a.s3299 :: Int + _N_ {-# U(P) #-} + a.s3299 = I#! upk.s3297# + } in + case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of { + _LT -> I#! upk.s3298# + _EQ -> a.s3299 + _GT -> a.s3299 + } +@ +The a.s3299 really isn't doing much good. We'd be better off inlining +it. (Actually, let-no-escapery means it isn't as bad as it looks.) + +So the current strategy is to inline all known-form constructors, and +only do the reverse (turn a constructor application back into a +variable) when we find a let-expression: +@ + let x = C a1 .. an + in + ... (let y = C a1 .. an in ...) ... +@ +where it is always good to ditch the binding for y, and replace y by +x. That's just what completeLetBinding does. + +\begin{code} +completeLet + :: SimplEnv + -> InBinder + -> InExpr -- Original RHS + -> OutExpr -- The simplified RHS + -> (SimplEnv -> SmplM OutExpr) -- Body handler + -> OutUniType -- Type of body + -> SmplM OutExpr + +completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty + + -- See if RHS is an atom, or a reusable constructor + | maybeToBool maybe_atomic_rhs + = let + new_env = extendIdEnvWithAtom env binder rhs_atom + in + tick atom_tick_type `thenSmpl_` + body_c new_env + + -- Maybe the rhs is an application of error, and sure to be demanded + | will_be_demanded && + maybeToBool maybe_error_app + = tick CaseOfError `thenSmpl_` + returnSmpl retyped_error_app + + -- The general case + | otherwise + = cloneId env binder `thenSmpl` \ id' -> + let + env1 = extendIdEnvWithClone env binder id' + new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs) + in + body_c new_env `thenSmpl` \ body' -> + returnSmpl (CoLet (CoNonRec id' new_rhs) body') + + where + will_be_demanded = willBeDemanded (getIdDemandInfo id) + try_to_reuse_constr = switchIsSet env SimplReuseCon + + Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs + + maybe_atomic_rhs :: Maybe (OutAtom, TickType) + -- If the RHS is atomic, we return Just (atom, tick type) + -- otherwise Nothing + + maybe_atomic_rhs + = case new_rhs of + CoVar var -> Just (CoVarAtom var, AtomicRhs) + + CoLit lit | not (isNoRepLit lit) + -> Just (CoLitAtom lit, AtomicRhs) + + CoCon con tys con_args + | try_to_reuse_constr + -- Look out for + -- let v = C args + -- in + --- ...(let w = C same-args in ...)... + -- Then use v instead of w. This may save + -- re-constructing an existing constructor. + -> case lookForConstructor env con tys con_args of + Nothing -> Nothing + Just var -> Just (CoVarAtom var, ConReused) + + other -> Nothing + + maybe_error_app = maybeErrorApp new_rhs (Just body_ty) + Just retyped_error_app = maybe_error_app +\end{code} + +%************************************************************************ +%* * +\subsection[Simplify-atoms]{Simplifying atoms} +%* * +%************************************************************************ + +\begin{code} +simplAtom :: SimplEnv -> InAtom -> OutAtom + +simplAtom env (CoLitAtom lit) = CoLitAtom lit + +simplAtom env (CoVarAtom id) + | isLocallyDefined id + = case lookupId env id of + Just (ItsAnAtom atom) -> atom + Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env)) + Nothing -> CoVarAtom id -- Must be an uncloned thing + + | otherwise + = -- Not locally defined, so no change + CoVarAtom id +\end{code} + + +%************************************************************************ +%* * +\subsection[Simplify-quickies]{Some local help functions} +%* * +%************************************************************************ + + +\begin{code} +-- fix_up_demandedness switches off the willBeDemanded Info field +-- for bindings floated out of a non-demanded let +fix_up_demandedness True {- Will be demanded -} bind + = bind -- Simple; no change to demand info needed +fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs) + = CoNonRec (un_demandify binder) rhs +fix_up_demandedness False {- May not be demanded -} (CoRec pairs) + = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs] + +un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info) + +is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op +is_cheap_prim_app other = False + +computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType +computeResultType env expr args + = do expr_ty' args + where + expr_ty = typeOfCoreExpr (unTagBinders expr) + expr_ty' = 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" +\end{code} + diff --git a/ghc/compiler/simplCore/simplifier.tib b/ghc/compiler/simplCore/simplifier.tib new file mode 100644 index 0000000..375724b --- /dev/null +++ b/ghc/compiler/simplCore/simplifier.tib @@ -0,0 +1,771 @@ +% Andre: +% +% - I'd like the transformation rules to appear clearly-identified in +% a box of some kind, so they can be distinguished from the examples. +% + + + +\documentstyle[slpj,11pt]{article} + +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + +\begin{document} + +\title{How to simplify matters} + +\author{Simon Peyton Jones and Andre Santos\\ +Department of Computing Science, University of Glasgow, G12 8QQ \\ + @simonpj@@dcs.glasgow.ac.uk@ +} + +\maketitle + + +\section{Motivation} + +Quite a few compilers use the {\em compilation by transformation} idiom. +The idea is that as much of possible of the compilation process is +expressed as correctness-preserving transformations, each of which +transforms a program into a semantically-equivalent +program that (hopefully) executes more quickly or in less space. +Functional languages are particularly amenable to this approach because +they have a particularly rich family of possible transformations. +Examples of transformation-based compilers +include the Orbit compiler,[.kranz orbit thesis.] +Kelsey's compilers,[.kelsey thesis, hudak kelsey principles 1989.] +the New Jersey SML compiler,[.appel compiling with continuations.] +and the Glasgow Haskell compiler.[.ghc JFIT.] Of course many, perhaps most, +other compilers also use transformation to some degree. + +Compilation by transformation uses automatic transformations; that is, those +which can safely be applied automatically by a compiler. There +is also a whole approach to programming, which we might call {\em programming by transformation}, +in which the programmer manually transforms an inefficient specification into +an efficient program. This development process might be supported by +a programming environment in which does the book keeping, but the key steps +are guided by the programmer. We focus exclusively on automatic transformations +in this paper. + +Automatic program transformations seem to fall into two broad categories: +\begin{itemize} +\item {\bf Glamorous transformations} are global, sophisticated, +intellectually satisfying transformations, sometimes guided by some +interesting kind of analysis. +Examples include: +lambda lifting,[.johnsson lambda lifting.] +full laziness,[.hughes thesis, lester spe.] +closure conversion,[.appel jim 1989.] +deforestation,[.wadler 1990 deforestation, marlow wadler deforestation Glasgow92, chin phd 1990 march, gill launchbury.] +transformations based on strictness analysis,[.peyton launchbury unboxed.] +and so on. It is easy to write papers about these sorts of transformations. + +\item {\bf Humble transformations} are small, simple, local transformations, +which individually look pretty trivial. Here are two simple examples\footnote{ +The notation @E[]@ stands for an arbitrary expression with zero or more holes. +The notation @E[e]@ denotes @E[]@ with the holes filled in by the expression @e@. +We implicitly assume that no name-capture happens --- it's just +a short-hand, not an algorithm. +}: +@ + let x = y in E[x] ===> E[y] + + case (x:xs) of ===> E1[x,xs] + (y:ys) -> E1[y,ys] + [] -> E2 +@ +Transformations of this kind are almost embarassingly simple. How could +anyone write a paper about them? +\end{itemize} +This paper is about humble transformations, and how to implement them. +Although each individual +transformation is simple enough, there is a scaling issue: +there are a large number of candidate transformations to consider, and +there are a very large number of opportunities to apply them. + +In the Glasgow Haskell compiler, all humble transformations +are performed by the so-called {\em simplifier}. +Our goal in this paper is to give an overview of how the simplifier works, what +transformations it applies, and what issues arose in its design. + +\section{The language} + +Mutter mutter. Important points: +\begin{itemize} +\item Second order lambda calculus. +\item Arguments are variables. +\item Unboxed data types, and unboxed cases. +\end{itemize} +Less important points: +\begin{itemize} +\item Constructors and primitives are saturated. +\item if-then-else desugared to @case@ +\end{itemize} + +Give data type. + +\section{Transformations} + +This section lists all the transformations implemented by the simplifier. +Because it is a complete list, it is a long one. +We content ourselves with a brief statement of each transformation, +augmented with forward references to Section~\ref{sect:composing} +which gives examples of the ways in which the transformations can compose together. + +\subsection{Beta reduction} + +If a lambda abstraction is applied to an argument, we can simply +beta-reduce. This applies equally to ordinary lambda abstractions and +type abstractions: +@ + (\x -> E[x]) arg ===> E[arg] + (/\a -> E[a]) ty ===> E[ty] +@ +There is no danger of duplicating work because the argument is +guaranteed to be a simple variable or literal. + +\subsubsection{Floating applications inward} + +Applications can be floated inside a @let(rec)@ or @case@ expression. +This is a good idea, because they might find a lambda abstraction inside +to beta-reduce with: +@ + (let(rec) Bind in E) arg ===> let(rec) Bind in (E arg) + + (case E of {P1 -> E1;...; Pn -> En}) arg + ===> + case E of {P1 -> E1 arg; ...; Pn -> En arg} +@ + + + +\subsection{Transformations concerning @let(rec)@} + +\subsubsection{Floating @let@ out of @let@} + +It is sometimes useful to float a @let(rec)@ out of a @let(rec)@ right-hand +side: +@ + let x = let(rec) Bind in B1 ===> let(rec) Bind in + in B2 let x = B1 + in B2 + + + letrec x = let(rec) Bind in B1 ===> let(rec) Bind + in B2 x = B1 + in B2 +@ + +\subsubsection{Floating @case@ out of @let@} + + +\subsubsection{@let@ to @case@} + + +\subsection{Transformations concerning @case@} + +\subsubsection{Case of known constructor} + +If a @case@ expression scrutinises a constructor, +the @case@ can be eliminated. This transformation is a real +win: it eliminates a whole @case@ expression. +@ + case (C a1 .. an) of ===> E[a1..an] + ... + C b1 .. bn -> E[b1..bn] + ... +@ +If none of the constructors in the alternatives match, then +the default is taken: +@ + case (C a1 .. an) of ===> let y = C a1 .. an + ...[no alt matches C]... in E + y -> E +@ +There is an important variant of this transformation when +the @case@ expression scrutinises a {\em variable} +which is known to be bound to a constructor. +This situation can +arise for two reasons: +\begin{itemize} +\item An enclosing @let(rec)@ binding binds the variable to a constructor. +For example: +@ + let x = C p q in ... (case x of ...) ... +@ +\item An enclosing @case@ expression scrutinises the same variable. +For example: +@ + case x of + ... + C p q -> ... (case x of ...) ... + ... +@ +This situation is particularly common, as we discuss in Section~\ref{sect:repeated-evals}. +\end{itemize} +In each of these examples, @x@ is known to be bound to @C p q@ +at the inner @case@. The general rules are: +@ + case x of {...; C b1 .. bn -> E[b1..bn]; ...} +===> {x bound to C a1 .. an} + E[a1..an] + + case x of {...[no alts match C]...; y -> E[y]} +===> {x bound to C a1 .. an} + E[x] +@ + +\subsubsection{Dead alternative elimination} +@ + case x of + C a .. z -> E + ...[other alts]... +===> x *not* bound to C + case x of + ...[other alts]... +@ +We might know that @x@ is not bound to a particular constructor +because of an enclosing case: +@ + case x of + C a .. z -> E1 + other -> E2 +@ +Inside @E1@ we know that @x@ is bound to @C@. +However, if the type has more than two constructors, +inside @E2@ all we know is that @x@ is {\em not} bound to @C@. + +This applies to unboxed cases also, in the obvious way. + +\subsubsection{Case elimination} + +If we can prove that @x@ is not bottom, then this rule applies. +@ + case x of ===> E[x] + y -> E[y] +@ +We might know that @x@ is non-bottom because: +\begin{itemize} +\item @x@ has an unboxed type. +\item There's an enclosing case which scrutinises @x@. +\item It is bound to an expression which provably terminates. +\end{itemize} +Since this transformation can only improve termination, even if we apply it +when @x@ is not provably non-bottom, we provide a compiler flag to +enable it all the time. + +\subsubsection{Case of error} + +@ + case (error ty E) of Alts ===> error ty' E + where + ty' is type of whole case expression +@ + +Mutter about types. Mutter about variables bound to error. +Mutter about disguised forms of error. + +\subsubsection{Floating @let(rec)@ out of @case@} + +A @let(rec)@ binding can be floated out of a @case@ scrutinee: +@ + case (let(rec) Bind in E) of Alts ===> let(rec) Bind in + case E of Alts +@ +This increases the likelihood of a case-of-known-constructor transformation, +because @E@ is not hidden from the @case@ by the @let(rec)@. + +\subsubsection{Floating @case@ out of @case@} + +Analogous to floating a @let(rec)@ from a @case@ scrutinee is +floating a @case@ from a @case@ scrutinee. We have to be +careful, though, about code size. If there's only one alternative +in the inner case, things are easy: +@ + case (case E of {P -> R}) of ===> case E of {P -> case R of + Q1 -> S1 Q1 -> S1 + ... ... + Qm -> Sm Qm -> Sm} +@ +If there's more than one alternative there's a danger +that we'll duplicate @S1@...@Sm@, which might be a lot of code. +Our solution is to create a new local definition for each +alternative: +@ + case (case E of {P1 -> R1; ...; Pn -> Rn}) of + Q1 -> S1 + ... + Qm -> Sm +===> + let s1 = \x1 ... z1 -> S1 + ... + sm = \xm ... zm -> Sm + in + case E of + P1 -> case R1 of {Q1 -> s1 x1 ... z1; ...; Qm -> sm xm ... zm} + ... + Pn -> case Rn of {Q1 -> s1 x1 ... z1; ...; Qm -> sm xm ... zm} +@ +Here, @x1 ... z1@ are that subset of +variables bound by the pattern @Q1@ which are free in @S1@, and +similarly for the other @si@. + +Is this transformation a win? After all, we have introduced @m@ new +functions! Section~\ref{sect:join-points} discusses this point. + +\subsubsection{Case merging} + +@ + case x of + ...[some alts]... + other -> case x of + ...[more alts]... +===> + case x of + ...[some alts]... + ...[more alts]... +@ +Any alternatives in @[more alts]@ which are already covered by @[some alts]@ +should first be eliminated by the dead-alternative transformation. + + +\subsection{Constructor reuse} + + +\subsection{Inlining} + +The inlining transformtion is simple enough: +@ + let x = R in B[x] ===> B[R] +@ +Inlining is more conventionally used to describe the instantiation of a function +body at its call site, with arguments substituted for formal parameters. We treat +this as a two-stage process: inlining followed by beta reduction. Since we are +working with a higher-order language, not all the arguments may be available at every +call site, so separating inlining from beta reduction allows us to concentrate on +one problem at a time. + +The choice of exactly {\em which} bindings to inline has a major impact on efficiency. +Specifically, we need to consider the following factors: +\begin{itemize} +\item +Inlining a function at its call site, followed by some beta reduction, +very often exposes opportunities for further transformations. +We inline many simple arithmetic and boolean operators for this reason. +\item +Inlining can increase code size. +\item +Inlining can duplicate work, for example if a redex is inlined at more than one site. +Duplicating a single expensive redex can ruin a program's efficiency. +\end{itemize} + + +Our inlining strategy depends on the form of @R@: + +Mutter mutter. + + +\subsubsection{Dead code removal} + +If a @let@-bound variable is not used the binding can be dropped: +@ + let x = E in B ===> B + x not free in B +@ +A similar transformation applies for @letrec@-bound variables. +Programmers seldom write dead code, of course, but bindings often become dead when they +are inlined. + + + + +\section{Composing transformations} +\label{sect:composing} + +The really interesting thing about humble transformations is the way in which +they compose together to carry out substantial and useful transformations. +This section gives a collection of motivating examples, all of which have +shown up in real application programs. + +\subsection{Repeated evals} +\label{sect:repeated-evals} + +Example: x+x, as in unboxed paper. + + +\subsection{Lazy pattern matching} + +Lazy pattern matching is pretty inefficient. Consider: +@ + let (x,y) = E in B +@ +which desugars to: +@ + let t = E + x = case t of (x,y) -> x + y = case t of (x,y) -> y + in B +@ +This code allocates three thunks! However, if @B@ is strict in {\em either} +@x@ {\em or} @y@, then the strictness analyser will easily spot that +the binding for @t@ is strict, so we can do a @let@-to-@case@ transformation: +@ + case E of + (x,y) -> let t = (x,y) in + let x = case t of (x,y) -> x + y = case t of (x,y) -> y + in B +@ +whereupon the case-of-known-constructor transformation +eliminates the @case@ expressions in the right-hand side of @x@ and @y@, +and @t@ is then spotted as being dead, so we get +@ + case E of + (x,y) -> B +@ + +\subsection{Join points} +\label{sect:join-points} + +One motivating example is this: +@ + if (not x) then E1 else E2 +@ +After desugaring the conditional, and inlining the definition of +@not@, we get +@ + case (case x of True -> False; False -> True}) of + True -> E1 + False -> E2 +@ +Now, if we apply our case-of-case transformation we get: +@ + let e1 = E1 + e2 = E2 + in + case x of + True -> case False of {True -> e1; False -> e2} + False -> case True of {True -> e1; False -> e2} +@ +Now the case-of-known constructor transformation applies: +@ + let e1 = E1 + e2 = E2 + in + case x of + True -> e2 + False -> e1 +@ +Since there is now only one occurrence of @e1@ and @e2@ we can +inline them, giving just what we hoped for: +@ + case x of {True -> E2; False -> E1} +@ +The point is that the local definitions will often disappear again. + +\subsubsection{How join points occur} + +But what if they don't disappear? Then the definitions @s1@ ... @sm@ +play the role of ``join points''; they represent the places where +execution joins up again, having forked at the @case x@. The +``calls'' to the @si@ should really be just jumps. To see this more clearly +consider the expression +@ + if (x || y) then E1 else E2 +@ +A C compiler will ``short-circuit'' the +evaluation of the condition if @x@ turns out to be true +generate code, something like this: +@ + if (x) goto l1; + if (y) {...code for E2...} + l1: ...code for E1... +@ +In our setting, here's what will happen. First we desguar the +conditional, and inline the definition of @||@: +@ + case (case x of {True -> True; False -> y}) of + True -> E1 + False -> E2 +@ +Now apply the case-of-case transformation: +@ + let e1 = E1 + e2 = E2 + in + case x of + True -> case True of {True -> e1; False -> e2} + False -> case y of {True -> e1; False -> e2} +@ +Unlike the @not@ example, only one of the two inner case +simplifies, and we can therefore only inline @e2@, because +@e1@ is still mentioned twice\footnote{Unless the +inlining strategy decides that @E1@ is small enough to duplicate; +it is used in separate @case@ branches so there's no concern about duplicating +work. Here's another example of the way in which we make one part of the +simplifier (the inlining strategy) help with the work of another (@case@-expression +simplification.} +@ + let e1 = E1 + in + case x of + True -> e1 + False -> case y of {True -> e1; False -> e2} +@ +The code generator produces essentially the same code as +the C code given above. The binding for @e1@ turns into +just a label, which is jumped to from the two occurrences of @e1@. + +\subsubsection{Case of @error@} + +The case-of-error transformation is often exposed by the case-of-case +transformation. Consider +@ + case (hd xs) of + True -> E1 + False -> E2 +@ +After inlining @hd@, we get +@ + case (case xs of [] -> error "hd"; (x:_) -> x) of + True -> E1 + False -> E2 +@ +(I've omitted the type argument of @error@ to save clutter.) +Now doing case-of-case gives +@ + let e1 = E1 + e2 = E2 + in + case xs of + [] -> case (error "hd") of { True -> e1; False -> e2 } + (x:_) -> case x of { True -> e1; False -> e2 } +@ +Now the case-of-error transformation springs to life, after which +we can inline @e1@ and @e2@: +@ + case xs of + [] -> error "hd" + (x:_) -> case x of {True -> E1; False -> E2} +@ + +\subsection{Nested conditionals combined} + +Sometimes programmers write something which should be done +by a single @case@ as a sequence of tests: +@ + if x==0::Int then E0 else + if x==1 then E1 else + E2 +@ +After eliminating some redundant evals and doing the case-of-case +transformation we get +@ + case x of I# x# -> + case x# of + 0# -> E0 + other -> case x# of + 1# -> E1 + other -> E2 +@ +The case-merging transformation puts these together to get +@ + case x of I# x# -> + case x# of + 0# -> E0 + 1# -> E1 + other -> E2 +@ +Sometimes the sequence of tests cannot be eliminated from the source +code because of overloading: +@ + f :: Num a => a -> Bool + f 0 = True + f 3 = True + f n = False +@ +If we specialise @f@ to @Int@ we'll get the previous example again. + +\subsection{Error tests eliminated} + +The elimination of redundant alternatives, and then of redundant cases, +arises when we inline functions which do error checking. A typical +example is this: +@ + if (x `rem` y) == 0 then (x `div` y) else y +@ +Here, both @rem@ and @div@ do an error-check for @y@ being zero. +The second check is eliminated by the transformations. +After transformation the code becomes: +@ + case x of I# x# -> + case y of I# y# -> + case y of + 0# -> error "rem: zero divisor" + _ -> case x# rem# y# of + 0# -> case x# div# y# of + r# -> I# r# + _ -> y +@ + +\subsection{Atomic arguments} + +At this point it is possible to appreciate the usefulness of +the Core-language syntax requirement that arguments are atomic. +For example, suppose that arguments could be arbitrary expressions. +Here is a possible transformation: +@ + f (case x of (p,q) -> p) +===> f strict in its second argument + case x of (p,q) -> f (p,p) +@ +Doing this transformation would be useful, because now the +argument to @f@ is a simple variable rather than a thunk. +However, if arguments are atomic, this transformation becomes +just a special case of floating a @case@ out of a strict @let@: +@ + let a = case x of (p,q) -> p + in f a +===> (f a) strict in a + case x of (p,q) -> let a=p in f a +===> + case x of (p,q) -> f p +@ +There are many examples of this kind. For almost any transformation +involving @let@ there is a corresponding one involving a function +argument. The same effect is achieved with much less complexity +by restricting function arguments to be atomic. + +\section{Design} + +Dependency analysis +Occurrence analysis + +\subsection{Renaming and cloning} + +Every program-transformation system has to worry about name capture. +For example, here is an erroneous transformation: +@ + let y = E + in + (\x -> \y -> x + y) (y+3) +===> WRONG! + let y = E + in + (\y -> (y+3) + y) +@ +The transformation fails because the originally free-occurrence +of @y@ in the argument @y+3@ has been ``captured'' by the @\y@-abstraction. +There are various sophisticated solutions to this difficulty, but +we adopted a very simple one: we uniquely rename every locally-bound identifier +on every pass of the simplifier. +Since we are in any case producing an entirely new program (rather than side-effecting +an existing one) it costs very little extra to rename the identifiers as we go. + +So our example would become +@ + let y = E + in + (\x -> \y -> x + y) (y+3) +===> WRONG! + let y1 = E + in + (\y2 -> (y1+3) + y2) +@ +The simplifier accepts as input a program which has arbitrary bound +variable names, including ``shadowing'' (where a binding hides an +outer binding for the same identifier), but it produces a program in +which every bound identifier has a distinct name. + +Both the ``old'' and ``new'' identifiers have type @Id@, but when writing +type signatures for functions in the simplifier we use the types @InId@, for +identifiers from the input program, and @OutId@ for identifiers from the output program: +@ + type InId = Id + type OutId = Id +@ +This nomenclature extends naturally to expressions: a value of type @InExpr@ is an +expression whose identifiers are from the input-program name-space, and similarly +@OutExpr@. + + +\section{The simplifier} + +The basic algorithm followed by the simplifier is: +\begin{enumerate} +\item Analyse: perform occurrence analysis and dependency analysis. +\item Simplify: apply as many transformations as possible. +\item Iterate: perform the above two steps repeatedly until no further transformations are possible. +(A compiler flag allows the programmer to bound the maximum number of iterations.) +\end{enumerate} +We make a effort to apply as many transformations as possible in Step +2. To see why this is a good idea, just consider a sequence of +transformations in which each transformation enables the next. If +each iteration of Step 2 only performs one transformation, then the +entire program will to be re-analysed by Step 1, and re-traversed by +Step 2, for each transformation of the sequence. Sometimes this is +unavoidable, but it is often possible to perform a sequence of +transformtions in a single pass. + +The key function, which simplifies expressions, has the following type: +@ + simplExpr :: SimplEnv + -> InExpr -> [OutArg] + -> SmplM OutExpr +@ +The monad, @SmplM@ can quickly be disposed of. It has only two purposes: +\begin{itemize} +\item It plumbs around a supply of unique names, so that the simplifier can +easily invent new names. +\item It gathers together counts of how many of each kind of transformation +has been applied, for statistical purposes. These counts are also used +in Step 3 to decide when the simplification process has terminated. +\end{itemize} + +The signature can be understood like this: +\begin{itemize} +\item The environment, of type @SimplEnv@, provides information about +identifiers bound by the enclosing context. +\item The second and third arguments together specify the expression to be simplified. +\item The result is the simplified expression, wrapped up by the monad. +\end{itemize} +The simplifier's invariant is this: +$$ +@simplExpr@~env~expr~[a_1,\ldots,a_n] = expr[env]~a_1~\ldots~a_n +$$ +That is, the expression returned by $@simplExpr@~env~expr~[a_1,\ldots,a_n]$ +is semantically equal (although hopefully more efficient than) +$expr$, with the renamings in $env$ applied to it, applied to the arguments +$a_1,\ldots,a_n$. + +\subsection{Application and beta reduction} + +The arguments are carried ``inwards'' by @simplExpr@, as an accumulating parameter. +This is a convenient way of implementing the transformations which float +arguments inside a @let@ and @case@. This list of pending arguments +requires a new data type, @CoreArg@, along with its ``in'' and ``out'' synonyms, +because an argument might be a type or an atom: +@ +data CoreArg bindee = TypeArg UniType + | ValArg (CoreAtom bindee) + +type InArg = CoreArg InId +type OutArg = CoreArg OutId +@ +The equations for applications simply apply +the environment to the argument (to handle renaming) and put the result +on the argument stack, tagged to say whether it is a type argument or value argument: +@ + simplExpr env (CoApp 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) +@ + + + + + + +\end{document} diff --git a/ghc/compiler/simplStg/LambdaLift.hi b/ghc/compiler/simplStg/LambdaLift.hi new file mode 100644 index 0000000..1ea1a64 --- /dev/null +++ b/ghc/compiler/simplStg/LambdaLift.hi @@ -0,0 +1,8 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface LambdaLift where +import Id(Id) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +liftProgram :: SplitUniqSupply -> [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs new file mode 100644 index 0000000..158ce90 --- /dev/null +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -0,0 +1,527 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[LambdaLift]{A STG-code lambda lifter} + +\begin{code} +#include "HsVersions.h" + +module LambdaLift ( liftProgram ) where + +import StgSyn + +import AbsUniType ( mkForallTy, splitForalls, glueTyArgs, + UniType, RhoType(..), TauType(..) + ) +import Bag +import Id ( mkSysLocal, getIdUniType, addIdArity, Id ) +import IdEnv +import Maybes +import SplitUniq +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import UniqSet +import Util +\end{code} + +This is the lambda lifter. It turns lambda abstractions into +supercombinators on a selective basis: + +* Let-no-escaped bindings are never lifted. That's one major reason + why the lambda lifter is done in STG. + +* Non-recursive bindings whose RHS is a lambda abstractions are lifted, + provided all the occurrences of the bound variable is in a function + postition. In this example, f will be lifted: + + let + f = \x -> e + in + ..(f a1)...(f a2)... + thus + + $f p q r x = e -- Supercombinator + + ..($f p q r a1)...($f p q r a2)... + + NOTE that the original binding is eliminated. + + But in this case, f won't be lifted: + + let + f = \x -> e + in + ..(g f)...(f a2)... + + Why? Because we have to heap-allocate a closure for f thus: + + $f p q r x = e -- Supercombinator + + let + f = $f p q r + in + ..(g f)...($f p q r a2).. + + so it might as well be the original lambda abstraction. + + We also do not lift if the function has an occurrence with no arguments, e.g. + + let + f = \x -> e + in f + + as this form is more efficient than if we create a partial application + + $f p q r x = e -- Supercombinator + + f p q r + +* Recursive bindings *all* of whose RHSs are lambda abstractions are + lifted iff + - all the occurrences of all the binders are in a function position + - there aren't ``too many'' free variables. + + Same reasoning as before for the function-position stuff. The ``too many + free variable'' part comes from considering the (potentially many) + recursive calls, which may now have lots of free vars. + +Recent Observations: +* 2 might be already ``too many'' variables to abstract. + The problem is that the increase in the number of free variables + of closures refering to the lifted function (which is always # of + abstracted args - 1) may increase heap allocation a lot. + Expeiments are being done to check this... +* We do not lambda lift if the function has at least one occurrence + without any arguments. This caused lots of problems. Ex: + h = \ x -> ... let y = ... + in let let f = \x -> ...y... + in f + ==> + f = \y x -> ...y... + h = \ x -> ... let y = ... + in f y + + now f y is a partial application, so it will be updated, and this + is Bad. + + +--- NOT RELEVANT FOR STG ---- +* All ``lone'' lambda abstractions are lifted. Notably this means lambda + abstractions: + - in a case alternative: case e of True -> (\x->b) + - in the body of a let: let x=e in (\y->b) +----------------------------- + +%************************************************************************ +%* * +\subsection[Lift-expressions]{The main function: liftExpr} +%* * +%************************************************************************ + +\begin{code} +liftProgram :: SplitUniqSupply -> [PlainStgBinding] -> [PlainStgBinding] +liftProgram us prog = concat (runLM Nothing us (mapLM liftTopBind prog)) + + +liftTopBind :: PlainStgBinding -> LiftM [PlainStgBinding] +liftTopBind (StgNonRec id rhs) + = dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) -> + returnLM (getScBinds rhs_info ++ [StgNonRec id rhs']) + +liftTopBind (StgRec pairs) + = mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> + returnLM ([co_rec_ify (StgRec (ids `zip` rhss') : + getScBinds (unionLiftInfos rhs_infos)) + ]) + where + (ids, rhss) = unzip pairs +\end{code} + + +\begin{code} +liftExpr :: PlainStgExpr + -> LiftM (PlainStgExpr, LiftInfo) + + +liftExpr expr@(StgConApp con args lvs) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgPrimApp op args lvs) = returnLM (expr, emptyLiftInfo) + +liftExpr expr@(StgApp (StgLitAtom lit) args lvs) = returnLM (expr, emptyLiftInfo) +liftExpr expr@(StgApp (StgVarAtom v) args lvs) + = lookup v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to + -- poke these bindings too early! + returnLM (StgApp (StgVarAtom sc) (map StgVarAtom sc_args ++ args) lvs, + emptyLiftInfo) + -- The lvs field is probably wrong, but we reconstruct it + -- anyway following lambda lifting + +liftExpr (StgCase scrut lv1 lv2 uniq alts) + = liftExpr scrut `thenLM` \ (scrut', scrut_info) -> + lift_alts alts `thenLM` \ (alts', alts_info) -> + returnLM (StgCase scrut' lv1 lv2 uniq alts', scrut_info `unionLiftInfo` alts_info) + where + lift_alts (StgAlgAlts ty alg_alts deflt) + = mapAndUnzipLM lift_alg_alt alg_alts `thenLM` \ (alg_alts', alt_infos) -> + lift_deflt deflt `thenLM` \ (deflt', deflt_info) -> + returnLM (StgAlgAlts ty alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos) + + lift_alts (StgPrimAlts ty prim_alts deflt) + = mapAndUnzipLM lift_prim_alt prim_alts `thenLM` \ (prim_alts', alt_infos) -> + lift_deflt deflt `thenLM` \ (deflt', deflt_info) -> + returnLM (StgPrimAlts ty prim_alts' deflt', foldr unionLiftInfo deflt_info alt_infos) + + lift_alg_alt (con, args, use_mask, rhs) + = liftExpr rhs `thenLM` \ (rhs', rhs_info) -> + returnLM ((con, args, use_mask, rhs'), rhs_info) + + lift_prim_alt (lit, rhs) + = liftExpr rhs `thenLM` \ (rhs', rhs_info) -> + returnLM ((lit, rhs'), rhs_info) + + lift_deflt StgNoDefault = returnLM (StgNoDefault, emptyLiftInfo) + lift_deflt (StgBindDefault var used rhs) + = liftExpr rhs `thenLM` \ (rhs', rhs_info) -> + returnLM (StgBindDefault var used rhs', rhs_info) +\end{code} + +Now the interesting cases. Let no escape isn't lifted. We turn it +back into a let, to play safe, because we have to redo that pass after +lambda anyway. + +\begin{code} +liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body) + = dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) -> + liftExpr body `thenLM` \ (body', body_info) -> + returnLM (StgLet (StgNonRec binder rhs') body', + rhs_info `unionLiftInfo` body_info) + +liftExpr (StgLetNoEscape _ _ (StgRec pairs) body) + = liftExpr body `thenLM` \ (body', body_info) -> + mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> + returnLM (StgLet (StgRec (binders `zipEqual` rhss')) body', + foldr unionLiftInfo body_info rhs_infos) + where + (binders,rhss) = unzip pairs +\end{code} + +\begin{code} +liftExpr (StgLet (StgNonRec binder rhs) body) + | not (isLiftable rhs) + = dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) -> + liftExpr body `thenLM` \ (body', body_info) -> + returnLM (StgLet (StgNonRec binder rhs') body', + rhs_info `unionLiftInfo` body_info) + + | otherwise -- It's a lambda + = -- Do the body of the let + fixLM (\ ~(sc_inline, _, _) -> + addScInlines [binder] [sc_inline] ( + liftExpr body + ) `thenLM` \ (body', body_info) -> + + -- Deal with the RHS + dontLiftRhs rhs `thenLM` \ (rhs', rhs_info) -> + + -- All occurrences in function position, so lambda lift + getFinalFreeVars (rhsFreeVars rhs) `thenLM` \ final_free_vars -> + + mkScPieces final_free_vars (binder,rhs') `thenLM` \ (sc_inline, sc_bind) -> + + returnLM (sc_inline, + body', + nonRecScBind rhs_info sc_bind `unionLiftInfo` body_info) + + ) `thenLM` \ (_, expr', final_info) -> + + returnLM (expr', final_info) + +liftExpr (StgLet (StgRec pairs) body) +--[Andre-testing] + | not (all isLiftableRec rhss) + = liftExpr body `thenLM` \ (body', body_info) -> + mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> + returnLM (StgLet (StgRec (binders `zipEqual` rhss')) body', + foldr unionLiftInfo body_info rhs_infos) + + | otherwise -- All rhss are liftable + = -- Do the body of the let + fixLM (\ ~(sc_inlines, _, _) -> + addScInlines binders sc_inlines ( + + liftExpr body `thenLM` \ (body', body_info) -> + mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> + let + -- Find the free vars of all the rhss, + -- excluding the binders themselves. + rhs_free_vars = unionManyUniqSets (map rhsFreeVars rhss) + `minusUniqSet` + mkUniqSet binders + + rhs_info = unionLiftInfos rhs_infos + in + getFinalFreeVars rhs_free_vars `thenLM` \ final_free_vars -> + + mapAndUnzipLM (mkScPieces final_free_vars) (binders `zip` rhss') + `thenLM` \ (sc_inlines, sc_pairs) -> + returnLM (sc_inlines, + body', + recScBind rhs_info sc_pairs `unionLiftInfo` body_info) + + )) `thenLM` \ (_, expr', final_info) -> + + returnLM (expr', final_info) + where + (binders,rhss) = unzip pairs +\end{code} + +\begin{code} +liftExpr (StgSCC ty cc expr) + = liftExpr expr `thenLM` \ (expr2, expr_info) -> + returnLM (StgSCC ty cc expr2, expr_info) +\end{code} + +A binding is liftable if it's a *function* (args not null) and never +occurs in an argument position. + +\begin{code} +isLiftable :: PlainStgRhs -> Bool + +isLiftable (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _) + -- experimental evidence suggests we should lift only if we will be abstracting up to 4 fvs. + = if not (null args || -- Not a function + unapplied_occ || -- Has an occ with no args at all + arg_occ || -- Occurs in arg position + length fvs > 4 -- Too many free variables + ) + then {-trace ("LL: " ++ show (length fvs))-} True + else False +isLiftable other_rhs = False + +isLiftableRec :: PlainStgRhs -> Bool +-- this is just the same as for non-rec, except we only lift to abstract up to 1 argument +-- this avoids undoing Static Argument Transformation work +isLiftableRec (StgRhsClosure _ (StgBinderInfo arg_occ _ _ _ unapplied_occ) fvs _ args _) + = if not (null args || -- Not a function + unapplied_occ || -- Has an occ with no args at all + arg_occ || -- Occurs in arg position + length fvs > 1 -- Too many free variables + ) + then {-trace ("LLRec: " ++ show (length fvs))-} True + else False +isLiftableRec other_rhs = False + +rhsFreeVars :: PlainStgRhs -> IdSet +rhsFreeVars (StgRhsClosure _ _ fvs _ _ _) = mkUniqSet fvs +rhsFreeVars other = panic "rhsFreeVars" +\end{code} + +dontLiftRhs is like liftExpr, except that it does not lift a top-level lambda +abstraction. It is used for the right-hand sides of definitions where +we've decided *not* to lift: for example, top-level ones or mutually-recursive +ones where not all are lambdas. + +\begin{code} +dontLiftRhs :: PlainStgRhs -> LiftM (PlainStgRhs, LiftInfo) + +dontLiftRhs rhs@(StgRhsCon cc v args) = returnLM (rhs, emptyLiftInfo) + +dontLiftRhs (StgRhsClosure cc bi fvs upd args body) + = liftExpr body `thenLM` \ (body', body_info) -> + returnLM (StgRhsClosure cc bi fvs upd args body', body_info) +\end{code} + + +\begin{code} +mkScPieces :: IdSet -- Extra args for the supercombinator + -> (Id, PlainStgRhs) -- The processed RHS and original Id + -> LiftM ((Id,[Id]), -- Replace abstraction with this; + -- the set is its free vars + (Id,PlainStgRhs)) -- Binding for 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 + arity = n_args + length extra_args + + -- Construct the supercombinator type + type_of_original_id = getIdUniType id + extra_arg_tys = map getIdUniType extra_args + (tyvars, rest) = splitForalls type_of_original_id + sc_ty = mkForallTy tyvars (glueTyArgs extra_arg_tys rest) + + sc_rhs = StgRhsClosure cc bi [] upd (extra_args ++ args) body +\end{code} + + +%************************************************************************ +%* * +\subsection[Lift-monad]{The LiftM monad} +%* * +%************************************************************************ + +The monad is used only to distribute global stuff, and the unique supply. + +\begin{code} +type LiftM a = LiftFlags + -> SplitUniqSupply + -> (IdEnv -- Domain = candidates for lifting + (Id, -- The supercombinator + [Id]) -- Args to apply it to + ) + -> a + + +type LiftFlags = Maybe Int -- No of fvs reqd to float recursive + -- binding; Nothing == infinity + + +runLM :: LiftFlags -> SplitUniqSupply -> LiftM a -> a +runLM flags us m = m flags us nullIdEnv + +thenLM :: LiftM a -> (a -> LiftM b) -> LiftM b +thenLM m k ci us idenv + = k (m ci us1 idenv) ci us2 idenv + where + (us1, us2) = splitUniqSupply us + +returnLM :: a -> LiftM a +returnLM a ci us idenv = a + +fixLM :: (a -> LiftM a) -> LiftM a +fixLM k ci us idenv = r + where + r = k r ci us idenv + +mapLM :: (a -> LiftM b) -> [a] -> LiftM [b] +mapLM f [] = returnLM [] +mapLM f (a:as) = f a `thenLM` \ r -> + mapLM f as `thenLM` \ rs -> + returnLM (r:rs) + +mapAndUnzipLM :: (a -> LiftM (b,c)) -> [a] -> LiftM ([b],[c]) +mapAndUnzipLM f [] = returnLM ([],[]) +mapAndUnzipLM f (a:as) = f a `thenLM` \ (b,c) -> + mapAndUnzipLM f as `thenLM` \ (bs,cs) -> + returnLM (b:bs, c:cs) +\end{code} + +\begin{code} +newSupercombinator :: UniType + -> Int -- Arity + -> LiftM Id + +newSupercombinator ty arity ci us idenv + = (mkSysLocal SLIT("sc") uniq ty mkUnknownSrcLoc) -- ToDo: improve location + `addIdArity` arity + -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it? + where + uniq = getSUnique us + +lookup :: Id -> LiftM (Id,[Id]) +lookup v ci us idenv + = 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 + = m ci us idenv' + where + idenv' = growIdEnvList idenv (ids `zip_lazy` values) + + -- zip_lazy zips two things together but matches lazily on the + -- second argument. This is important, because the ids are know here, + -- but the things they are bound to are decided only later + zip_lazy [] _ = [] + zip_lazy (x:xs) ~(y:ys) = (x,y) : zip_lazy xs ys + + +-- The free vars reported by the free-var analyser will include +-- some ids, f, which are to be replaced by ($f a b c), where $f +-- is the supercombinator. Hence instead of f being a free var, +-- {a,b,c} are. +-- +-- Example +-- let +-- f a = ...y1..y2..... +-- in +-- let +-- g b = ...f...z... +-- in +-- ... +-- +-- Here the free vars of g are {f,z}; but f will be lambda-lifted +-- with free vars {y1,y2}, so the "real~ free vars of g are {y1,y2,z}. + +getFinalFreeVars :: IdSet -> LiftM IdSet + +getFinalFreeVars free_vars ci us idenv + = unionManyUniqSets (map munge_it (uniqSetToList free_vars)) + where + munge_it :: Id -> IdSet -- Takes a free var and maps it to the "real" + -- free var + munge_it id = case lookupIdEnv idenv id of + Just (_, args) -> mkUniqSet args + Nothing -> singletonUniqSet id + +\end{code} + + +%************************************************************************ +%* * +\subsection[Lift-info]{The LiftInfo type} +%* * +%************************************************************************ + +\begin{code} +type LiftInfo = Bag PlainStgBinding -- Float to top + +emptyLiftInfo = emptyBag + +unionLiftInfo :: LiftInfo -> LiftInfo -> LiftInfo +unionLiftInfo binds1 binds2 = binds1 `unionBags` binds2 + +unionLiftInfos :: [LiftInfo] -> LiftInfo +unionLiftInfos infos = foldr unionLiftInfo emptyLiftInfo infos + +mkScInfo :: PlainStgBinding -> LiftInfo +mkScInfo bind = unitBag bind + +nonRecScBind :: LiftInfo -- From body of supercombinator + -> (Id, PlainStgRhs) -- Supercombinator and its rhs + -> LiftInfo +nonRecScBind binds (sc_id,sc_rhs) = binds `snocBag` (StgNonRec sc_id sc_rhs) + + +-- In the recursive case, all the SCs from the RHSs of the recursive group +-- are dealing with might potentially mention the new, recursive SCs. +-- So we flatten the whole lot into a single recursive group. + +recScBind :: LiftInfo -- From body of supercombinator + -> [(Id,PlainStgRhs)] -- Supercombinator rhs + -> LiftInfo + +recScBind binds pairs = unitBag (co_rec_ify (StgRec pairs : bagToList binds)) + +co_rec_ify :: [PlainStgBinding] -> PlainStgBinding +co_rec_ify binds = StgRec (concat (map f binds)) + where + f (StgNonRec id rhs) = [(id,rhs)] + f (StgRec pairs) = pairs + + +getScBinds :: LiftInfo -> [PlainStgBinding] +getScBinds binds = bagToList binds + +looksLikeSATRhs [(f,StgRhsClosure _ _ _ _ ls _)] (StgApp (StgVarAtom f') args _) + = (f == f') && (length args == length ls) +looksLikeSATRhs _ _ = False +\end{code} diff --git a/ghc/compiler/simplStg/SatStgRhs.hi b/ghc/compiler/simplStg/SatStgRhs.hi new file mode 100644 index 0000000..de10f7c --- /dev/null +++ b/ghc/compiler/simplStg/SatStgRhs.hi @@ -0,0 +1,8 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SatStgRhs where +import Id(Id) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +satStgRhs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs new file mode 100644 index 0000000..a6793d7 --- /dev/null +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -0,0 +1,307 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[SatStgRhs]{Saturates RHSs when they are partial applications} + + +\begin{display} +Subject: arg satis check +Date: Wed, 29 Apr 92 13:33:58 +0100 +From: Simon L Peyton Jones + +Andre + +Another transformation to consider. We'd like to avoid +argument-satisfaction checks wherever possible. So, whenever we have an +STG binding application + + f = vs \ xs -> g e1 ... en + +where xs has one or more elements +and +where g is a known function with arity m+n, + +then: change it to + + f = vs \ xs++{x1...xm} -> g e1 ... en x1 .. xm + +Now g has enough args. One arg-satisfaction check disappears; +the one for the closure incorporates the one for g. + +You might like to consider variants, applying the transformation more +widely. I concluded that this was the only instance which made +sense, but I could be wrong. + +Simon +\end{display} + +The algorithm proceeds as follows: +\begin{enumerate} +\item +Gather the arity information of the functions defined in this module +(as @getIdArity@ only knows about the arity of @ImportedIds@). + +\item +for every definition of the form +\begin{verbatim} + v = /\ts -> \vs -> f args +\end{verbatim} +we try to match the arity of \tr{f} with the number of arguments. +If they do not match we insert extra lambdas to make that application +saturated. +\end{enumerate} + +This is done for local definitions as well. + +\begin{code} +#include "HsVersions.h" + +module SatStgRhs ( satStgRhs ) where + +import StgSyn + +import AbsUniType ( splitTypeWithDictsAsArgs, Class, + TyVarTemplate, TauType(..) + ) +import CostCentre +import IdEnv +import Id ( mkSysLocal, getIdUniType, getIdArity, addIdArity ) +import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) ) +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import SplitUniq +import Unique +import Util +import Maybes + +type Arity = Int +type Count = Int + +type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed + -- arity of n + -- Nothing => Don't know how many args it needs + +type Id_w_Arity = Id -- An Id with correct arity info pinned on it +type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things +\end{code} + +This pass +\begin{itemize} +\item adds extra args where necessary; +\item pins the correct arity on everything. +\end{itemize} + +%************************************************************************ +%* * +\subsection{Top-level list of bindings (a ``program'')} +%* * +%************************************************************************ + +\begin{code} +satStgRhs :: PlainStgProgram -> SUniqSM PlainStgProgram + +satStgRhs p = satProgram nullIdEnv p + +satProgram :: SatEnv -> PlainStgProgram -> SUniqSM PlainStgProgram +satProgram env [] = returnSUs [] + +satProgram env (bind:binds) + = satBinding True{-toplevel-} env bind `thenSUs` \ (env2, bind2) -> + satProgram env2 binds `thenSUs` \ binds2 -> + returnSUs (bind2 : binds2) +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +satBinding :: Bool -- True <=> top-level + -> SatEnv + -> PlainStgBinding + -> SUniqSM (SatEnv, PlainStgBinding) + +satBinding top env (StgNonRec b rhs) + = satRhs top env (b, rhs) `thenSUs` \ (b2, rhs2) -> + let + env2 = addOneToIdEnv env b b2 + in + returnSUs (env2, StgNonRec b2 rhs2) + +satBinding top env (StgRec pairs) + = -- Do it once to get the arities right... + mapSUs (satRhs top env) pairs `thenSUs` \ pairs2 -> + let + env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2) + in + -- Do it again to *use* those arities: + mapSUs (satRhs top env2) pairs `thenSUs` \ pairs3 -> + + returnSUs (env2, StgRec pairs3) + +satRhs :: Bool -> SatEnv -> (Id, PlainStgRhs) -> SUniqSM (Id_w_Arity, PlainStgRhs) + +satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here + = let + b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero. + in + returnSUs (b2, StgRhsCon cc con (lookupArgs env args)) + +satRhs top env (b, StgRhsClosure cc bi fv u args body) + = satExpr env body `thenSUs` \ (arity_info, body2) -> + let + num_args = length args + in + (case arity_info of + Nothing -> + returnSUs (num_args, StgRhsClosure cc bi fv u args body2) + + Just needed_args -> + ASSERT(needed_args >= 1) + + let -- the arity we're aiming for is: what we already have ("args") + -- plus the ones requested in "arity_info" + new_arity = num_args + needed_args + + -- get type info for this function: + (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (getIdUniType b) + + -- now, we already have "args"; we drop that many types + args_we_dont_have_tys = drop num_args all_arg_tys + + -- finally, we take some of those (up to maybe all of them), + -- depending on how many "needed_args" + args_to_add_tys = take needed_args args_we_dont_have_tys + in + -- make up names for them + mapSUs newName args_to_add_tys `thenSUs` \ nns -> + + -- and do the business + let + body3 = saturate body2 (map StgVarAtom nns) + + new_cc -- if we're adding args, we'd better not + -- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02) + = if not (isCafCC cc) + then cc -- unchanged + else if top then subsumedCosts else useCurrentCostCentre + in + returnSUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3) + ) + `thenSUs` \ (arity, rhs2) -> + let + b2 = b `addIdArity` arity + in + returnSUs (b2, rhs2) +\end{code} + +%************************************************************************ +%* * +\subsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +satExpr :: SatEnv -> PlainStgExpr -> SUniqSM (ExprArityInfo, PlainStgExpr) + +satExpr env app@(StgApp (StgLitAtom lit) [] lvs) = returnSUs (Nothing, app) + +satExpr env app@(StgApp (StgVarAtom f) as lvs) + = returnSUs (arity_to_return, StgApp (StgVarAtom f2) as2 lvs) + where + as2 = lookupArgs env as + f2 = lookupVar env f + arity_to_return = case arityMaybe (getIdArity f2) of + Nothing -> Nothing + + Just f_arity -> if remaining_arity > 0 + then Just remaining_arity + else Nothing + where + remaining_arity = f_arity - length as + +satExpr env app@(StgConApp con as lvs) + = returnSUs (Nothing, StgConApp con (lookupArgs env as) lvs) + +satExpr env app@(StgPrimApp op as lvs) + = returnSUs (Nothing, StgPrimApp op (lookupArgs env as) lvs) + +satExpr env (StgSCC ty l e) + = satExpr env e `thenSUs` \ (_, e2) -> + returnSUs (Nothing, StgSCC ty l e2) + +{- OMITTED: Let-no-escapery should come *after* saturation + +satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) + = satBinding binds `thenSUs` \ (binds2, c) -> + satExpr body `thenSUs` \ (_, body2, c2) -> + returnSUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2) +-} + +satExpr env (StgLet binds body) + = satBinding False{-not top-level-} env binds `thenSUs` \ (env2, binds2) -> + satExpr env2 body `thenSUs` \ (_, body2) -> + returnSUs (Nothing, StgLet binds2 body2) + +satExpr env (StgCase expr lve lva uniq alts) + = satExpr env expr `thenSUs` \ (_, expr2) -> + sat_alts alts `thenSUs` \ alts2 -> + returnSUs (Nothing, StgCase expr2 lve lva uniq alts2) + where + sat_alts (StgAlgAlts ty alts def) + = mapSUs sat_alg_alt alts `thenSUs` \ alts2 -> + sat_deflt def `thenSUs` \ def2 -> + returnSUs (StgAlgAlts ty alts2 def2) + where + sat_alg_alt (id, bs, use_mask, e) + = satExpr env e `thenSUs` \ (_, e2) -> + returnSUs (id, bs, use_mask, e2) + + sat_alts (StgPrimAlts ty alts def) + = mapSUs sat_prim_alt alts `thenSUs` \ alts2 -> + sat_deflt def `thenSUs` \ def2 -> + returnSUs (StgPrimAlts ty alts2 def2) + where + sat_prim_alt (l, e) + = satExpr env e `thenSUs` \ (_, e2) -> + returnSUs (l, e2) + + sat_deflt StgNoDefault + = returnSUs StgNoDefault + + sat_deflt (StgBindDefault b u expr) + = satExpr env expr `thenSUs` \ (_,expr2) -> + returnSUs (StgBindDefault b u expr2) +\end{code} + +%************************************************************************ +%* * +\subsection{Utility functions} +%* * +%************************************************************************ + +\begin{code} +saturate :: PlainStgExpr -> [PlainStgAtom] -> PlainStgExpr + +saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs +saturate other _ = panic "SatStgRhs: saturate" +\end{code} + +\begin{code} +lookupArgs :: SatEnv -> [PlainStgAtom] -> [PlainStgAtom] +lookupArgs env args = map do args + where + do (StgVarAtom v) = StgVarAtom (lookupVar env v) + do a@(StgLitAtom lit) = a + +lookupVar :: SatEnv -> Id -> Id +lookupVar env v = case lookupIdEnv env v of + Nothing -> v + Just v2 -> v2 + +newName :: UniType -> SUniqSM Id +newName ut + = getSUnique `thenSUs` \ uniq -> + returnSUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc) +\end{code} diff --git a/ghc/compiler/simplStg/SimplStg.hi b/ghc/compiler/simplStg/SimplStg.hi new file mode 100644 index 0000000..08f6c91 --- /dev/null +++ b/ghc/compiler/simplStg/SimplStg.hi @@ -0,0 +1,12 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SimplStg where +import CmdLineOpts(GlobalSwitch, StgToDo, SwitchResult) +import CostCentre(CostCentre) +import Id(Id) +import PreludePS(_PackedString) +import Pretty(PprStyle) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgBinding) +stg2stg :: [StgToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [StgBinding Id Id] -> _State _RealWorld -> (([StgBinding Id Id], ([CostCentre], [CostCentre])), _State _RealWorld) + {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SSLLU(ALL)LL" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs new file mode 100644 index 0000000..6fdb44c --- /dev/null +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -0,0 +1,354 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[SimplStg]{Driver for simplifying @STG@ programs} + +\begin{code} +#include "HsVersions.h" + +module SimplStg ( stg2stg ) where + +IMPORT_Trace + +import StgSyn +import StgFuns + +import LambdaLift ( liftProgram ) +import SCCfinal ( stgMassageForProfiling ) +import SatStgRhs ( satStgRhs ) +import StgStats ( showStgStats ) +import StgVarInfo ( setStgVarInfo ) +import UpdAnal ( updateAnalyse ) + +import CmdLineOpts +import Id ( unlocaliseId ) +import IdEnv +import MainMonad +import Maybes ( maybeToBool, Maybe(..) ) +import Outputable +import Pretty +import SplitUniq +import StgLint ( lintStgBindings ) +import StgSAT ( doStaticArgs ) +import UniqSet +import Unique +import Util +\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) + -> SplitUniqSupply -- a name supply + -> [PlainStgBinding] -- input... + -> MainIO + ([PlainStgBinding], -- 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 + = BSCC("Stg2Stg") + case (splitUniqSupply us) of { (us4now, us4later) -> + + (if do_verbose_stg2stg then + writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_` + writeMn stderr (ppShow 1000 + (ppAbove (ppStr ("*** Core2Stg:")) + (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds))) + )) + else returnMn ()) `thenMn_` + + -- Do the main business! + foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos + `thenMn` \ (processed_binds, _, cost_centres) -> + -- Do essential wind-up: part (a) is SatStgRhs + + -- Not optional, because correct arity information is used by + -- the code generator. Afterwards do setStgVarInfo; it gives + -- the wrong answers if arities are subsequently changed, + -- which stgSatRhs might do. Furthermore, setStgVarInfo + -- decides about let-no-escape things, which in turn do a + -- better job if arities are correct, which is done by + -- satStgRhs. + + case (satStgRhs processed_binds us4later) of { saturated_binds -> + + -- Essential wind-up: part (b), eliminate indirections + + let no_ind_binds = elimIndirections saturated_binds in + + + -- Essential wind-up: part (c), do setStgVarInfo. It has to + -- happen regardless, because the code generator uses its + -- decorations. + -- + -- Why does it have to happen last? Because earlier passes + -- may move things around, which would change the live-var + -- info. Also, setStgVarInfo decides about let-no-escape + -- things, which in turn do a better job if arities are + -- correct, which is done by satStgRhs. + -- + let + -- ToDo: provide proper flag control! + binds_to_mangle + = if not do_unlocalising + then no_ind_binds + else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds) + in + returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) + }} + 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_unlocalising, unlocal_tag) + = case (stringSwitchSet sw_chkr EnsureSplittableC) of + Nothing -> (False, panic "tag") + Just tag -> (True, _PK_ tag) + + grp_name = case (stringSwitchSet sw_chkr SccGroup) of + Just xx -> _PK_ xx + Nothing -> module_name -- default: module name + + ------------- + stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag + then lintStgBindings ppr_style + else ( \ whodunnit binds -> binds ) + + ------------------------------------------- + do_stg_pass (binds, us, ccs) to_do + = let + (us1, us2) = splitUniqSupply us + in + case to_do of + StgDoStaticArgs -> + ASSERT(null (fst ccs) && null (snd ccs)) + BSCC("StgStaticArgs") + let + binds3 = doStaticArgs binds us1 + in + end_pass us2 "StgStaticArgs" ccs binds3 + ESCC + + StgDoUpdateAnalysis -> + ASSERT(null (fst ccs) && null (snd ccs)) + BSCC("StgUpdAnal") + -- NB We have to do setStgVarInfo first! (There's one + -- place free-var info is used) But no let-no-escapes, + -- because update analysis doesn't care. + end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds)) + ESCC + + D_stg_stats -> + trace (showStgStats binds) + end_pass us2 "StgStats" ccs binds + + StgDoLambdaLift -> + BSCC("StgLambdaLift") + -- NB We have to do setStgVarInfo first! + let + binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds) + in + end_pass us2 "LambdaLift" ccs binds3 + ESCC + + StgDoMassageForProfiling -> + BSCC("ProfMassage") + let + (collected_CCs, binds3) + = stgMassageForProfiling module_name grp_name us1 switch_is_on binds + in + end_pass us2 "ProfMassage" collected_CCs binds3 + ESCC + + end_pass us2 what ccs binds2 + = -- report verbosely, if required + (if do_verbose_stg2stg then + writeMn stderr (ppShow 1000 + (ppAbove (ppStr ("*** "++what++":")) + (ppAboves (map (ppr ppr_style) binds2)) + )) + else returnMn ()) `thenMn_` + let + linted_binds = stg_linter what binds2 + in + returnMn (linted_binds, us2, ccs) + -- return: processed binds + -- UniqueSupply for the next guy to use + -- cost-centres to be declared/registered (specialised) + -- add to description of what's happened (reverse order) + +-- here so it can be inlined... +foldl_mn f z [] = returnMn z +foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> + foldl_mn f zz xs +\end{code} + +%************************************************************************ +%* * +\subsection[SimplStg-unlocalise]{Unlocalisation in STG code} +%* * +%************************************************************************ + +The idea of all this ``unlocalise'' stuff is that in certain (prelude +only) modules we split up the .hc file into lots of separate little +files, which are separately compiled by the C compiler. That gives +lots of little .o files. The idea is that if you happen to mention +one of them you don't necessarily pull them all in. (Pulling in a +piece you don't need can be v bad, because it may mention other pieces +you don't need either, and so on.) + +Sadly, splitting up .hc files means that local names (like s234) are +now globally visible, which can lead to clashes between two .hc +files. So unlocaliseWhatnot goes through making all the local things +into global things, essentially by giving them full names so when they +are printed they'll have their module name too. Pretty revolting +really. + +\begin{code} +type UnlocalEnv = IdEnv Id + +lookup_uenv :: UnlocalEnv -> Id -> Id +lookup_uenv env id = case lookupIdEnv env id of + Nothing -> id + Just new_id -> new_id + +unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [PlainStgBinding] -> (UnlocalEnv, [PlainStgBinding]) + +unlocaliseStgBinds mod uenv [] = (uenv, []) + +unlocaliseStgBinds mod uenv (b : bs) + = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) -> + BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) -> + (uenv3, new_b : new_bs) + BEND BEND + +------------------ + +unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> PlainStgBinding -> (UnlocalEnv, PlainStgBinding) + +unlocal_top_bind mod uenv bind@(StgNonRec binder _) + = let new_uenv = case unlocaliseId mod binder of + Nothing -> uenv + Just new_binder -> addOneToIdEnv uenv binder new_binder + in + (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) + +unlocal_top_bind mod uenv bind@(StgRec pairs) + = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ] + new_uenv = growIdEnvList uenv [ (b,new_b) + | (b, Just new_b) <- maybe_unlocaliseds] + in + (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) +\end{code} + +%************************************************************************ +%* * +\subsection[SimplStg-indirections]{Eliminating indirections in STG code} +%* * +%************************************************************************ + +In @elimIndirections@, we look for things at the top-level of the form... +\begin{verbatim} + x_local = ....rhs... + ... + x_exported = x_local + ... +\end{verbatim} +In cases we find like this, we go {\em backwards} and replace +\tr{x_local} with \tr{...rhs...}, to produce +\begin{verbatim} + x_exported = ...rhs... + ... + ... +\end{verbatim} +This saves a gratuitous jump +(from \tr{x_exported} to \tr{x_local}), and makes strictness +information propagate better. + +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we eliminate only the first one. Thus: +\begin{verbatim} + x_local = ....rhs... + ... + x_exported1 = x_local + ... + x_exported2 = x_local + ... +\end{verbatim} +becomes +\begin{verbatim} + x_exported1 = ....rhs... + ... + ... + x_exported2 = x_exported1 + ... +\end{verbatim} + +We also have to watch out for + + f = \xyz -> g x y z + +This can arise post lambda lifting; the original might have been + + f = \xyz -> letrec g = [xy] \ [k] -> e + in + g z + +Strategy: first collect the info; then make a \tr{Id -> Id} mapping. +Then blast the whole program (LHSs as well as RHSs) with it. + +\begin{code} +elimIndirections :: [PlainStgBinding] -> [PlainStgBinding] + +elimIndirections binds_in + = if isNullIdEnv blast_env then + binds_in -- Nothing to do + else + [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds] + where + lookup_fn id = case lookupIdEnv blast_env id of + Just new_id -> new_id + Nothing -> id + + (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in + + try_bind :: IdEnv Id -> PlainStgBinding -> (IdEnv Id, Maybe PlainStgBinding) + try_bind env_so_far + (StgNonRec exported_binder + (StgRhsClosure _ _ _ _ + lambda_args + (StgApp (StgVarAtom local_binder) fun_args _) + )) + | isExported exported_binder && -- Only if this is exported + not (isExported local_binder) && -- Only if this one is defined in this + isLocallyDefined local_binder && -- module, so that we *can* change its + -- binding to be the exported thing! + not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before + args_match lambda_args fun_args -- Just an eta-expansion + + = (addOneToIdEnv env_so_far local_binder exported_binder, + Nothing) + where + args_match [] [] = True + args_match (la:las) (StgVarAtom fa:fas) = la == fa && args_match las fas + args_match _ _ = False + + try_bind env_so_far bind + = (env_so_far, Just bind) + + in_dom env id = maybeToBool (lookupIdEnv env id) +\end{code} + +@renameTopStgBind@ renames top level binders and all occurrences thereof. + +\begin{code} +renameTopStgBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding + +renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs) +renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] +\end{code} diff --git a/ghc/compiler/simplStg/StgSAT.hi b/ghc/compiler/simplStg/StgSAT.hi new file mode 100644 index 0000000..91f7a35 --- /dev/null +++ b/ghc/compiler/simplStg/StgSAT.hi @@ -0,0 +1,18 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgSAT where +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import StgSyn(PlainStgProgram(..), StgAtom, StgBinding, StgCaseAlternatives, StgExpr, StgRhs) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type PlainStgProgram = [StgBinding Id Id] +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +doStaticArgs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs new file mode 100644 index 0000000..80cdec4 --- /dev/null +++ b/ghc/compiler/simplStg/StgSAT.lhs @@ -0,0 +1,186 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[SAT]{Static Argument Transformation pass} +%* * +%************************************************************************ + +May be seen as removing invariants from loops: +Arguments of recursive functions that do not change in recursive +calls are removed from the recursion, which is done locally +and only passes the arguments which effectively change. + +Example: +map = /\ ab -> \f -> \xs -> case xs of + [] -> [] + (a:b) -> f a : map f b + +as map is recursively called with the same argument f (unmodified) +we transform it to + +map = /\ ab -> \f -> \xs -> let map' ys = case ys of + [] -> [] + (a:b) -> f a : map' b + in map' xs + +Notice that for a compiler that uses lambda lifting this is +useless as map' will be transformed back to what map was. + +\begin{code} +#include "HsVersions.h" + +module StgSAT ( + doStaticArgs, + + -- and to make the interface self-sufficient... + PlainStgProgram(..), StgExpr, StgBinding, Id + ) where + +import IdEnv +import Maybes ( Maybe(..) ) +import StgSyn +import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv, + SatM(..), initSAT, thenSAT, thenSAT_, + emptyEnvSAT, returnSAT, mapSAT ) +import StgSATMonad +import SplitUniq +import Util +\end{code} + +\begin{code} +doStaticArgs :: PlainStgProgram -> SplitUniqSupply -> PlainStgProgram + +doStaticArgs binds + = initSAT (mapSAT sat_bind binds) + where + sat_bind (StgNonRec binder expr) + = emptyEnvSAT `thenSAT_` + satRhs expr `thenSAT` (\ expr' -> + returnSAT (StgNonRec binder expr')) + sat_bind (StgRec [(binder,rhs)]) + = emptyEnvSAT `thenSAT_` + insSAEnv binder (getArgLists rhs) `thenSAT_` + satRhs rhs `thenSAT` (\ rhs' -> + saTransform binder rhs') + sat_bind (StgRec pairs) + = emptyEnvSAT `thenSAT_` + mapSAT satRhs rhss `thenSAT` \ rhss' -> + returnSAT (StgRec (binders `zip` rhss')) + where + (binders, rhss) = unzip pairs +\end{code} + +\begin{code} +satAtom (StgVarAtom v) + = updSAEnv (Just (v,([],[]))) `thenSAT_` + returnSAT () + +satAtom _ = returnSAT () +\end{code} + +\begin{code} +satExpr :: PlainStgExpr -> SatM PlainStgExpr + +satExpr e@(StgConApp con args lvs) + = mapSAT satAtom args `thenSAT_` + returnSAT e + +satExpr e@(StgPrimApp op args lvs) + = mapSAT satAtom args `thenSAT_` + returnSAT e + +satExpr e@(StgApp (StgLitAtom _) _ _) + = returnSAT e + +satExpr e@(StgApp (StgVarAtom v) args _) + = updSAEnv (Just (v,([],map tagArg args))) `thenSAT_` + mapSAT satAtom args `thenSAT_` + returnSAT e + where + tagArg (StgVarAtom v) = Static v + tagArg _ = NotStatic + +satExpr (StgCase expr lv1 lv2 uniq alts) + = satExpr expr `thenSAT` \ expr' -> + sat_alts alts `thenSAT` \ alts' -> + returnSAT (StgCase expr' lv1 lv2 uniq alts') + where + sat_alts (StgAlgAlts ty alts deflt) + = mapSAT satAlgAlt alts `thenSAT` \ alts' -> + sat_default deflt `thenSAT` \ deflt' -> + returnSAT (StgAlgAlts ty alts' deflt') + where + satAlgAlt (con, params, use_mask, rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (con, params, use_mask, rhs') + + sat_alts (StgPrimAlts ty alts deflt) + = mapSAT satPrimAlt alts `thenSAT` \ alts' -> + sat_default deflt `thenSAT` \ deflt' -> + returnSAT (StgPrimAlts ty alts' deflt') + where + satPrimAlt (lit, rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (lit, rhs') + + sat_default StgNoDefault + = returnSAT StgNoDefault + sat_default (StgBindDefault binder used rhs) + = satExpr rhs `thenSAT` \ rhs' -> + returnSAT (StgBindDefault binder used rhs') + +satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body) + = satExpr body `thenSAT` \ body' -> + satRhs rhs `thenSAT` \ rhs' -> + returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body') + +satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body) + = satExpr body `thenSAT` \ body' -> + insSAEnv binder (getArgLists rhs) `thenSAT_` + satRhs rhs `thenSAT` \ rhs' -> + saTransform binder rhs' `thenSAT` \ binding -> + returnSAT (StgLetNoEscape lv1 lv2 binding body') + +satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body) + = let (binders, rhss) = unzip binds + in + satExpr body `thenSAT` \ body' -> + mapSAT satRhs rhss `thenSAT` \ rhss' -> + returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body') + +satExpr (StgLet (StgNonRec binder rhs) body) + = satExpr body `thenSAT` \ body' -> + satRhs rhs `thenSAT` \ rhs' -> + returnSAT (StgLet (StgNonRec binder rhs') body') + +satExpr (StgLet (StgRec [(binder,rhs)]) body) + = satExpr body `thenSAT` \ body' -> + insSAEnv binder (getArgLists rhs) `thenSAT_` + satRhs rhs `thenSAT` \ rhs' -> + saTransform binder rhs' `thenSAT` \ binding -> + returnSAT (StgLet binding body') + +satExpr (StgLet (StgRec binds) body) + = let (binders, rhss) = unzip binds + in + satExpr body `thenSAT` \ body' -> + mapSAT satRhs rhss `thenSAT` \ rhss' -> + returnSAT (StgLet (StgRec (binders `zip` rhss')) body') + +satExpr (StgSCC ty cc expr) + = satExpr expr `thenSAT` \ expr' -> + returnSAT (StgSCC ty cc expr') + +-- ToDo: DPH stuff +\end{code} + +\begin{code} +satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs +satRhs (StgRhsClosure cc bi fvs upd args body) + = satExpr body `thenSAT` \ body' -> + returnSAT (StgRhsClosure cc bi fvs upd args body') + +\end{code} + diff --git a/ghc/compiler/simplStg/StgSATMonad.hi b/ghc/compiler/simplStg/StgSATMonad.hi new file mode 100644 index 0000000..a6940eb --- /dev/null +++ b/ghc/compiler/simplStg/StgSATMonad.hi @@ -0,0 +1,22 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgSATMonad where +import Class(Class) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import SATMonad(Arg) +import SplitUniq(SplitUniqSupply) +import StgSyn(PlainStgExpr(..), StgBinding, StgExpr, StgRhs) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +type PlainStgExpr = StgExpr Id Id +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +getArgLists :: StgRhs Id Id -> ([Arg UniType], [Arg Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +saTransform :: Id -> StgRhs Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (StgBinding Id Id, UniqFM ([Arg UniType], [Arg Id])) + {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLU(LLL)L" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs new file mode 100644 index 0000000..f0cb84d --- /dev/null +++ b/ghc/compiler/simplStg/StgSATMonad.lhs @@ -0,0 +1,182 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[SATMonad]{The Static Argument Transformation pass Monad} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module StgSATMonad ( + getArgLists, saTransform, + + Id, UniType, SplitUniqSupply, PlainStgExpr(..) + ) where + +import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate, + extractTyVarsFromTy, splitType, splitTyArgs, + glueTyArgs, instantiateTy, TauType(..), + Class, ThetaType(..), SigmaType(..), + InstTyEnv(..) + ) +import IdEnv +import Id ( mkSysLocal, getIdUniType, 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 SplitUniq +import Unique +import UniqSet ( UniqSet(..), emptyUniqSet ) +import Util + +\end{code} + +%************************************************************************ +%* * +\subsection{Utility Functions} +%* * +%************************************************************************ + +\begin{code} +newSATNames :: [Id] -> SatM [Id] +newSATNames [] = returnSAT [] +newSATNames (id:ids) = newSATName id (getIdUniType id) `thenSAT` \ id' -> + newSATNames ids `thenSAT` \ ids' -> + returnSAT (id:ids) + +getArgLists :: PlainStgRhs -> ([Arg UniType],[Arg Id]) +getArgLists (StgRhsCon _ _ _) + = ([],[]) +getArgLists (StgRhsClosure _ _ _ _ args _) + = ([], [Static v | v <- args]) + +\end{code} + +\begin{code} +saTransform :: Id -> PlainStgRhs -> SatM PlainStgBinding +saTransform binder rhs + = getSATInfo binder `thenSAT` \ r -> + case r of + Just (_,args) | any isStatic args + -- [Andre] test: do it only if we have more than one static argument. + --Just (_,args) | length (filter isStatic args) > 1 + -> newSATName binder (new_ty args) `thenSAT` \ binder' -> + let non_static_args = get_nsa args (snd (getArgLists rhs)) + in + newSATNames non_static_args `thenSAT` \ non_static_args' -> + mkNewRhs binder binder' args rhs non_static_args' non_static_args + `thenSAT` \ new_rhs -> + trace ("SAT(STG) "++ show (length (filter isStatic args))) ( + returnSAT (StgNonRec binder new_rhs) + ) + _ -> returnSAT (StgRec [(binder, rhs)]) + + where + get_nsa :: [Arg a] -> [Arg a] -> [a] + get_nsa [] _ = [] + get_nsa _ [] = [] + get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as + get_nsa (_:args) (_:as) = get_nsa args as + + mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args + = let + local_body = StgApp (StgVarAtom binder') + [StgVarAtom a | a <- non_static_args] emptyUniqSet + + rec_body = StgRhsClosure cc bi fvs upd non_static_args' + (doStgSubst binder args subst_env body) + + subst_env = mkIdEnv + ((binder,binder'):zip non_static_args non_static_args') + in + returnSAT ( + StgRhsClosure cc bi fvs upd rhsargs + (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body) + ) + + new_ty args + = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty') + where + -- get type info for the local function: + (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder + (reg_arg_tys, res_type) = splitTyArgs tau_ty + + -- now, we drop the ones that are + -- static, that is, the ones we will not pass to the local function + l = length dict_tys + dict_tys' = dropStatics (take l args) dict_tys + reg_arg_tys' = dropStatics (drop l args) reg_arg_tys + tau_ty' = glueTyArgs reg_arg_tys' res_type +\end{code} + +NOTE: This does not keep live variable/free variable information!! + +\begin{code} +doStgSubst binder orig_args subst_env body + = substExpr body + where + substExpr (StgConApp con args lvs) + = StgConApp con (map substAtom args) emptyUniqSet + substExpr (StgPrimApp op args lvs) + = StgPrimApp op (map substAtom args) emptyUniqSet + substExpr expr@(StgApp (StgLitAtom _) [] _) + = expr + substExpr (StgApp atom@(StgVarAtom v) args lvs) + | v `eqId` binder + = StgApp (StgVarAtom (lookupNoFailIdEnv subst_env v)) + (remove_static_args orig_args args) emptyUniqSet + | otherwise + = StgApp (substAtom atom) (map substAtom args) lvs + substExpr (StgCase scrut lv1 lv2 uniq alts) + = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts) + where + subst_alts (StgAlgAlts ty alg_alts deflt) + = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt) + subst_alts (StgPrimAlts ty prim_alts deflt) + = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt) + subst_alg_alt (con, args, use_mask, rhs) + = (con, args, use_mask, substExpr rhs) + subst_prim_alt (lit, rhs) + = (lit, substExpr rhs) + subst_deflt StgNoDefault + = StgNoDefault + subst_deflt (StgBindDefault var used rhs) + = StgBindDefault var used (substExpr rhs) + substExpr (StgLetNoEscape fv1 fv2 b body) + = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body) + substExpr (StgLet b body) + = StgLet (substBinding b) (substExpr body) + substExpr (StgSCC ty cc expr) + = StgSCC ty cc (substExpr expr) + substRhs (StgRhsCon cc v args) + = StgRhsCon cc v (map substAtom args) + substRhs (StgRhsClosure cc bi fvs upd args body) + = StgRhsClosure cc bi [] upd args (substExpr body) + + substBinding (StgNonRec binder rhs) + = StgNonRec binder (substRhs rhs) + substBinding (StgRec pairs) + = StgRec (zip binders (map substRhs rhss)) + where + (binders,rhss) = unzip pairs + + substAtom atom@(StgLitAtom lit) = atom + substAtom atom@(StgVarAtom v) + = case lookupIdEnv subst_env v of + Just v' -> StgVarAtom v' + Nothing -> atom + + remove_static_args _ [] + = [] + remove_static_args (Static _:origs) (_:as) + = 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.hi b/ghc/compiler/simplStg/StgStats.hi new file mode 100644 index 0000000..7dc9282 --- /dev/null +++ b/ghc/compiler/simplStg/StgStats.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgStats where +import Id(Id) +import StgSyn(StgBinding) +showStgStats :: [StgBinding Id Id] -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs new file mode 100644 index 0000000..2b16fc0 --- /dev/null +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -0,0 +1,188 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[StgStats]{Gathers statistical information about programs} + + +The program gather statistics about +\begin{enumerate} +\item number of boxed cases +\item number of unboxed cases +\item number of let-no-escapes +\item number of non-updatable lets +\item number of updatable lets +\item number of applications +\item number of primitive applications +\item number of closures (does not include lets bound to constructors) +\item number of free variables in closures +%\item number of top-level functions +%\item number of top-level CAFs +\item number of constructors +\end{enumerate} + +\begin{code} +#include "HsVersions.h" + +module StgStats ( showStgStats ) where + +import StgSyn + +import FiniteMap + +import Util +\end{code} + +\begin{code} +data CounterType + = AlgCases + | PrimCases + | LetNoEscapes + | NonUpdatableLets + | UpdatableLets + | Applications + | PrimitiveApps + | FreeVariables + | Closures -- does not include lets bound to constructors +--| UpdatableTopLevelDefs +--| NonUpdatableTopLevelDefs + | Constructors + deriving (Eq, Ord, Text) + +type Count = Int +type StatEnv = FiniteMap CounterType Count +\end{code} + +\begin{code} +emptySE :: StatEnv +emptySE = emptyFM + +combineSE :: StatEnv -> StatEnv -> StatEnv +combineSE = plusFM_C (+) + +combineSEs :: [StatEnv] -> StatEnv +combineSEs = foldr combineSE emptySE + +countOne :: CounterType -> StatEnv +countOne c = singletonFM c 1 + +countN :: CounterType -> Int -> StatEnv +countN = singletonFM +\end{code} + +%************************************************************************ +%* * +\subsection{Top-level list of bindings (a ``program'')} +%* * +%************************************************************************ + +\begin{code} +showStgStats :: PlainStgProgram -> String +showStgStats prog = concat (map showc (fmToList (gatherStgStats prog))) + where + showc (AlgCases,n) = "AlgCases " ++ show n ++ "\n" + showc (PrimCases,n) = "PrimCases " ++ show n ++ "\n" + showc (LetNoEscapes,n) = "LetNoEscapes " ++ show n ++ "\n" + showc (NonUpdatableLets,n) = "NonUpdatableLets " ++ show n ++ "\n" + showc (UpdatableLets,n) = "UpdatableLets " ++ show n ++ "\n" + showc (Applications,n) = "Applications " ++ show n ++ "\n" + showc (PrimitiveApps,n) = "PrimitiveApps " ++ show n ++ "\n" + showc (Closures,n) = "Closures " ++ show n ++ "\n" + showc (FreeVariables,n) = "Free Vars in Closures " ++ show n ++ "\n" + showc (Constructors,n) = "Constructors " ++ show n ++ "\n" + +gatherStgStats :: PlainStgProgram -> StatEnv + +gatherStgStats binds + = combineSEs (map statBinding binds) +\end{code} + +%************************************************************************ +%* * +\subsection{Bindings} +%* * +%************************************************************************ + +\begin{code} +statBinding :: PlainStgBinding -> StatEnv + +statBinding (StgNonRec b rhs) + = statRhs (b, rhs) + +statBinding (StgRec pairs) + = combineSEs (map statRhs pairs) + +statRhs :: (Id, PlainStgRhs) -> StatEnv + +statRhs (b, StgRhsCon cc con args) + = countOne Constructors `combineSE` + countOne NonUpdatableLets + +statRhs (b, StgRhsClosure cc bi fv u args body) + = statExpr body `combineSE` + countN FreeVariables (length fv) `combineSE` + countOne Closures `combineSE` + (case u of + Updatable -> countOne UpdatableLets + _ -> countOne NonUpdatableLets) + +\end{code} + +%************************************************************************ +%* * +\subsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +statExpr :: PlainStgExpr -> StatEnv + +statExpr (StgApp _ [] lvs) + = emptySE +statExpr (StgApp _ _ lvs) + = countOne Applications + +statExpr (StgConApp con as lvs) + = countOne Constructors + +statExpr (StgPrimApp op as lvs) + = countOne PrimitiveApps + +statExpr (StgSCC ty l e) + = statExpr e + +statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body) + = statBinding binds `combineSE` + statExpr body `combineSE` + countOne LetNoEscapes + +statExpr (StgLet binds body) + = statBinding binds `combineSE` + statExpr body + +statExpr (StgCase expr lve lva uniq alts) + = statExpr expr `combineSE` + stat_alts alts + where + stat_alts (StgAlgAlts ty alts def) + = combineSEs (map stat_alg_alt alts) `combineSE` + stat_deflt def `combineSE` + countOne AlgCases + where + stat_alg_alt (id, bs, use_mask, e) + = statExpr e + + stat_alts (StgPrimAlts ty alts def) + = combineSEs (map stat_prim_alt alts) `combineSE` + stat_deflt def `combineSE` + countOne PrimCases + where + stat_prim_alt (l, e) + = statExpr e + + stat_deflt StgNoDefault + = emptySE + + stat_deflt (StgBindDefault b u expr) + = statExpr expr +\end{code} + diff --git a/ghc/compiler/simplStg/StgVarInfo.hi b/ghc/compiler/simplStg/StgVarInfo.hi new file mode 100644 index 0000000..52f36e0 --- /dev/null +++ b/ghc/compiler/simplStg/StgVarInfo.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgVarInfo where +import Id(Id) +import StgSyn(StgBinding) +setStgVarInfo :: Bool -> [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs new file mode 100644 index 0000000..10d618c --- /dev/null +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -0,0 +1,790 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[StgVarInfo]{Sets free/live variable info in STG syntax} + +And, as we have the info in hand, we may convert some lets to +let-no-escapes. + +\begin{code} +#include "HsVersions.h" + +module StgVarInfo ( setStgVarInfo ) where + +IMPORT_Trace -- ToDo: rm (debugging only) +import Pretty +import Outputable + +import StgSyn + +import Id ( getIdArity, externallyVisibleId ) +import IdInfo -- ( arityMaybe, ArityInfo ) + +import IdEnv +import Maybes ( maybeToBool, Maybe(..) ) +import UniqSet +import Util + +infixr 9 `thenLne`, `thenLne_` +\end{code} + +%************************************************************************ +%* * +\subsection[live-vs-free-doc]{Documentation} +%* * +%************************************************************************ + +(There is other relevant documentation in codeGen/CgLetNoEscape.) + +The actual Stg datatype is decorated with {\em live variable} +information, as well as {\em free variable} information. The two are +{\em not} the same. Liveness is an operational property rather than a +semantic one. A variable is live at a particular execution point if +it can be referred to {\em directly} again. In particular, a dead +variable's stack slot (if it has one): +\begin{enumerate} +\item +should be stubbed to avoid space leaks, and +\item +may be reused for something else. +\end{enumerate} + +There ought to be a better way to say this. Here are some examples: +\begin{verbatim} + let v = [q] \[x] -> e + in + ...v... (but no q's) +\end{verbatim} + +Just after the `in', v is live, but q is dead. If the whole of that +let expression was enclosed in a case expression, thus: +\begin{verbatim} + case (let v = [q] \[x] -> e in ...v...) of + alts[...q...] +\end{verbatim} +(ie @alts@ mention @q@), then @q@ is live even after the `in'; because +we'll return later to the @alts@ and need it. + +Let-no-escapes make this a bit more interesting: +\begin{verbatim} + let-no-escape v = [q] \ [x] -> e + in + ...v... +\end{verbatim} +Here, @q@ is still live at the `in', because @v@ is represented not by +a closure but by the current stack state. In other words, if @v@ is +live then so is @q@. Furthermore, if @e@ mentions an enclosing +let-no-escaped variable, then {\em its} free variables are also live +if @v@ is. + +%************************************************************************ +%* * +\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} +%* * +%************************************************************************ + +Top-level: +\begin{code} +setStgVarInfo :: Bool -- True <=> do let-no-escapes + -> [PlainStgBinding] -- input + -> [PlainStgBinding] -- result + +setStgVarInfo want_LNEs pgm + = pgm' + where + (pgm', _) = initLne want_LNEs (varsTopBinds pgm) + +\end{code} + +For top-level guys, we basically aren't worried about this +live-variable stuff; we do need to keep adding to the environment +as we step through the bindings (using @extendVarEnv@). + +\begin{code} +varsTopBinds :: [PlainStgBinding] -> LneM ([PlainStgBinding], FreeVarsInfo) + +varsTopBinds [] = returnLne ([], emptyFVInfo) +varsTopBinds (bind:binds) + = extendVarEnv env_extension ( + varsTopBinds binds `thenLne` \ (binds', fv_binds) -> + varsTopBind fv_binds bind `thenLne` \ (bind', fv_bind) -> + returnLne ((bind' : binds'), + (fv_binds `unionFVInfo` fv_bind) `minusFVBinders` binders + ) + + ) + where + env_extension = [(b, LetrecBound + True {- top level -} + (rhsArity rhs) + emptyUniqSet) + | (b,rhs) <- pairs] + + pairs = case bind of + StgNonRec binder rhs -> [(binder,rhs)] + StgRec pairs -> pairs + + binders = [b | (b,_) <- pairs] + + +varsTopBind :: FreeVarsInfo -- Info about the body + -> PlainStgBinding + -> LneM (PlainStgBinding, FreeVarsInfo) + +varsTopBind body_fvs (StgNonRec binder rhs) + = varsRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, _) -> + returnLne (StgNonRec binder rhs2, fvs) + +varsTopBind body_fvs (StgRec pairs) + = let + (binders, rhss) = unzip pairs + in + fixLne (\ ~(_, rec_rhs_fvs) -> + let + scope_fvs = unionFVInfo body_fvs rec_rhs_fvs + in + mapAndUnzip3Lne (varsRhs scope_fvs) pairs `thenLne` \ (rhss2, fvss, _) -> + let + fvs = unionFVInfos fvss + in + returnLne (StgRec (binders `zip` rhss2), fvs) + ) + +\end{code} + +\begin{code} +varsRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> (Id,PlainStgRhs) + -> LneM (PlainStgRhs, FreeVarsInfo, EscVarsSet) + +varsRhs scope_fv_info (binder, StgRhsCon cc con args) + = varsAtoms args `thenLne` \ fvs -> + returnLne (StgRhsCon cc con args, fvs, getFVSet fvs) + +varsRhs scope_fv_info (binder, StgRhsClosure cc _ _ upd args body) + = extendVarEnv [ (a, LambdaBound) | a <- args ] ( + do_body args body `thenLne` \ (body2, body_fvs, body_escs) -> + let + set_of_args = mkUniqSet args + rhs_fvs = body_fvs `minusFVBinders` args + rhs_escs = body_escs `minusUniqSet` set_of_args + binder_info = lookupFVInfo scope_fv_info binder + in + returnLne (StgRhsClosure cc binder_info (getFVs rhs_fvs) upd args body2, + rhs_fvs, rhs_escs) + ) + where + -- Pick out special case of application in body of thunk + do_body [] (StgApp (StgVarAtom f) args _) = varsApp (Just upd) f args + do_body _ other_body = varsExpr other_body +\end{code} + +\begin{code} +varsAtoms :: [PlainStgAtom] + -> LneM FreeVarsInfo + +varsAtoms atoms + = mapLne var_atom atoms `thenLne` \ fvs_lists -> + returnLne (unionFVInfos fvs_lists) + where + var_atom a@(StgLitAtom _) = returnLne emptyFVInfo + var_atom a@(StgVarAtom v) + = lookupVarEnv v `thenLne` \ how_bound -> + returnLne (singletonFVInfo v how_bound stgArgOcc) +\end{code} + +%************************************************************************ +%* * +\subsection[expr-StgVarInfo]{Setting variable info on expressions} +%* * +%************************************************************************ + +@varsExpr@ carries in a monad-ised environment, which binds each +let(rec) variable (ie non top level, not imported, not lambda bound, +not case-alternative bound) to: + - its STG arity, and + - its set of live vars. +For normal variables the set of live vars is just the variable +itself. For let-no-escaped variables, the set of live vars is the set +live at the moment the variable is entered. The set is guaranteed to +have no further let-no-escaped vars in it. + +\begin{code} +varsExpr :: PlainStgExpr + -> LneM (PlainStgExpr, -- Decorated expr + FreeVarsInfo, -- Its free vars (NB free, not live) + EscVarsSet) -- Its escapees, a subset of its free vars; + -- also a subset of the domain of the envt + -- because we are only interested in the escapees + -- for vars which might be turned into + -- let-no-escaped ones. +\end{code} + +The second and third components can be derived in a simple bottom up pass, not +dependent on any decisions about which variables will be let-no-escaped or +not. The first component, that is, the decorated expression, may then depend +on these components, but it in turn is not scrutinised as the basis for any +decisions. Hence no black holes. + +\begin{code} +varsExpr (StgApp lit@(StgLitAtom _) args _) + = --(if null args then id else (trace (ppShow 80 (ppr PprShowAll args)))) ( + returnLne (StgApp lit [] emptyUniqSet, emptyFVInfo, emptyUniqSet) + --) + +varsExpr (StgApp fun@(StgVarAtom f) args _) = varsApp Nothing f args + +varsExpr (StgConApp con args _) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + varsAtoms args `thenLne` \ args_fvs -> + + returnLne (StgConApp con args live_in_cont, args_fvs, getFVSet args_fvs) + +varsExpr (StgPrimApp op args _) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + varsAtoms args `thenLne` \ args_fvs -> + + returnLne (StgPrimApp op args live_in_cont, args_fvs, getFVSet args_fvs) + +varsExpr (StgSCC ty label expr) + = varsExpr expr `thenLne` ( \ (expr2, fvs, escs) -> + returnLne (StgSCC ty label expr2, fvs, escs) ) +\end{code} + +Cases require a little more real work. +\begin{code} +varsExpr (StgCase scrut _ _ uniq alts) + = getVarsLiveInCont `thenLne` \ live_in_cont -> + 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 + in + -- we tell the scrutinee that everything live in the alts + -- is live in it, too. + setVarsLiveInCont live_in_alts ( + varsExpr scrut + ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) -> + lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs -> + let + live_in_whole_case = live_in_alts `unionUniqSets` 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 + ) + where + vars_alts (StgAlgAlts ty alts deflt) + = mapAndUnzip3Lne vars_alg_alt alts + `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> + let + alts_fvs = unionFVInfos alts_fvs_list + alts_escs = unionManyUniqSets 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 + ) + where + vars_alg_alt (con, binders, worthless_use_mask, rhs) + = extendVarEnv [(b, CaseBound) | b <- binders] ( + varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + let + good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders ] + -- records whether each param is used in the RHS + in + returnLne ( + (con, binders, good_use_mask, rhs2), + rhs_fvs `minusFVBinders` binders, + rhs_escs `minusUniqSet` mkUniqSet binders -- ToDo: remove the minusUniqSet; + -- since escs won't include + -- any of these binders + )) + + vars_alts (StgPrimAlts ty alts deflt) + = mapAndUnzip3Lne vars_prim_alt alts + `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) -> + let + alts_fvs = unionFVInfos alts_fvs_list + alts_escs = unionManyUniqSets 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 + ) + where + vars_prim_alt (lit, rhs) + = varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + returnLne ((lit, rhs2), rhs_fvs, rhs_escs) + + vars_deflt StgNoDefault + = returnLne (StgNoDefault, emptyFVInfo, emptyUniqSet) + + vars_deflt (StgBindDefault binder _ rhs) + = extendVarEnv [(binder, CaseBound)] ( + varsExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) -> + let + used_in_rhs = binder `elementOfFVInfo` rhs_fvs + in + returnLne ( + StgBindDefault binder used_in_rhs rhs2, + rhs_fvs `minusFVBinders` [binder], + rhs_escs `minusUniqSet` singletonUniqSet binder + )) +\end{code} + +Lets not only take quite a bit of work, but this is where we convert +then to let-no-escapes, if we wish. + +(Meanwhile, we don't expect to see let-no-escapes...) +\begin{code} +varsExpr (StgLetNoEscape _ _ _ _) = panic "varsExpr: unexpected StgLetNoEscape" + +varsExpr (StgLet bind body) + = isSwitchSetLne {-StgDoLetNoEscapes-} `thenLne` \ want_LNEs -> + + (fixLne (\ ~(_, _, _, no_binder_escapes) -> + let + non_escaping_let = want_LNEs && no_binder_escapes + in + vars_let non_escaping_let bind body + )) `thenLne` \ (new_let, fvs, escs, _) -> + + returnLne (new_let, fvs, escs) +\end{code} + +\begin{code} +#ifdef DPH +-- rest of varsExpr goes here + +#endif {- Data Parallel Haskell -} +\end{code} + +Applications: +\begin{code} +varsApp :: Maybe UpdateFlag -- Just upd <=> this application is + -- the rhs of a thunk binding + -- x = [...] \upd [] -> the_app + -- with specified update flag + -> Id -- Function + -> [PlainStgAtom] -- Arguments + -> LneM (PlainStgExpr, FreeVarsInfo, EscVarsSet) + +varsApp maybe_thunk_body f args + = getVarsLiveInCont `thenLne` \ live_in_cont -> + + varsAtoms args `thenLne` \ args_fvs -> + + lookupVarEnv f `thenLne` \ how_bound -> + + let + n_args = length args + + fun_fvs = singletonFVInfo f how_bound fun_occ + + fun_occ = + case how_bound of + LetrecBound _ arity _ + | n_args == 0 -> stgFakeFunAppOcc -- Function Application + -- with no arguments. + -- used by the lambda lifter. + | arity > n_args -> stgUnsatOcc -- Unsaturated + + + | arity == n_args && + maybeToBool maybe_thunk_body -> -- Exactly saturated, + -- and rhs of thunk + case maybe_thunk_body of + Just Updatable -> stgStdHeapOcc + Just SingleEntry -> stgNoUpdHeapOcc + other -> panic "varsApp" + + | otherwise -> stgNormalOcc + -- record only that it occurs free + + other -> NoStgBinderInfo + -- uninteresting variable + + myself = singletonUniqSet f + + fun_escs = case how_bound of + + LetrecBound _ arity lvs -> + if arity == n_args then + emptyUniqSet -- Function doesn't escape + else + myself -- Inexact application; it does escape + + other -> emptyUniqSet -- Only letrec-bound escapees + -- are interesting + + -- At the moment of the call: + + -- either the function is *not* let-no-escaped, in which case + -- nothing is live except live_in_cont + -- or the function *is* let-no-escaped in which case the + -- variables it uses are live, but still the function + -- itself is not. PS. In this case, the function's + -- live vars should already include those of the + -- continuation, but it does no harm to just union the + -- two regardless. + + live_at_call + = live_in_cont `unionUniqSets` case how_bound of + LetrecBound _ _ lvs -> lvs `minusUniqSet` myself + other -> emptyUniqSet + in + returnLne ( + StgApp (StgVarAtom f) args live_at_call, + fun_fvs `unionFVInfo` args_fvs, + fun_escs `unionUniqSets` (getFVSet args_fvs) + -- All the free vars of the args are disqualified + -- from being let-no-escaped. + ) +\end{code} + +The magic for lets: +\begin{code} +vars_let :: Bool -- True <=> yes, we are let-no-escaping this let + -> PlainStgBinding -- bindings + -> PlainStgExpr -- body + -> LneM (PlainStgExpr, -- new let + FreeVarsInfo, -- variables free in the whole let + EscVarsSet, -- variables that escape from the whole let + Bool) -- True <=> none of the binders in the bindings + -- is among the escaping vars + +vars_let let_no_escape bind body + = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) -> + + -- Do the bindings, setting live_in_cont to empty if + -- 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) + (vars_bind rec_bind_lvs rec_body_fvs bind) + `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) -> + + -- The live variables of this binding are the ones which are live + -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs) + -- together with the live_in_cont ones + lookupLiveVarsForSet (bind_fvs `minusFVBinders` binders) `thenLne` \ lvs_from_fvs -> + let + bind_lvs = lvs_from_fvs `unionUniqSets` live_in_cont + in + + -- bind_fvs and bind_escs still include the binders of the let(rec) + -- but bind_lvs does not + + -- Do the body + extendVarEnv env_ext ( + varsExpr body `thenLne` \ (body2, body_fvs, body_escs) -> + lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs -> + + returnLne (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) + + )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, + body2, body_fvs, body_escs, body_lvs) -> + + + -- Compute the new let-expression + let + new_let = if let_no_escape then + -- trace "StgLetNoEscape!" ( + StgLetNoEscape live_in_whole_let bind_lvs bind2 body2 + -- ) + else + StgLet bind2 body2 + + free_in_whole_let + = (bind_fvs `unionFVInfo` body_fvs) `minusFVBinders` binders + + live_in_whole_let + = bind_lvs `unionUniqSets` (body_lvs `minusUniqSet` set_of_binders) + + real_bind_escs = if let_no_escape then + bind_escs + else + getFVSet bind_fvs + -- Everything escapes which is free in the bindings + + let_escs = (real_bind_escs `unionUniqSets` body_escs) `minusUniqSet` set_of_binders + + all_escs = bind_escs `unionUniqSets` body_escs -- Still includes binders of + -- this let(rec) + + no_binder_escapes = isEmptyUniqSet (set_of_binders `intersectUniqSets` all_escs) + -- Mustn't depend on the passed-in let_no_escape flag, since + -- no_binder_escapes is used by the caller to derive the flag! + in + returnLne ( + new_let, + free_in_whole_let, + let_escs, + no_binder_escapes + )) + where + binders = case bind of + StgNonRec binder rhs -> [binder] + StgRec pairs -> map fst pairs + set_of_binders = mkUniqSet binders + + mk_binding bind_lvs (binder,rhs) + = (binder, + LetrecBound False -- Not top level + (stgArity rhs) + live_vars + ) + where + live_vars = if let_no_escape then + bind_lvs `unionUniqSets` singletonUniqSet binder + else + singletonUniqSet binder + + vars_bind :: PlainStgLiveVars + -> FreeVarsInfo -- Free var info for body of binding + -> PlainStgBinding + -> LneM (PlainStgBinding, + FreeVarsInfo, EscVarsSet, -- free vars; escapee vars + [(Id, HowBound)]) + -- extension to environment + + vars_bind rec_bind_lvs rec_body_fvs (StgNonRec binder rhs) + = varsRhs rec_body_fvs (binder,rhs) `thenLne` \ (rhs2, fvs, escs) -> + let + env_ext = [mk_binding rec_bind_lvs (binder,rhs)] + in + returnLne (StgNonRec binder rhs2, fvs, escs, env_ext) + + vars_bind rec_bind_lvs rec_body_fvs (StgRec pairs) + = let + (binders, rhss) = unzip pairs + env_ext = map (mk_binding rec_bind_lvs) pairs + in + extendVarEnv env_ext ( + fixLne (\ ~(_, rec_rhs_fvs, _, _) -> + let + rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs + in + mapAndUnzip3Lne (varsRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) -> + let + fvs = unionFVInfos fvss + escs = unionManyUniqSets escss + in + returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext) + )) +\end{code} + +%************************************************************************ +%* * +\subsection[LNE-monad]{A little monad for this let-no-escaping pass} +%* * +%************************************************************************ + +There's a lot of stuff to pass around, so we use this @LneM@ monad to +help. All the stuff here is only passed {\em down}. + +\begin{code} +type LneM a = Bool -- True <=> do let-no-escapes + -> IdEnv HowBound + -> PlainStgLiveVars -- vars live in continuation + -> a + +type Arity = Int + +data HowBound + = ImportBound + | CaseBound + | LambdaBound + | LetrecBound + Bool -- True <=> bound at top level + Arity -- Arity + PlainStgLiveVars -- Live vars... see notes below +\end{code} + +For a let(rec)-bound variable, x, we record what varibles are live if +x is live. For "normal" variables that is just x alone. If x is +a let-no-escaped variable then x is represented by a code pointer and +a stack pointer (well, one for each stack). So all of the variables +needed in the execution of x are live if x is, and are therefore recorded +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 + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenLne #-} +{-# INLINE thenLne_ #-} +{-# INLINE returnLne #-} +#endif + +returnLne :: a -> LneM a +returnLne e sw env lvs_cont = e + +thenLne :: LneM a -> (a -> LneM b) -> LneM b +(m `thenLne` k) sw env lvs_cont + = case (m sw env lvs_cont) of + m_result -> k m_result sw env lvs_cont + +thenLne_ :: LneM a -> LneM b -> LneM b +(m `thenLne_` k) sw env lvs_cont + = case (m sw env lvs_cont) of + _ -> k sw env lvs_cont + +mapLne :: (a -> LneM b) -> [a] -> LneM [b] +mapLne f [] = returnLne [] +mapLne f (x:xs) + = f x `thenLne` \ r -> + mapLne f xs `thenLne` \ rs -> + returnLne (r:rs) + +mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) + +mapAndUnzipLne f [] = returnLne ([],[]) +mapAndUnzipLne f (x:xs) + = f x `thenLne` \ (r1, r2) -> + mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) -> + returnLne (r1:rs1, r2:rs2) + +mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d]) + +mapAndUnzip3Lne f [] = returnLne ([],[],[]) +mapAndUnzip3Lne f (x:xs) + = f x `thenLne` \ (r1, r2, r3) -> + mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) -> + returnLne (r1:rs1, r2:rs2, r3:rs3) + +fixLne :: (a -> LneM a) -> LneM a +fixLne expr sw env lvs_cont = result + where + result = expr result sw env lvs_cont +-- ^^^^^^ ------ ^^^^^^ +\end{code} + +Functions specific to this monad: +\begin{code} +{- NOT USED: +ifSwitchSetLne :: GlobalSwitch -> LneM a -> LneM a -> LneM a +ifSwitchSetLne switch then_ else_ switch_checker env lvs_cont + = (if switch_checker switch then then_ else else_) switch_checker env lvs_cont +-} + +isSwitchSetLne :: LneM Bool +isSwitchSetLne want_LNEs env lvs_cont + = want_LNEs + +getVarsLiveInCont :: LneM PlainStgLiveVars +getVarsLiveInCont sw env lvs_cont = lvs_cont + +setVarsLiveInCont :: PlainStgLiveVars -> LneM a -> LneM a +setVarsLiveInCont new_lvs_cont expr sw env lvs_cont + = expr sw env new_lvs_cont + +extendVarEnv :: [(Id, HowBound)] -> LneM a -> LneM a +extendVarEnv extension expr sw env lvs_cont + = expr sw (growIdEnvList env extension) lvs_cont + +lookupVarEnv :: Id -> LneM HowBound +lookupVarEnv v sw env lvs_cont + = returnLne ( + case (lookupIdEnv env v) of + Just xx -> xx + Nothing -> --false:ASSERT(not (isLocallyDefined v)) + ImportBound + ) sw env lvs_cont + +-- The result of lookupLiveVarsForSet, a set of live variables, is +-- only ever tacked onto a decorated expression. It is never used as +-- the basis of a control decision, which might give a black hole. + +lookupLiveVarsForSet :: FreeVarsInfo -> LneM PlainStgLiveVars + +lookupLiveVarsForSet fvs sw env lvs_cont + = returnLne (unionManyUniqSets (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 + Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr PprShowAll v) + else + emptyUniqSet +\end{code} + + +%************************************************************************ +%* * +\subsection[Free-var info]{Free variable information} +%* * +%************************************************************************ + +\begin{code} +type FreeVarsInfo = IdEnv (Id, Bool, StgBinderInfo) + -- If f is mapped to NoStgBinderInfo, that means + -- that f *is* mentioned (else it wouldn't be in the + -- IdEnv at all), but only in a saturated applications. + -- + -- All case/lambda-bound things are also mapped to + -- NoStgBinderInfo, since we aren't interested in their + -- occurence info. + -- + -- The Bool is True <=> the Id is top level letrec bound + +type EscVarsSet = UniqSet Id +\end{code} + +\begin{code} +emptyFVInfo :: FreeVarsInfo +emptyFVInfo = nullIdEnv + +singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo +singletonFVInfo id ImportBound info = nullIdEnv +singletonFVInfo id (LetrecBound top_level _ _) info = unitIdEnv id (id, top_level, info) +singletonFVInfo id other info = unitIdEnv id (id, False, info) + +unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo +unionFVInfo fv1 fv2 = combineIdEnvs plusFVInfo fv1 fv2 + +unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo +unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs + +minusFVBinders :: FreeVarsInfo -> [Id] -> FreeVarsInfo +minusFVBinders fv ids = fv `delManyFromIdEnv` ids + +elementOfFVInfo :: Id -> FreeVarsInfo -> Bool +elementOfFVInfo id fvs = maybeToBool (lookupIdEnv fvs id) + +lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo +lookupFVInfo fvs id = case lookupIdEnv fvs id of + Nothing -> NoStgBinderInfo + Just (_,_,info) -> info + +getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +getFVs fvs = [id | (id,False,_) <- rngIdEnv fvs] + +getFVSet :: FreeVarsInfo -> UniqSet Id +getFVSet fvs = mkUniqSet (getFVs fvs) + +plusFVInfo (id1,top1,info1) (id2,top2,info2) + = ASSERT (id1 == id2 && top1 == top2) + (id1, top1, combineStgBinderInfo info1 info2) +\end{code} + +\begin{code} +rhsArity :: PlainStgRhs -> Arity +rhsArity (StgRhsCon _ _ _) = 0 +rhsArity (StgRhsClosure _ _ _ _ args _) = length args +\end{code} + + + diff --git a/ghc/compiler/simplStg/UpdAnal.hi b/ghc/compiler/simplStg/UpdAnal.hi new file mode 100644 index 0000000..c45043e --- /dev/null +++ b/ghc/compiler/simplStg/UpdAnal.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UpdAnal where +import Id(Id) +import StgSyn(StgBinding) +updateAnalyse :: [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs new file mode 100644 index 0000000..a50e672 --- /dev/null +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -0,0 +1,510 @@ +\section{Update Avoidance Analyser} -*-haskell-literate-*- + +(c) Simon Marlow, Andre Santos 1992-1993 +(c) The AQUA Project, Glasgow University, 1995 + +%----------------------------------------------------------------------------- +\subsection{Module Interface} + +\begin{code} +#include "HsVersions.h" +\end{code} + +> module UpdAnal ( updateAnalyse ) where +> +> IMPORT_Trace + +> import AbsUniType ( splitTyArgs, splitType, Class, TyVarTemplate, +> TauType(..) +> ) +> import Id +> import IdEnv +> import IdInfo +> import Outputable ( isExported ) +> import Pretty +> import SrcLoc ( mkUnknownSrcLoc ) +> import StgSyn +> import UniqSet +> import Unique ( getBuiltinUniques ) +> import Util + +%----------------------------------------------------------------------------- +\subsection{Reverse application} + +This is used instead of lazy pattern bindings to avoid space leaks. + +> infixr 3 =: +> a =: k = k a + +%----------------------------------------------------------------------------- +\subsection{Types} + +List of closure references + +> type Refs = IdSet +> x `notInRefs` y = not (x `elementOfUniqSet` y) + +A closure value: environment of closures that are evaluated on entry, +a list of closures that are referenced from the result, and an +abstract value for the evaluated closure. + +An IdEnv is used for the reference counts, as these environments are +combined often. A generic environment is used for the main environment +mapping closure names to values; as a common operation is extension of +this environment, this representation should be efficient. + +> -- partain: funny synonyms to cope w/ the fact +> -- that IdEnvs know longer know what their keys are +> -- (94/05) ToDo: improve +> type IdEnvInt = IdEnv (Id, Int) +> type IdEnvClosure = IdEnv (Id, Closure) + +> -- backward-compat functions +> null_IdEnv :: IdEnv (Id, a) +> null_IdEnv = nullIdEnv +> +> unit_IdEnv :: Id -> a -> IdEnv (Id, a) +> unit_IdEnv k v = unitIdEnv k (k, v) +> +> mk_IdEnv :: [(Id, a)] -> IdEnv (Id, a) +> mk_IdEnv pairs = mkIdEnv [ (k, (k,v)) | (k,v) <- pairs ] +> +> grow_IdEnv :: IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) +> grow_IdEnv env1 env2 = growIdEnv env1 env2 +> +> addOneTo_IdEnv :: IdEnv (Id, a) -> Id -> a -> IdEnv (Id, a) +> addOneTo_IdEnv env k v = addOneToIdEnv env k (k, v) +> +> combine_IdEnvs :: (a->a->a) -> IdEnv (Id, a) -> IdEnv (Id, a) -> IdEnv (Id, a) +> combine_IdEnvs combiner env1 env2 = combineIdEnvs new_combiner env1 env2 +> where +> new_combiner (id, x) (_, y) = (id, combiner x y) +> +> dom_IdEnv :: IdEnv (Id, a) -> Refs +> dom_IdEnv env = mkUniqSet [ i | (i,_) <- rngIdEnv env ] +> +> lookup_IdEnv :: IdEnv (Id, a) -> Id -> Maybe a +> lookup_IdEnv env key = case lookupIdEnv env key of +> Nothing -> Nothing +> Just (_,a) -> Just a +> -- end backward compat stuff + +> type Closure = (IdEnvInt, Refs, AbFun) + +> type AbVal = IdEnvClosure -> Closure +> data AbFun = Fun (Closure -> Closure) + +> -- partain: speeding-up stuff +> +> type CaseBoundVars = IdSet +> noCaseBound = emptyUniqSet +> isCaseBound = elementOfUniqSet +> x `notCaseBound` y = not (isCaseBound x y) +> moreCaseBound :: CaseBoundVars -> [Id] -> CaseBoundVars +> moreCaseBound old new = old `unionUniqSets` mkUniqSet new +> +> -- end speeding-up + +%---------------------------------------------------------------------------- +\subsection{Environment lookup} + +If the requested value is not in the environment, we return an unknown +value. Lookup is designed to be partially applied to a variable, and +repeatedly applied to different environments after that. + +> lookup v +> | isImportedId v +> = const (case updateInfoMaybe (getIdUpdateInfo v) of +> Nothing -> unknownClosure +> Just spec -> convertUpdateSpec spec) +> | otherwise +> = \p -> case lookup_IdEnv p v of +> Just b -> b +> Nothing -> unknownClosure + +%----------------------------------------------------------------------------- +Represent a list of references as an ordered list. + +> mkRefs :: [Id] -> Refs +> mkRefs = mkUniqSet + +> noRefs :: Refs +> noRefs = emptyUniqSet + +> elemRefs = elementOfUniqSet + +> merge :: [Refs] -> Refs +> merge xs = foldr merge2 emptyUniqSet xs + +> merge2 :: Refs -> Refs -> Refs +> merge2 = unionUniqSets + +%----------------------------------------------------------------------------- +\subsection{Some non-interesting values} + +bottom will be used for abstract values that are not functions. +Hopefully its value will never be required! + +> bottom :: AbFun +> bottom = panic "Internal: (Update Analyser) bottom" + +noClosure is a value that is definitely not a function (i.e. primitive +values and constructor applications). unknownClosure is a value about +which we have no information at all. This should occur rarely, but +could happen when an id is imported and the exporting module was not +compiled with the update analyser. + +> noClosure, unknownClosure :: Closure +> noClosure = (null_IdEnv, noRefs, bottom) +> unknownClosure = (null_IdEnv, noRefs, dont_know noRefs) + +dont_know is a black hole: it is something we know nothing about. +Applying dont_know to anything will generate a new dont_know that simply +contains more buried references. + +> dont_know :: Refs -> AbFun +> dont_know b' +> = Fun (\(c,b,f) -> let b'' = dom_IdEnv c `merge2` b `merge2` b' +> in (null_IdEnv, b'', dont_know b'')) + +%----------------------------------------------------------------------------- + +> getrefs :: IdEnvClosure -> [AbVal] -> Refs -> Refs +> getrefs p vs rest = foldr merge2 rest (getrefs' (map ($ p) vs)) +> where +> getrefs' [] = [] +> getrefs' ((c,b,_):rs) = dom_IdEnv c : b : getrefs' rs + +%----------------------------------------------------------------------------- + +udData is used when we are putting a list of closure references into a +data structure, or something else that we know nothing about. + +> udData :: [PlainStgAtom] -> CaseBoundVars -> AbVal +> udData vs cvs +> = \p -> (null_IdEnv, getrefs p local_ids noRefs, bottom) +> where local_ids = [ lookup v | (StgVarAtom v) <- vs, v `notCaseBound` cvs ] + +%----------------------------------------------------------------------------- +\subsection{Analysing an atom} + +> udAtom :: CaseBoundVars -> PlainStgAtom -> AbVal +> udAtom cvs (StgVarAtom v) +> | v `isCaseBound` cvs = const unknownClosure +> | otherwise = lookup v +> +> udAtom cvs _ = const noClosure + +%----------------------------------------------------------------------------- +\subsection{Analysing an STG expression} + +> ud :: PlainStgExpr -- Expression to be analysed +> -> CaseBoundVars -- List of case-bound vars +> -> IdEnvClosure -- Current environment +> -> (PlainStgExpr, AbVal) -- (New expression, abstract value) +> +> ud e@(StgPrimApp _ vs _) cvs p = (e, udData vs cvs) +> ud e@(StgConApp _ vs _) cvs p = (e, udData vs cvs) +> ud e@(StgSCC ty lab a) cvs p = ud a cvs p =: \(a', abval_a) -> +> (StgSCC ty lab a', abval_a) + +Here is application. The first thing to do is analyse the head, and +get an abstract function. Multiple applications are performed by using +a foldl with the function doApp. Closures are actually passed to the +abstract function iff the atom is a local variable. + +I've left the type signature for doApp in to make things a bit clearer. + +> ud e@(StgApp a atoms lvs) cvs p +> = (e, abval_app) +> where +> abval_atoms = map (udAtom cvs) atoms +> abval_a = udAtom cvs a +> abval_app = \p -> +> let doApp :: Closure -> AbVal -> Closure +> doApp (c, b, Fun f) abval_atom = +> abval_atom p =: \e@(_,_,_) -> +> f e =: \(c', b', f') -> +> (combine_IdEnvs (+) c' c, b', f') +> in foldl doApp (abval_a p) abval_atoms + +> ud (StgCase expr lve lva uniq alts) cvs p +> = ud expr cvs p =: \(expr', abval_selector) -> +> udAlt alts p =: \(alts', abval_alts) -> +> let +> abval_case = \p -> +> abval_selector p =: \(c, b, abfun_selector) -> +> abval_alts p =: \(cs, bs, abfun_alts) -> +> let bs' = b `merge2` bs in +> (combine_IdEnvs (+) c cs, bs', dont_know bs') +> in +> (StgCase expr' lve lva uniq alts', abval_case) +> where +> +> udAlt :: PlainStgCaseAlternatives +> -> IdEnvClosure +> -> (PlainStgCaseAlternatives, AbVal) +> +> udAlt (StgAlgAlts ty [alt] StgNoDefault) p +> = udAlgAlt p alt =: \(alt', abval) -> +> (StgAlgAlts ty [alt'] StgNoDefault, abval) +> udAlt (StgAlgAlts ty [] def) p +> = udDef def p =: \(def', abval) -> +> (StgAlgAlts ty [] def', abval) +> udAlt (StgAlgAlts ty alts def) p +> = udManyAlts alts def udAlgAlt (StgAlgAlts ty) p +> udAlt (StgPrimAlts ty [alt] StgNoDefault) p +> = udPrimAlt p alt =: \(alt', abval) -> +> (StgPrimAlts ty [alt'] StgNoDefault, abval) +> udAlt (StgPrimAlts ty [] def) p +> = udDef def p =: \(def', abval) -> +> (StgPrimAlts ty [] def', abval) +> udAlt (StgPrimAlts ty alts def) p +> = udManyAlts alts def udPrimAlt (StgPrimAlts ty) p +> +> udPrimAlt p (l, e) +> = ud e cvs p =: \(e', v) -> ((l, e'), v) +> +> udAlgAlt p (id, vs, use_mask, e) +> = ud e (moreCaseBound cvs vs) p =: \(e', v) -> ((id, vs, use_mask, e'), v) +> +> udDef :: PlainStgCaseDefault +> -> IdEnvClosure +> -> (PlainStgCaseDefault, AbVal) +> +> udDef StgNoDefault p +> = (StgNoDefault, \p -> (null_IdEnv, noRefs, dont_know noRefs)) +> udDef (StgBindDefault v is_used expr) p +> = ud expr (moreCaseBound cvs [v]) p =: \(expr', abval) -> +> (StgBindDefault v is_used expr', abval) +> +> udManyAlts alts def udalt stgalts p +> = udDef def p =: \(def', abval_def) -> +> unzip (map (udalt p) alts) =: \(alts', abvals_alts) -> +> let +> abval_alts = \p -> +> abval_def p =: \(cd, bd, _) -> +> unzip3 (map ($ p) abvals_alts) =: \(cs, bs, _) -> +> let bs' = merge (bd:bs) in +> (foldr (combine_IdEnvs max) cd cs, bs', dont_know bs') +> in (stgalts alts' def', abval_alts) + +The heart of the analysis: here we decide whether to make a specific +closure updatable or not, based on the results of analysing the body. + +> ud (StgLet binds body) cvs p +> = udBinding binds cvs p =: \(binds', vs, abval1, abval2) -> +> abval1 p =: \(cs, p') -> +> grow_IdEnv p p' =: \p -> +> ud body cvs p =: \(body', abval_body) -> +> abval_body p =: \(c, b, abfun) -> +> tag b (combine_IdEnvs (+) cs c) binds' =: \tagged_binds -> +> let +> abval p +> = abval2 p =: \(c1, p') -> +> abval_body (grow_IdEnv p p') =: \(c2, b, abfun) -> +> (combine_IdEnvs (+) c1 c2, b, abfun) +> in +> (StgLet tagged_binds body', abval) + +%----------------------------------------------------------------------------- +\subsection{Analysing bindings} + +For recursive sets of bindings we perform one iteration of a fixed +point algorithm, using (dont_know fv) as a safe approximation to the +real fixed point, where fv are the (mappings in the environment of +the) free variables of the function. + +We'll return two new environments, one with the new closures in and +one without. There's no point in carrying around closures when their +respective bindings have already been analysed. + +We don't need to find anything out about closures with arguments, +constructor closures etc. + +> udBinding :: PlainStgBinding +> -> CaseBoundVars +> -> IdEnvClosure +> -> (PlainStgBinding, +> [Id], +> IdEnvClosure -> (IdEnvInt, IdEnvClosure), +> IdEnvClosure -> (IdEnvInt, IdEnvClosure)) +> +> udBinding (StgNonRec v rhs) cvs p +> = udRhs rhs cvs p =: \(rhs', abval) -> +> abval p =: \(c, b, abfun) -> +> let +> abval_rhs a = \p -> +> abval p =: \(c, b, abfun) -> +> (c, unit_IdEnv v (a, b, abfun)) +> a = case rhs of +> StgRhsClosure _ _ _ Updatable [] _ -> unit_IdEnv v 1 +> _ -> null_IdEnv +> in (StgNonRec v rhs', [v], abval_rhs a, abval_rhs null_IdEnv) +> +> udBinding (StgRec ve) cvs p +> = (StgRec ve', [], abval_rhs, abval_rhs) +> where +> (vs, ve', abvals) = unzip3 (map udBind ve) +> fv = (map lookup . filter (`notCaseBound` cvs) . concat . map collectfv) ve +> vs' = mkRefs vs +> abval_rhs = \p -> +> let +> p' = grow_IdEnv (mk_IdEnv (vs `zip` (repeat closure))) p +> closure = (null_IdEnv, fv', dont_know fv') +> fv' = getrefs p fv vs' +> (cs, ps) = unzip (doRec vs abvals) +> +> doRec [] _ = [] +> doRec (v:vs) (abval:as) +> = abval p' =: \(c,b,abfun) -> +> (c, (v,(null_IdEnv, b, abfun))) : doRec vs as +> +> in +> (foldr (combine_IdEnvs (+)) null_IdEnv cs, mk_IdEnv ps) +> +> udBind (v,rhs) +> = udRhs rhs cvs p =: \(rhs', abval) -> +> (v,(v,rhs'), abval) +> +> collectfv (_, StgRhsClosure _ _ fv _ _ _) = fv +> collectfv (_, StgRhsCon _ con args) = [ v | (StgVarAtom v) <- args ] + +%----------------------------------------------------------------------------- +\subsection{Analysing Right-Hand Sides} + +> udRhs e@(StgRhsCon _ _ vs) cvs p = (e, udData vs cvs) +> +> udRhs (StgRhsClosure cc bi fv u [] body) cvs p +> = ud body cvs p =: \(body', abval_body) -> +> (StgRhsClosure cc bi fv u [] body', abval_body) + +Here is the code for closures with arguments. A closure has a number +of arguments, which correspond to a set of nested lambda expressions. +We build up the analysis using foldr with the function doLam to +analyse each lambda expression. + +> udRhs (StgRhsClosure cc bi fv u args body) cvs p +> = ud body cvs p =: \(body', abval_body) -> +> let +> fv' = map lookup (filter (`notCaseBound` cvs) fv) +> abval_rhs = \p -> +> foldr doLam (\b -> abval_body) args (getrefs p fv' noRefs) p +> in +> (StgRhsClosure cc bi fv u args body', abval_rhs) +> where +> +> doLam :: Id -> (Refs -> AbVal) -> Refs -> AbVal +> doLam i f b p +> = (null_IdEnv, b, +> Fun (\x@(c',b',_) -> +> let b'' = dom_IdEnv c' `merge2` b' `merge2` b in +> f b'' (addOneTo_IdEnv p i x))) + +%----------------------------------------------------------------------------- +\subsection{Adjusting Update flags} + +The closure is tagged single entry iff it is used at most once, it is +not referenced from inside a data structure or function, and it has no +arguments (closures with arguments are re-entrant). + +> tag :: Refs -> IdEnvInt -> PlainStgBinding -> PlainStgBinding +> +> tag b c r@(StgNonRec v (StgRhsClosure cc bi fv Updatable [] body)) +> = if (v `notInRefs` b) && (lookupc c v <= 1) +> then -- trace "One!" ( +> StgNonRec v (StgRhsClosure cc bi fv SingleEntry [] body) +> -- ) +> else r +> tag b c other = other +> +> lookupc c v = case lookup_IdEnv c v of +> Just n -> n +> Nothing -> 0 + +%----------------------------------------------------------------------------- +\subsection{Top Level analysis} + +Should we tag top level closures? This could have good implications +for CAFs (i.e. they could be made non-updateable if only used once, +thus preventing a space leak). + +> updateAnalyse :: PlainStgProgram -> PlainStgProgram {- Exported -} +> updateAnalyse bs +> = udProgram bs null_IdEnv + +> udProgram :: PlainStgProgram -> IdEnvClosure -> PlainStgProgram +> udProgram [] p = [] +> udProgram (d:ds) p +> = udBinding d noCaseBound p =: \(d', vs, _, abval_bind) -> +> abval_bind p =: \(_, p') -> +> grow_IdEnv p p' =: \p'' -> +> attachUpdateInfoToBinds d' p'' =: \d'' -> +> d'' : udProgram ds p'' + +%----------------------------------------------------------------------------- +\subsection{Exporting Update Information} + +Convert the exported representation of a function's update function +into a real Closure value. + +> convertUpdateSpec :: UpdateSpec -> Closure +> convertUpdateSpec = mkClosure null_IdEnv noRefs noRefs + +> mkClosure :: IdEnvInt -> Refs -> Refs -> UpdateSpec -> Closure +> +> mkClosure c b b' [] = (c, b', dont_know b') +> mkClosure c b b' (0 : ns) = (null_IdEnv, b, Fun (\ _ -> mkClosure c b b' ns)) +> mkClosure c b b' (1 : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> +> mkClosure +> (combine_IdEnvs (+) c c') +> (dom_IdEnv c' `merge2` b'' `merge2` b) +> (b'' `merge2` b') +> ns )) +> mkClosure c b b' (n : ns) = (null_IdEnv, b, Fun (\ (c',b'',f) -> +> mkClosure c +> (dom_IdEnv c' `merge2` b'' `merge2` b) +> (dom_IdEnv c' `merge2` b'' `merge2` b') +> ns )) + +Convert a Closure into a representation that can be placed in a .hi file. + +> mkUpdateSpec :: Id -> Closure -> UpdateSpec +> mkUpdateSpec v f = {- removeSuperfluous2s -} (map countUses ids) +> where +> (c,b,_) = foldl doApp f ids +> ids = map mkid (getBuiltinUniques arity) +> mkid u = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc +> countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2 +> noType = panic "UpdAnal: no type!" +> +> doApp (c,b,Fun f) i +> = f (unit_IdEnv i 1, noRefs, dont_know noRefs) =: \(c',b',f') -> +> (combine_IdEnvs (+) c' c, b', f') +> +> (_,dict_tys,tau_ty) = (splitType . getIdUniType) v +> (reg_arg_tys, _) = splitTyArgs tau_ty +> arity = length dict_tys + length reg_arg_tys + + removeSuperfluous2s = reverse . dropWhile (> 1) . reverse + +%----------------------------------------------------------------------------- +\subsection{Attaching the update information to top-level bindings} + +This is so that the information can later be retrieved for printing +out in the .hi file. This is not an ideal solution, however it will +suffice for now. + +> attachUpdateInfoToBinds b p +> = case b of +> StgNonRec v rhs -> StgNonRec (attachOne v) rhs +> StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ] +> +> where attachOne v +> | isExported v +> = let c = lookup v p in +> addIdUpdateInfo v +> (mkUpdateInfo (mkUpdateSpec v c)) +> | otherwise = v + +%----------------------------------------------------------------------------- diff --git a/ghc/compiler/specialise/SpecTyFuns.hi b/ghc/compiler/specialise/SpecTyFuns.hi new file mode 100644 index 0000000..44f6c54 --- /dev/null +++ b/ghc/compiler/specialise/SpecTyFuns.hi @@ -0,0 +1,29 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SpecTyFuns where +import Bag(Bag) +import Class(Class) +import Id(Id) +import Maybes(Labda(..)) +import Pretty(PprStyle, Pretty(..), PrettyRep) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +type ConstraintVector = [Bool] +data Labda a = Hamna | Ni a +type Pretty = Int -> Bool -> PrettyRep +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +argTysMatchSpecTys_error :: [Labda UniType] -> [UniType] -> Labda (Int -> Bool -> PrettyRep) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +isUnboxedSpecialisation :: [Labda UniType] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkConstraintVector :: [TyVarTemplate] -> [(Class, TyVarTemplate)] -> [Bool] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} +mkSpecialisedCon :: Id -> [UniType] -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)S" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprSpecErrs :: PprStyle -> Bag (Id, [Labda UniType]) -> Bag (Id, [Labda UniType]) -> Bag (TyCon, [Labda UniType]) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LSLL" _N_ _N_ #-} +specialiseCallTys :: Bool -> Bool -> Bool -> [Bool] -> [UniType] -> [Labda UniType] + {-# GHC_PRAGMA _A_ 5 _U_ 12211 _N_ _S_ "ELLLL" _N_ _N_ #-} +specialiseConstrTys :: [UniType] -> [Labda UniType] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/specialise/SpecTyFuns.lhs b/ghc/compiler/specialise/SpecTyFuns.lhs new file mode 100644 index 0000000..39fbd17 --- /dev/null +++ b/ghc/compiler/specialise/SpecTyFuns.lhs @@ -0,0 +1,293 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} + +\begin{code} +#include "HsVersions.h" + +module SpecTyFuns ( + specialiseCallTys, + ConstraintVector(..), + mkConstraintVector, + isUnboxedSpecialisation, + + specialiseConstrTys, + mkSpecialisedCon, + + argTysMatchSpecTys_error, + + pprSpecErrs, + + Maybe(..), Pretty(..), UniType + ) where + +import AbsUniType +import Bag ( Bag, isEmptyBag, bagToList ) +import FiniteMap ( FiniteMap, emptyFM, addListToFM_C, + keysFM, lookupWithDefaultFM + ) +import Id ( mkSameSpecCon, getIdUniType, + isDictFunId, isConstMethodId, Id ) +import Maybes +import Outputable +import Pretty +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[@specialiseTys@]{Determine specialising types} +%* * +%************************************************************************ + +@specialiseCallTys@ works out which type args don't need to be specialised on, +based on flags, the overloading constraint vector, and the types. + +\begin{code} +specialiseCallTys :: Bool -- Specialise on all type args + -> Bool -- Specialise on unboxed type args + -> Bool -- Specialise on overloaded type args + -> ConstraintVector -- Tells which type args are overloaded + -> [UniType] -- Type args + -> [Maybe UniType] -- Nothings replace non-specialised type args + +specialiseCallTys True _ _ cvec tys + = map Just tys +specialiseCallTys False spec_unboxed spec_overloading cvec tys + = zipWith spec_ty_other cvec tys + where + spec_ty_other c ty | (spec_unboxed && isUnboxedDataType ty) + || (spec_overloading && c) + = Just ty + | otherwise + = Nothing + +type ConstraintVector = [Bool] -- True for constrained tyvar, false otherwise + +mkConstraintVector :: [TyVarTemplate] + -> [(Class,TyVarTemplate)] + -> ConstraintVector + +mkConstraintVector tyvars class_tyvar_pairs + = [tyvar `elem` constrained_tyvars | tyvar <- tyvars] + where + constrained_tyvars = map snd class_tyvar_pairs -- May contain dups +\end{code} + +\begin{code} +isUnboxedSpecialisation :: [Maybe UniType] -> Bool +isUnboxedSpecialisation tys + = any is_unboxed tys + where + is_unboxed (Just ty) = isUnboxedDataType ty + is_unboxed Nothing = False +\end{code} + +@specialiseConstrTys@ works out which type args don't need to be +specialised on. We only speciailise on unboxed types. + +\begin{code} +specialiseConstrTys :: [UniType] + -> [Maybe UniType] + +specialiseConstrTys tys + = map maybe_unboxed_ty tys + where + maybe_unboxed_ty ty = case isUnboxedDataType ty of + True -> Just ty + False -> Nothing +\end{code} + +\begin{code} +mkSpecialisedCon :: Id -> [UniType] -> Id +mkSpecialisedCon con tys + = if spec_reqd + then mkSameSpecCon spec_tys con + else con + where + spec_tys = specialiseConstrTys tys + spec_reqd = maybeToBool (firstJust spec_tys) +\end{code} + +@argTysMatchSpecTys@ checks if a list of argument types is consistent +with a list of specialising types. An error message is returned if not. +\begin{code} +argTysMatchSpecTys_error :: [Maybe UniType] + -> [UniType] + -> Maybe Pretty +argTysMatchSpecTys_error spec_tys arg_tys + = if match spec_tys arg_tys + then Nothing + else Just (ppSep [ppStr "Spec and Arg Types Inconsistent:", + ppStr "spectys=", ppSep [pprMaybeTy PprDebug ty | ty <- spec_tys], + ppStr "argtys=", ppSep [pprParendUniType PprDebug ty | ty <- arg_tys]]) + where + match (Nothing:spec_tys) (arg:arg_tys) + = not (isUnboxedDataType arg) && + match spec_tys arg_tys + match (Just spec:spec_tys) (arg:arg_tys) + = case (cmpUniType True{-properly-} spec arg) of + EQ_ -> match spec_tys arg_tys + other -> False + match [] [] = True + match _ _ = False +\end{code} + +@pprSpecErrs@ prints error and warning information +about imported specialisations which do not exist. + +\begin{code} +pprSpecErrs :: PprStyle + -> (Bag (Id,[Maybe UniType])) -- errors + -> (Bag (Id,[Maybe UniType])) -- warnings + -> (Bag (TyCon,[Maybe UniType])) -- errors + -> Pretty + +pprSpecErrs sty spec_errs spec_warn spec_tyerrs + | not any_errs && not any_warn + = ppNil + + | otherwise + = ppAboves [if any_errs then ppAboves [ + ppStr "SPECIALISATION ERRORS (Essential):", + ppAboves (map pp_module_errs use_modules), + ppStr "***" + ] + else + ppNil, + if any_warn then ppAboves [ + ppStr "SPECIALISATION MESSAGES (Desirable):", + ppAboves (map pp_module_warn use_modules), + ppStr "***" + ] + else + ppNil + ] + where + any_errs = not (isEmptyBag spec_errs) || not (isEmptyBag spec_tyerrs) + any_warn = not (isEmptyBag spec_warn) + + mk_module_fm errs_bag + = addListToFM_C (++) emptyFM errs_list + where + errs_list = map add_name (bagToList errs_bag) + + add_name (id, tys) = (mod, [(name, id, tys)]) + where + (mod,name) = getOrigName id + + tyerrs_fm = mk_module_fm spec_tyerrs + errs_fm = mk_module_fm spec_errs + warn_fm = mk_module_fm spec_warn + + module_names = concat [keysFM errs_fm, keysFM warn_fm, keysFM tyerrs_fm] + sorted_modules = map head (equivClasses _CMP_STRING_ module_names) + + -- Ensure any dfun instance specialisations (module _NIL_) are printed last + -- ToDo: Print instance specialisations with the instance module + -- This requires the module which defined the instance to be known: + -- add_name could then extract the instance module for a dfun id + -- and pp_dfun made a special case of pp_err + use_modules = if (head sorted_modules == _NIL_) + then tail sorted_modules ++ [_NIL_] + else sorted_modules + + + pp_module_errs :: FAST_STRING -> Pretty + pp_module_errs mod + | have_errs && mod == _NIL_ + -- A _NIL_ module string corresponds to internal Ids + -- The only ones for which call instances should arise are + -- dfuns which correspond to instance specialisations + = ASSERT (null mod_tyerrs) + ppAboves [ + ppStr "*** INSTANCES", + ppAboves (map (pp_dfun sty) mod_errs) + ] + + | have_errs + = ppAboves [ + pp_module mod, + ppAboves (map (pp_err sty) mod_errs), + ppAboves (map (pp_tyerr sty) mod_tyerrs) + ] + + | otherwise + = ppNil + + where + mod_tyerrs = lookupWithDefaultFM tyerrs_fm [] mod + mod_errs = lookupWithDefaultFM errs_fm [] mod + have_errs = not (null mod_tyerrs) || not (null mod_errs) + + + pp_module_warn :: FAST_STRING -> Pretty + pp_module_warn mod + | have_warn && mod == _NIL_ + -- A _NIL_ module string corresponds to internal Ids + -- The only ones for which call instances should arise are + -- dfuns which correspond to instance specialisations + = ppAboves [ + ppStr "*** INSTANCES", + ppAboves (map (pp_dfun sty) mod_warn) + ] + + | have_warn + = ppAboves [ + pp_module mod, + ppAboves (map (pp_err sty) mod_warn) + ] + + | otherwise + = ppNil + + where + mod_warn = lookupWithDefaultFM warn_fm [] mod + have_warn = not (null mod_warn) + + +pp_module mod + = ppCat [ppStr "*** module", ppPStr mod, ppStr "***"] + + +pp_tyerr :: PprStyle -> (FAST_STRING, TyCon, [Maybe UniType]) -> Pretty + +pp_tyerr sty (_, tycon, tys) + = ppCat [ppStr "{-# SPECIALIZE data", + pprNonOp sty tycon, ppCat (map (pprParendUniType sty) spec_tys), + ppStr "#-}" ] + where + tvs = getTyConTyVarTemplates tycon + (spec_args, tv_maybes) = unzip (map choose_ty (tvs `zip` tys)) + spec_tys = map (mkForallTy (catMaybes tv_maybes)) spec_args + + choose_ty (tv, Nothing) = (mkTyVarTemplateTy tv, Just tv) + choose_ty (tv, Just ty) = (ty, Nothing) + +pp_err sty (_, id, tys) + = ppCat [ppStr "{-# SPECIALIZE", + pprNonOp sty id, ppStr "::", + pprUniType sty spec_ty, + ppStr "#-}" ] + where + spec_ty = specialiseTy (getIdUniType id) tys 100 -- HACK to drop all dicts!!! + +pp_dfun sty (_, id, tys) + | isDictFunId id + = ppCat [ppStr "{-# SPECIALIZE instance", + pprUniType sty spec_ty, + ppStr "#-}" ] + | isConstMethodId id + = pp_comment sty "OVERLOADED METHOD" id spec_ty + | otherwise + = pp_comment sty "HELP ..." id spec_ty + where + spec_ty = specialiseTy (getIdUniType id) tys 100 -- HACK to drop all dicts!!! + +pp_comment sty msg id spec_ty + = ppCat [ppStr "{-", ppStr msg, + pprNonOp sty id, ppStr "::", + pprUniType sty spec_ty, + ppStr "-}" ] +\end{code} diff --git a/ghc/compiler/specialise/Specialise.hi b/ghc/compiler/specialise/Specialise.hi new file mode 100644 index 0000000..4c3a5df --- /dev/null +++ b/ghc/compiler/specialise/Specialise.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Specialise where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import FiniteMap(FiniteMap) +import Id(Id) +import Maybes(Labda) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import UniType(UniType) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data SpecialiseData = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [[Labda UniType]]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType])) +initSpecData :: [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> SpecialiseData + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +specProgram :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> SpecialiseData -> ([CoreBinding Id Id], SpecialiseData) + {-# GHC_PRAGMA _A_ 4 _U_ 2121 _N_ _S_ "LU(ALL)LU(EALALLLL)" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs new file mode 100644 index 0000000..5962ca7 --- /dev/null +++ b/ghc/compiler/specialise/Specialise.lhs @@ -0,0 +1,2535 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} + +\begin{code} +#include "HsVersions.h" + +module Specialise ( + specProgram, + initSpecData, + + SpecialiseData(..), + FiniteMap, Bag + + ) where + +import PlainCore +import SpecTyFuns + +IMPORT_Trace +import Outputable -- ToDo: these may be removable... +import Pretty + +import AbsPrel ( liftDataCon, PrimOp(..), PrimKind -- for CCallOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType +import Bag +import CmdLineOpts ( GlobalSwitch(..) ) +import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) +import FiniteMap +import Id +import IdEnv +import IdInfo -- All of it +import InstEnv ( lookupClassInstAtSimpleType ) +import Maybes ( catMaybes, firstJust, maybeToBool, Maybe(..) ) +import TyVarEnv -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) ) +import UniqSet -- All of it +import Util +import SplitUniq + +infixr 9 `thenSM` +\end{code} + +%************************************************************************ +%* * +\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} +%* * +%************************************************************************ + +These notes describe how we implement specialisation to eliminate +overloading, and optionally to eliminate unboxed polymorphism, and +full polymorphism. + +The specialisation pass is a partial evaluator which works on Core +syntax, complete with all the explicit dictionary application, +abstraction and construction as added by the type checker. The +existing type checker remains largely as it is. + +One important thought: the {\em types} passed to an overloaded +function, and the {\em dictionaries} passed are mutually redundant. +If the same function is applied to the same type(s) then it is sure to +be applied to the same dictionary(s)---or rather to the same {\em +values}. (The arguments might look different but they will evaluate +to the same value.) + +Second important thought: we know that we can make progress by +treating dictionary arguments as static and worth specialising on. So +we can do without binding-time analysis, and instead specialise on +dictionary arguments and no others. + +The basic idea +~~~~~~~~~~~~~~ +Suppose we have + + let f = + in + +and suppose f is overloaded. + +STEP 1: CALL-INSTANCE COLLECTION + +We traverse , accumulating all applications of f to types and +dictionaries. + +(Might there be partial applications, to just some of its types and +dictionaries? In principle yes, but in practice the type checker only +builds applications of f to all its types and dictionaries, so partial +applications could only arise as a result of transformation, and even +then I think it's unlikely. In any case, we simply don't accumulate such +partial applications.) + +There's a choice of whether to collect details of all *polymorphic* functions +or simply all *overloaded* ones. How to sort this out? + Pass in a predicate on the function to say if it is "interesting"? + This is dependent on the user flags: SpecialiseOverloaded + SpecialiseUnboxed + SpecialiseAll + +STEP 2: EQUIVALENCES + +So now we have a collection of calls to f: + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... +Notice that f may take several type arguments. To avoid ambiguity, we +say that f is called at type t1/t2 and t3/t4. + +We take equivalence classes using equality of the *types* (ignoring +the dictionary args, which as mentioned previously are redundant). + +STEP 3: SPECIALISATION + +For each equivalence class, choose a representative (f t1 t2 d1 d2), +and create a local instance of f, defined thus: + + f@t1/t2 = t1 t2 d1 d2 + +(f_rhs presumably has some big lambdas and dictionary lambdas, so lots +of simplification will now result.) Then we should recursively do +everything again. + +The new id has its own unique, but its print-name (if exported) has +an explicit representation of the instance types t1/t2. + +Add this new id to f's IdInfo, to record that f has a specialised version. + +Before doing any of this, check that f's IdInfo doesn't already +tell us about an existing instance of f at the required type/s. +(This might happen if specialisation was applied more than once, or +it might arise from user SPECIALIZE pragmas.) + +Recursion +~~~~~~~~~ +Wait a minute! What if f is recursive? Then we can't just plug in +its right-hand side, can we? + +But it's ok. The type checker *always* creates non-recursive definitions +for overloaded recursive functions. For example: + + f x = f (x+x) -- Yes I know its silly + +becomes + + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl + +We still have recusion for non-overloadd functions which we +speciailise, but the recursive call should get speciailised to the +same recursive version. + + +Polymorphism 1 +~~~~~~~~~~~~~~ + +All this is crystal clear when the function is applied to *constant +types*; that is, types which have no type variables inside. But what if +it is applied to non-constant types? Suppose we find a call of f at type +t1/t2. There are two possibilities: + +(a) The free type variables of t1, t2 are in scope at the definition point +of f. In this case there's no problem, we proceed just as before. A common +example is as follows. Here's the Haskell: + + g y = let f x = x+x + in f y + f y + +After typechecking we have + + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) + +Notice that the call to f is at type type "a"; a non-constant type. +Both calls to f are at the same type, so we can specialise to give: + + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) + + +(b) The other case is when the type variables in the instance types +are *not* in scope at the definition point of f. The example we are +working with above is a good case. There are two instances of (+.sel a d), +but "a" is not in scope at the definition of +.sel. Can we do anything? +Yes, we can "common them up", a sort of limited common sub-expression deal. +This would give: + + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) + +This can save work, and can't be spotted by the type checker, because +the two instances of +.sel weren't originally at the same type. + +Further notes on (b) + +* There are quite a few variations here. For example, the defn of + +.sel could be floated ouside the \y, to attempt to gain laziness. + It certainly mustn't be floated outside the \d because the d has to + be in scope too. + +* We don't want to inline f_rhs in this case, because +that will duplicate code. Just commoning up the call is the point. + +* Nothing gets added to +.sel's IdInfo. + +* Don't bother unless the equivalence class has more than one item! + +Not clear whether this is all worth it. It is of course OK to +simply discard call-instances when passing a big lambda. + +Polymorphism 2 -- Overloading +~~~~~~~~~~~~~~ +Consider a function whose most general type is + + f :: forall a b. Ord a => [a] -> b -> b + +There is really no point in making a version of g at Int/Int and another +at Int/Bool, because it's only instancing the type variable "a" which +buys us any efficiency. Since g is completely polymorphic in b there +ain't much point in making separate versions of g for the different +b types. + +That suggests that we should identify which of g's type variables +are constrained (like "a") and which are unconstrained (like "b"). +Then when taking equivalence classes in STEP 2, we ignore the type args +corresponding to unconstrained type variable. In STEP 3 we make +polymorphic versions. Thus: + + f@t1/ = /\b -> t1 b d1 d2 + +This seems pretty simple, and a Good Thing. + +Polymorphism 3 -- Unboxed +~~~~~~~~~~~~~~ + +If we are speciailising at unboxed types we must speciailise +regardless of the overloading constraint. In the exaple above it is +worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int# +etc. + +Note that specialising an overloaded type at an uboxed type requires +an unboxed instance -- we cannot default to an unspecialised version! + + +Dictionary floating +~~~~~~~~~~~~~~~~~~~ +Consider + + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x + + +Before specialisation, leaving out type abstractions we have + + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x + +After specialising h we get a specialised version of h, like this: + + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) + +But we can't naively make an instance for g from this, because deq is not in scope +at the defn of g. Instead, we have to float out the (new) defn of deq +to widen its scope. Notice that this floating can't be done in advance -- it only +shows up when specialisation is done. + +DELICATE MATTER: the way we tell a dictionary binding is by looking to +see if it has a Dict type. If the type has been "undictify'd", so that +it looks like a tuple, then the dictionary binding won't be floated, and +an opportunity to specialise might be lost. + +User SPECIALIZE pragmas +~~~~~~~~~~~~~~~~~~~~~~~ +Specialisation pragmas can be digested by the type checker, and implemented +by adding extra definitions along with that of f, in the same way as before + + f@t1/t2 = t1 t2 d1 d2 + +Indeed the pragmas *have* to be dealt with by the type checker, because +only it knows how to build the dictionaries d1 and d2! For example + + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + +Here, the specialised version of g is an application of g's rhs to the +Ord dictionary for (Tree Int), which only the type checker can conjure +up. There might not even *be* one, if (Tree Int) is not an instance of +Ord! (All the other specialision has suitable dictionaries to hand +from actual calls.) + +Problem. The type checker doesn't have to hand a convenient , because +it is buried in a complex (as-yet-un-desugared) binding group. +Maybe we should say + + f@t1/t2 = f* t1 t2 d1 d2 + +where f* is the Id f with an IdInfo which says "inline me regardless!". +Indeed all the specialisation could be done in this way. +That in turn means that the simplifier has to be prepared to inline absolutely +any in-scope let-bound thing. + + +Again, the pragma should permit polymorphism in unconstrained variables: + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + +We *insist* that all overloaded type variables are specialised to ground types, +(and hence there can be no context inside a SPECIALIZE pragma). +We *permit* unconstrained type variables to be specialised to + - a ground type + - or left as a polymorphic type variable +but nothing in between. So + + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + +is *illegal*. (It can be handled, but it adds complication, and gains the +programmer nothing.) + + +SPECIALISING INSTANCE DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} + +The original instance decl creates a dictionary-function +definition: + + dfun.Foo.List :: forall a. Foo a -> Foo [a] + +The SPECIALIZE pragma just makes a specialised copy, just as for +ordinary function definitions: + + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + +The information about what instance of the dfun exist gets added to +the dfun's IdInfo in the same way as a user-defined function too. + +In fact, matters are a little bit more complicated than this. +When we make one of these specialised instances, we are defining +a constant dictionary, and so we want immediate access to its constant +methods and superclasses. Indeed, these constant methods and superclasses +must be in the IdInfo for the class selectors! We need help from the +typechecker to sort this out, perhaps by generating a separate IdInfo +for each. + +Automatic instance decl specialisation? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can instance decls be specialised automatically? It's tricky. +We could collect call-instance information for each dfun, but +then when we specialised their bodies we'd get new call-instances +for ordinary functions; and when we specialised their bodies, we might get +new call-instances of the dfuns, and so on. This all arises because of +the unrestricted mutual recursion between instance decls and value decls. + +Furthermore, instance decls are usually exported and used non-locally, +so we'll want to compile enough to get those specialisations done. + +Lastly, there's no such thing as a local instance decl, so we can +survive solely by spitting out *usage* information, and then reading that +back in as a pragma when next compiling the file. So for now, +we only specialise instance decls in response to pragmas. + +That means that even if an instance decl ain't otherwise exported it +needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs +something to say which module defined the instance, so the usage info +can be fed into the right reqts info file. Blegh. + + +SPECIAILISING DATA DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +With unboxed specialisation (or full specialisation) we also require +data types (and their constructors) to be speciailised on unboxed +type arguments. + +In addition to normal call instances we gather TyCon call instances at +unboxed types, determine equivalence classes for the locally defined +TyCons and build speciailised data constructor Ids for each TyCon and +substitute these in the CoCon calls. + +We need the list of local TyCons to partition the TyCon instance info. +We pass out a FiniteMap from local TyCons to Specialised Instances to +give to the interface and code genertors. + +N.B. The specialised data constructors reference the original data +constructor and type constructor which do not have the updated +specialisation info attached. Any specialisation info must be +extracted from the TyCon map returned. + + +SPITTING OUT USAGE INFORMATION +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To spit out usage information we need to traverse the code collecting +call-instance information for all imported (non-prelude?) functions +and data types. Then we equivalence-class it and spit it out. + +This is done at the top-level when all the call instances which escape +must be for imported functions and data types. + + +Partial specialisation by pragmas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about partial specialisation: + + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + +or even + + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + +Seems quite reasonable. Similar things could be done with instance decls: + + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + +Ho hum. Things are complex enough without this. I pass. + + +Requirements for the simplifer +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplifier has to be able to take advantage of the specialisation. + +* When the simplifier finds an application of a polymorphic f, it looks in +f's IdInfo in case there is a suitable instance to call instead. This converts + + f t1 t2 d1 d2 ===> f_t1_t2 + +Note that the dictionaries get eaten up too! + +* Dictionary selection operations on constant dictionaries must be + short-circuited: + + +.sel Int d ===> +Int + +The obvious way to do this is in the same way as other specialised +calls: +.sel has inside it some IdInfo which tells that if it's applied +to the type Int then it should eat a dictionary and transform to +Int. + +In short, dictionary selectors need IdInfo inside them for constant +methods. + +* Exactly the same applies if a superclass dictionary is being + extracted: + + Eq.sel Int d ===> dEqInt + +* Something similar applies to dictionary construction too. Suppose +dfun.Eq.List is the function taking a dictionary for (Eq a) to +one for (Eq [a]). Then we want + + dfun.Eq.List Int d ===> dEq.List_Int + +Where does the Eq [Int] dictionary come from? It is built in +response to a SPECIALIZE pragma on the Eq [a] instance decl. + +In short, dfun Ids need IdInfo with a specialisation for each +constant instance of their instance declaration. + + +What does the specialisation IdInfo look like? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + SpecInfo + [Maybe UniType] -- Instance types + Int -- No of dicts to eat + Id -- Specialised version + +For example, if f has this SpecInfo: + + SpecInfo [Just t1, Nothing, Just t3] 2 f' + +then + + f t1 t2 t3 d1 d2 ===> f t2 + +The "Nothings" identify type arguments in which the specialised +version is polymorphic. + +What can't be done this way? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no way, post-typechecker, to get a dictionary for (say) +Eq a from a dictionary for Eq [a]. So if we find + + ==.sel [t] d + +we can't transform to + + eqList (==.sel t d') + +where + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + +Of course, we currently have no way to automatically derive +eqList, nor to connect it to the Eq [a] instance decl, but you +can imagine that it might somehow be possible. Taking advantage +of this is permanently ruled out. + +Still, this is no great hardship, because we intend to eliminate +overloading altogether anyway! + + +Mutter mutter +~~~~~~~~~~~~~ +What about types/classes mentioned in SPECIALIZE pragmas spat out, +but not otherwise exported. Even if they are exported, what about +their original names. + +Suggestion: use qualified names in pragmas, omitting module for +prelude and "this module". + + +Mutter mutter 2 +~~~~~~~~~~~~~~~ +Consider this + + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + +Here, g is only called at one type, but the dictionary isn't in scope at the +definition point for g. Usually the type checker would build a +definition for d1 which enclosed g, but the transformation system +might have moved d1's defn inward. + + +Unboxed bindings +~~~~~~~~~~~~~~~~ + +What should we do when a value is specialised to a *strict* unboxed value? + + map_*_* f (x:xs) = let h = f x + t = map f xs + in h:t + +Could convert let to case: + + map_*_Int# f (x:xs) = case f x of h# -> + let t = map f xs + in h#:t + +This may be undesirable since it forces evaluation here, but the value +may not be used in all branches of the body. In the general case this +transformation is impossible since the mutual recursion in a letrec +cannot be expressed as a case. + +There is also a problem with top-level unboxed values, since our +implementation cannot handle unboxed values at the top level. + +Solution: Lift the binding of the unboxed value and extract it when it +is used: + + map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h# + t = map f xs + in case h of + _Lift h# -> h#:t + +Now give it to the simplifier and the _Lifting will be optimised away. + +The benfit is that we have given the specialised "unboxed" values a +very simple lifted semantics and then leave it up to the simplifier to +optimise it --- knowing that the overheads will be removed in nearly +all cases. + +In particular, the value will only be evaluted in the branches of the +program which use it, rather than being forced at the point where the +value is bound. For example: + + filtermap_*_* p f (x:xs) + = let h = f x + t = ... + in case p x of + True -> h:t + False -> t + ==> + filtermap_*_Int# p f (x:xs) + = let h = case (f x) of h# -> _Lift h# + t = ... + in case p x of + True -> case h of _Lift h# + -> h#:t + False -> t + +The binding for h can still be inlined in the one branch and the +_Lifting eliminated. + + +Question: When won't the _Lifting be eliminated? + +Answer: When they at the top-level (where it is necessary) or when +inlining would duplicate work (or possibly code depending on +options). However, the _Lifting will still be eliminated if the +strictness analyser deems the lifted binding strict. + + + +%************************************************************************ +%* * +\subsubsection[CallInstances]{@CallInstances@ data type} +%* * +%************************************************************************ + +\begin{code} +type FreeVarsSet = UniqSet Id +type FreeTyVarsSet = UniqSet TyVar + +data CallInstance + = CallInstance + Id -- This Id; *new* ie *cloned* id + [Maybe UniType] -- Specialised at these types (*new*, cloned) + -- Nothing => no specialisation on this type arg + -- is required (flag dependent). + [PlainCoreArg] -- 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} +pprCI :: CallInstance -> Pretty +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]) + Just (SpecInfo _ _ spec_id) + -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id] + ]) + +isUnboxedCI :: CallInstance -> Bool +isUnboxedCI (CallInstance _ spec_tys _ _ _) + = any isUnboxedDataType (catMaybes spec_tys) + +isExplicitCI :: CallInstance -> Bool +isExplicitCI (CallInstance _ _ _ _ (Just _)) + = True +isExplicitCI (CallInstance _ _ _ _ Nothing) + = False +\end{code} + +Comparisons are based on the {\em types}, ignoring the dictionary args: + +\begin{code} + +cmpCI :: CallInstance -> CallInstance -> TAG_ +cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) + = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } + +cmpCI_tys :: CallInstance -> CallInstance -> TAG_ +cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _) + = cmpUniTypeMaybeList tys1 tys2 + +isCIofTheseIds :: [Id] -> CallInstance -> Bool +isCIofTheseIds ids (CallInstance ci_id _ _ _ _) = any (eqId ci_id) ids + +singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails +singleCI id tys dicts + = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing)) + emptyBag [] emptyUniqSet + where + fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts]) + +explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails +explicitCI id tys specinfo + = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet + where + call_inst = CallInstance id tys dicts fv_set (Just specinfo) + dicts = panic "Specialise:explicitCI:dicts" + fv_set = singletonUniqSet id + +getCIs :: [Id] -> UsageDetails -> ([CallInstance], UsageDetails) +getCIs ids (UsageDetails cis tycon_cis dbs fvs) + = let + (cis_here, cis_not_here) = partitionBag (isCIofTheseIds ids) cis + cis_here_list = bagToList cis_here + in + -- pprTrace "getCIs:" + -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"]) + -- 4 (ppAboves (map pprCI cis_here_list))) + (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs) + +dumpCIs :: Bag CallInstance -- The call instances + -> [Id] -- Bound ids *new* + -> Bag CallInstance -- Kept call instances +dumpCIs cis bound_ids + = (if not (isEmptyBag cis_dict_bound_arg) then + (if isEmptyBag unboxed_cis_dict_bound_arg + then (\ x y -> y) -- pprTrace "dumpCIs: bound dictionary arg ... \n" + else pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n") + (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"]) + 4 (ppAboves (map pprCI (bagToList cis_dump)))) + else id) + cis_keep + where + (cis_dump, cis_keep) = partitionBag mentions_bound_ids cis + + mentions_bound_ids (CallInstance _ _ _ fv_set _) + = or [i `elementOfUniqSet` fv_set | i <- bound_ids] + + (cis_of_bound_id, cis_dict_bound_arg) = partitionBag (isCIofTheseIds bound_ids) cis_dump + (unboxed_cis_dict_bound_arg, _) = partitionBag isUnboxedCI cis_dict_bound_arg + +\end{code} + +Any call instances of a bound_id can be safely dumped, because any +recursive calls should be at the same instance as the parent instance. + + letrec f = /\a -> \x::a -> ...(f t x')... + +Here, the type, t, at which f is used in its own RHS should be +just "a"; that is, the recursive call is at the same type as +the original call. That means that when specialising f at some +type, say Int#, we shouldn't find any *new* instances of f +arising from specialising f's RHS. The only instance we'll find +is another call of (f Int#). + +ToDo: We should check this rather than just dumping them. + +However, we do report any call instances which are mysteriously dumped +because they have a dictionary argument which is bound here ... + +ToDo: Under what circumstances does this occur, if at all? + +%************************************************************************ +%* * +\subsubsection[TyConInstances]{@TyConInstances@ data type} +%* * +%************************************************************************ + +\begin{code} +data TyConInstance + = TyConInstance TyCon -- Type Constructor + [Maybe UniType] -- Applied to these specialising types + +cmpTyConI :: TyConInstance -> TyConInstance -> TAG_ +cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) + = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } + +cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_ +cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) + = cmpUniTypeMaybeList tys1 tys2 + +singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails +singleTyConI ty_con spec_tys + = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet + +isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool +isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con + +isLocalSpecTyConI :: Bool -> TyConInstance -> Bool +isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con + +getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails) +getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs) + = let + (tycon_cis_local, tycon_cis_global) + = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis + tycon_cis_local_list = bagToList tycon_cis_local + in + (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs) +\end{code} + + +%************************************************************************ +%* * +\subsubsection[UsageDetails]{@UsageDetails@ data type} +%* * +%************************************************************************ + +\begin{code} +data UsageDetails + = UsageDetails + (Bag CallInstance) -- The collection of call-instances + (Bag TyConInstance) -- Constructor call-instances + [DictBindDetails] -- Dictionary bindings in data-dependence order! + FreeVarsSet -- Free variables (excl imported ones, incl top level) (cloned) +\end{code} + +The DictBindDetails are fully processed; their call-instance information is +incorporated in the call-instances of the +UsageDetails which includes the DictBindDetails. The free vars in a usage details +will *include* the binders of the DictBind details. + +A @DictBindDetails@ contains bindings for dictionaries *only*. + +\begin{code} +data DictBindDetails + = DictBindDetails + [Id] -- Main binders, originally visible in scope of binding (cloned) + PlainCoreBinding -- Fully processed + FreeVarsSet -- Free in binding group (cloned) + FreeTyVarsSet -- Free in binding group +\end{code} + +\begin{code} +emptyUDs :: UsageDetails +unionUDs :: UsageDetails -> UsageDetails -> UsageDetails +unionUDList :: [UsageDetails] -> UsageDetails + +emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet + +unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2) + = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2) + (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) + -- The append here is really redundant, since the bindings don't + -- scope over each other. ToDo. + +unionUDList = foldr unionUDs emptyUDs + +singleFvUDs (CoVarAtom v) | not (isImportedId v) + = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) +singleFvUDs other + = emptyUDs + +singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) + +dumpDBs :: [DictBindDetails] + -> [TyVar] -- TyVars being bound (cloned) + -> [Id] -- Ids being bound (cloned) + -> FreeVarsSet -- Fvs of body + -> ([PlainCoreBinding], -- These ones have to go here + [DictBindDetails], -- These can float further + [Id], -- Incoming list + names of dicts bound here + FreeVarsSet -- Incominf fvs + fvs of dicts bound here + ) +dumpDBs [] bound_tyvars bound_ids fvs = ([], [], bound_ids, fvs) + +dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs) + bound_tyvars bound_ids fvs + | or [i `elementOfUniqSet` db_fvs | i <- bound_ids] + || + or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars] + = let -- Ha! Dump it! + (dbinds_here, dbs_outer, full_bound_ids, full_fvs) + = dumpDBs dbs bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs) + in + (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs) + + | otherwise -- This one can float out further + = let + (dbinds_here, dbs_outer, full_bound_ids, full_fvs) + = dumpDBs dbs bound_tyvars bound_ids fvs + in + (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs) + + + +dumpUDs :: UsageDetails + -> [Id] -- Ids which are just being bound; *new* + -> [TyVar] -- TyVars which are just being bound + -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids + UsageDetails) -- The above bindings removed, and + -- any call-instances which mention the ids dumped too + +dumpUDs (UsageDetails cis tycon_cis dbs fvs) bound_ids tvs + = let + (dict_binds_here, dbs_outer, full_bound_ids, full_fvs) = dumpDBs dbs tvs bound_ids fvs + cis_outer = dumpCIs cis full_bound_ids + fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids) + in + (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer) +\end{code} + +\begin{code} +addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails -- Dict binding and RHS usage + -> UsageDetails -- The usage to augment + -> UsageDetails +addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs) + (UsageDetails cis tycon_cis dbs fvs) + = UsageDetails (db_cis `unionBags` cis) + (db_tycon_cis `unionBags` tycon_cis) + (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs) + fvs + where + -- The free tyvars of the dictionary bindings should really be + -- gotten from the RHSs, but I'm pretty sure it's good enough just + -- to look at the type of the dictionary itself. + -- Doing the proper job would entail keeping track of free tyvars as + -- well as free vars, which would be a bore. + db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders)) +\end{code} + +%************************************************************************ +%* * +\subsection[cloning-binders]{The Specialising IdEnv and CloneInfo} +%* * +%************************************************************************ + +@SpecIdEnv@ maps old Ids to their new "clone". There are three cases: + +1) (NoLift CoLitAtom l) : an Id which is bound to a literal + +2) (NoLift CoLitAtom l) : an Id bound to a "new" Id + The new Id is a possibly-type-specialised clone of the original + +3) Lifted lifted_id unlifted_id : + + This indicates that the original Id has been specialised to an + unboxed value which must be lifted (see "Unboxed bindings" above) + @unlifted_id@ is the unboxed clone of the original Id + @lifted_id@ is a *lifted* version of the original Id + + When you lookup Ids which are Lifted, you have to insert a case + expression to un-lift the value (done with @bindUnlift@) + + You also have to insert a case to lift the value in the binding + (done with @liftExpr@) + + +\begin{code} +type SpecIdEnv = IdEnv CloneInfo + +data CloneInfo + = NoLift PlainCoreAtom -- refers to cloned id or literal + + | Lifted Id -- lifted, cloned id + Id -- unlifted, cloned id + +\end{code} + +%************************************************************************ +%* * +\subsection[specialise-data]{Data returned by specialiser} +%* * +%************************************************************************ + +\begin{code} +data SpecialiseData + = SpecData Bool + -- True <=> Specialisation performed + Bool + -- False <=> Specialisation completed with errors + + [TyCon] + -- Local tycons declared in this module + + [TyCon] + -- Those in-scope data types for which we want to + -- generate code for their constructors. + -- Namely: data types declared in this module + + -- any big tuples used in this module + -- The initial (and default) value is the local tycons + + (FiniteMap TyCon [[Maybe UniType]]) + -- TyCon specialisations to be generated + -- We generate specialisations for data types defined + -- in this module and any tuples used in this module + -- The initial (and default) value is the specialisations + -- requested by source-level SPECIALIZE data pragmas + -- and _SPECIALISE_ pragmas in the interface files + + (Bag (Id,[Maybe UniType])) + -- Imported specialisation errors + (Bag (Id,[Maybe UniType])) + -- Imported specialisation warnings + (Bag (TyCon,[Maybe UniType])) + -- Imported TyCon specialisation errors + +initSpecData local_tycons tycon_specs + = SpecData False True local_tycons local_tycons tycon_specs emptyBag emptyBag emptyBag +\end{code} + +ToDo[sansom]: Transformation data to process specialisation requests. + +%************************************************************************ +%* * +\subsection[specProgram]{Specialising a core program} +%* * +%************************************************************************ + +\begin{code} +specProgram :: (GlobalSwitch -> Bool) + -> SplitUniqSupply + -> [PlainCoreBinding] -- input ... + -> SpecialiseData + -> ([PlainCoreBinding], -- main result + SpecialiseData) -- result specialise data + +specProgram sw_chker uniqs binds + (SpecData False _ local_tycons _ init_specs init_errs init_warn init_tyerrs) + = case (initSM (specTyConsAndScope (specTopBinds binds)) sw_chker uniqs) of + (final_binds, tycon_specs_list, + UsageDetails import_cis import_tycis _ fvs) + -> let + used_conids = filter isDataCon (uniqSetToList fvs) + used_tycons = map getDataConTyCon used_conids + used_gen = filter isLocalGenTyCon used_tycons + gen_tycons = setToList (mkSet local_tycons `union` mkSet used_gen) + + result_specs = addListToFM_C (++) init_specs tycon_specs_list + + uniq_cis = map head (equivClasses cmpCI (bagToList import_cis)) + cis_list = [(id, tys) | CallInstance id tys _ _ _ <- uniq_cis] + (cis_unboxed, cis_other) = partition (isUnboxedSpecialisation . snd) cis_list + cis_warn = init_warn `unionBags` listToBag cis_other + cis_errs = init_errs `unionBags` listToBag cis_unboxed + + uniq_tycis = map head (equivClasses cmpTyConI (bagToList import_tycis)) + tycis_unboxed = [(con, tys) | TyConInstance con tys <- uniq_tycis] + tycis_errs = init_tyerrs `unionBags` listToBag tycis_unboxed + + no_errs = isEmptyBag cis_errs && isEmptyBag tycis_errs + && (not (sw_chker SpecialiseImports) || isEmptyBag cis_warn) + in + (final_binds, + SpecData True no_errs local_tycons gen_tycons result_specs + cis_errs cis_warn tycis_errs) + +specProgram sw_chker uniqs binds (SpecData True _ _ _ _ _ _ _) + = panic "Specialise:specProgram: specialiser called more than once" + +-- It may be possible safely to call the specialiser more than once, +-- but I am not sure there is any benefit in doing so (Patrick) + +-- ToDo: What about unfoldings performed after specialisation ??? +\end{code} + +%************************************************************************ +%* * +\subsection[specTyConsAndScope]{Specialising data constructors within tycons} +%* * +%************************************************************************ + +In the specialiser we just collect up the specialisations which will +be required. We don't create the specialised constructors in +Core. These are only introduced when we convert to StgSyn. + +ToDo: Perhaps this should be done in CoreToStg to ensure no inconsistencies! + +\begin{code} +specTyConsAndScope :: SpecM ([PlainCoreBinding], UsageDetails) + -> SpecM ([PlainCoreBinding], [(TyCon,[[Maybe UniType]])], UsageDetails) + +specTyConsAndScope scopeM + = scopeM `thenSM` \ (binds, scope_uds) -> + getSwitchCheckerSM `thenSM` \ sw_chkr -> + let + (tycons_cis, gotci_scope_uds) + = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds + + tycon_specs_list = collectTyConSpecs tycons_cis + in + (if sw_chkr SpecialiseTrace && not (null tycon_specs_list) then + pprTrace "Specialising TyCons:\n" + (ppAboves [ if not (null specs) then + ppHang (ppCat [(ppr PprDebug tycon), ppStr "at types"]) + 4 (ppAboves (map pp_specs specs)) + else ppNil + | (tycon, specs) <- tycon_specs_list]) + else id) ( + returnSM (binds, tycon_specs_list, gotci_scope_uds) + ) + where + collectTyConSpecs [] + = [] + collectTyConSpecs tycons_cis@(TyConInstance tycon _ : _) + = (tycon, tycon_specs) : collectTyConSpecs other_tycons_cis + where + (tycon_cis, other_tycons_cis) = partition (isTyConIofThisTyCon tycon) tycons_cis + uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis) + tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis] + + pp_specs specs = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- specs] + + +{- UNUSED: create specialised constructors in Core + +NB: this code may have some bitrot (Andy & Will 95/06) + +specTyConsAndScope spec_tycons scopeM + = fixSM (\ ~(_, _, _, rec_spec_infos) -> + bindConIds cons_tospec rec_spec_infos ( + scopeM `thenSM` \ (binds, scope_uds) -> + let + (tycons_cis, gotci_scope_uds) + = getLocalSpecTyConIs (sw_chkr CompilingPrelude) scope_uds + in + mapAndUnzipSM (inst_tycon tycons_cis) spec_tycons + `thenSM` \ (tycon_specs_list, spec_infoss) -> + returnSM (binds, tycon_specs_list, gotci_scope_uds, concat spec_infoss) + ) + + ) `thenSM` \ (binds, tycon_specs_list, final_uds, spec_infos) -> + returnSM (binds, tycon_specs_list, final_uds) + + where + conss_tospec = map getTyConDataCons spec_tycons + cons_tospec = concat conss_tospec + + inst_tycon tycons_cis tycon + = mapSM mk_con_specs (getTyConDataCons tycon) `thenSM` \ spec_infos -> + getSwitchCheckerSM `thenSM` \ sw_chkr -> + (if sw_chkr SpecialiseTrace && not (null tycon_cis) then + pprTrace "Specialising:" + (ppHang (ppCat [ppr PprDebug tycon, ppStr "at types"]) + 4 (ppAboves (map pp_inst uniq_cis))) + else id) ( + returnSM ((tycon, tycon_specs), spec_infos) + ) + where + tycon_cis = filter (isTyConIofThisTyCon tycon) tycons_cis + uniq_cis = map head (equivClasses cmpTyConI_tys tycon_cis) + + tycon_specs = [spec_tys | TyConInstance _ spec_tys <- uniq_cis] + + mk_con_specs con_id + = mapSM (mk_con_spec con_id) uniq_cis + mk_con_spec con_id (TyConInstance _ spec_tys) + = newSpecIds [con_id] spec_tys 0 copy_arity_info_and `thenSM` \ [spec_id] -> + returnSM (SpecInfo spec_tys 0 spec_id) + + copy_arity_info old new = addIdArity new (getDataConArity old) + + pp_inst (TyConInstance _ spec_tys) + = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- spec_tys] +-} +\end{code} + +%************************************************************************ +%* * +\subsection[specTopBinds]{Specialising top-level bindings} +%* * +%************************************************************************ + +\begin{code} +specTopBinds :: [PlainCoreBinding] + -> SpecM ([PlainCoreBinding], UsageDetails) + +specTopBinds binds + = spec_top_binds binds `thenSM` \ (binds, UsageDetails cis tycis dbind_details fvs) -> + let + -- Add bindings for floated dbinds and collect fvs + -- In actual fact many of these bindings are dead code since dict + -- arguments are dropped when a specialised call is created + -- The simplifier should be able to cope ... + + (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)) + in + returnSM (dbinds ++ binds, UsageDetails cis tycis [] fvs_outer) + + where + spec_top_binds (first_bind:rest_binds) + = specBindAndScope True {- top level -} first_bind ( + spec_top_binds rest_binds `thenSM` \ (rest_binds, rest_uds) -> + returnSM (ItsABinds rest_binds, rest_uds) + ) `thenSM` \ (first_binds, ItsABinds rest_binds, all_uds) -> + returnSM (first_binds ++ rest_binds, all_uds) + + spec_top_binds [] + = returnSM ([], emptyUDs) +\end{code} + +%************************************************************************ +%* * +\subsection[specExpr]{Specialising expressions} +%* * +%************************************************************************ + +\begin{code} +specExpr :: PlainCoreExpr + -> [PlainCoreArg] -- The arguments: + -- TypeArgs are speced + -- ValArgs are unprocessed + -> SpecM (PlainCoreExpr, -- Result expression with specialised versions installed + UsageDetails) -- Details of usage of enclosing binders in the result + -- expression. + +specExpr (CoVar v) args + = lookupId v `thenSM` \ vlookup -> + case vlookup of + Lifted vl vu + -> -- Binding has been lifted, need to extract un-lifted value + -- NB: a function binding will never be lifted => args always null + -- i.e. no call instance required or call to be constructed + ASSERT (null args) + returnSM (bindUnlift vl vu (CoVar vu), singleFvUDs (CoVarAtom vl)) + + NoLift vatom@(CoVarAtom new_v) + -> mapSM specArg args `thenSM` \ arg_info -> + mkCallInstance v new_v arg_info `thenSM` \ uds -> + mkCall new_v arg_info `thenSM` \ call -> + returnSM (call, uds) + +specExpr expr@(CoLit _) null_args + = ASSERT (null null_args) + returnSM (expr, emptyUDs) + +specExpr (CoCon con tys args) null_args + = ASSERT (null null_args) + mapSM specTy tys `thenSM` \ tys -> + mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> + mkTyConInstance con tys `thenSM` \ con_uds -> + returnSM (applyBindUnlifts unlifts (CoCon con tys args), + unionUDList args_uds_s `unionUDs` con_uds) + +{- UNUSED: create specialised constructors in CoCon +specExpr (CoCon con tys args) null_args + = ASSERT (null null_args) + mapSM specTy tys `thenSM` \ tys -> + mapAndUnzipSM specAtom args `thenSM` \ (args, args_uds_s) -> + mkTyConInstance con tys `thenSM` \ con_con -> + lookupId con `thenSM` \ con -> + mkConstrCall con tys `thenSM` \ ~(spec_con, spec_tys) -> + returnSM (CoCon spec_con spec_tys args, + unionUDList args_uds_s `unionUDs` con_uds) +-} + +specExpr (CoPrim op@(CCallOp str is_asm may_gc arg_tys res_ty) tys args) null_args + = ASSERT (null null_args) + ASSERT (null tys) + mapSM specTy arg_tys `thenSM` \ arg_tys -> + specTy res_ty `thenSM` \ res_ty -> + mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> + returnSM (applyBindUnlifts unlifts (CoPrim (CCallOp str is_asm may_gc arg_tys res_ty) tys args), + unionUDList args_uds_s) + +specExpr (CoPrim prim tys args) null_args + = ASSERT (null null_args) + mapSM specTy tys `thenSM` \ tys -> + mapAndUnzip3SM specAtom args `thenSM` \ (args, args_uds_s, unlifts) -> + -- specPrimOp prim tys `thenSM` \ (prim, tys, prim_uds) -> + returnSM (applyBindUnlifts unlifts (CoPrim prim tys args), + unionUDList args_uds_s {-`unionUDs` prim_uds-} ) + +{- ToDo: specPrimOp + +specPrimOp :: PrimOp + -> [UniType] + -> SpecM (PrimOp, + [UniType], + UsageDetails) + +-- Checks that PrimOp can handle (possibly unboxed) tys passed +-- and/or chooses PrimOp specialised to any unboxed tys +-- Errors are dealt with by returning a PrimOp call instance +-- which will result in a cis_errs message + +-- ToDo: Deal with checkSpecTyApp for CoPrim in CoreLint +-} + + +specExpr (CoApp fun arg) args + = -- Arg is passed on unprocessed + specExpr fun (ValArg 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 (CoLam bound_ids body) args + = specLam bound_ids body args + +specExpr (CoTyLam tyvar body) (TypeArg ty : args) + = -- Type lambda with argument; argument already spec'd + bindTyVar tyvar ty ( + specExpr body args + ) + +specExpr (CoTyLam tyvar body) [] + = -- No arguments + cloneTyVarSM tyvar `thenSM` \ new_tyvar -> + bindTyVar tyvar (mkTyVarTy new_tyvar) ( + specExpr body [] `thenSM` \ (body, body_uds) -> + let + (binds_here, final_uds) = dumpUDs body_uds [] [new_tyvar] + in + returnSM (CoTyLam new_tyvar (mkCoLetsNoUnboxed binds_here body), final_uds) + ) + +specExpr (CoCase scrutinee alts) args + = specExpr scrutinee [] `thenSM` \ (scrutinee, scrut_uds) -> + specAlts alts scrutinee_type args `thenSM` \ (alts, alts_uds) -> + returnSM (CoCase scrutinee alts, scrut_uds `unionUDs` alts_uds) + where + scrutinee_type = typeOfCoreExpr scrutinee + + +specExpr (CoLet bind body) args + = specBindAndScope False {- not top level -} bind ( + specExpr body args `thenSM` \ (body, body_uds) -> + returnSM (ItsAnExpr body, body_uds) + ) `thenSM` \ (binds, ItsAnExpr body, all_uds) -> + returnSM (mkCoLetsNoUnboxed binds body, all_uds) + +specExpr (CoSCC cc expr) args + = specExpr expr [] `thenSM` \ (expr, expr_uds) -> + mapAndUnzip3SM specArg args `thenSM` \ (args, args_uds_s, unlifts) -> + let + scc_expr + = if squashableDictishCcExpr cc expr -- can toss the _scc_ + then expr + else CoSCC cc expr + in + returnSM (applyBindUnlifts unlifts (applyToArgs scc_expr args), + unionUDList args_uds_s `unionUDs` expr_uds) + +-- ToDo:DPH: add stuff here! +\end{code} + +%************************************************************************ +%* * +\subsubsection{Specialising a lambda} +%* * +%************************************************************************ + +\begin{code} +specLam :: [Id] -> PlainCoreExpr -> [PlainCoreArg] + -> SpecM (PlainCoreExpr, UsageDetails) + +specLam [] body args + = -- All lambdas saturated + specExpr body args + +specLam (binder:binders) body (ValArg arg : args) + = -- Lambda with an unprocessed argument + lookup_arg arg `thenSM` \ arg -> + bindId binder arg ( + specLam binders body args + ) + where + lookup_arg (CoLitAtom l) = returnSM (NoLift (CoLitAtom l)) + lookup_arg (CoVarAtom v) = lookupId v + +specLam bound_ids body [] + = -- Lambda with no arguments + specLambdaOrCaseBody bound_ids body [] `thenSM` \ (bound_ids, body, uds) -> + returnSM (CoLam bound_ids body, uds) +\end{code} + +\begin{code} +specLambdaOrCaseBody :: [Id] -- The binders + -> PlainCoreExpr -- The body + -> [PlainCoreArg] -- Its args + -> SpecM ([Id], -- New binders + PlainCoreExpr, -- New body + UsageDetails) + +specLambdaOrCaseBody bound_ids body args + = cloneLambdaOrCaseBinders bound_ids `thenSM` \ (new_ids, clone_infos) -> + bindIds bound_ids clone_infos ( + + specExpr body args `thenSM` \ (body, body_uds) -> + + let + -- Dump any dictionary bindings (and call instances) + -- from the scope which mention things bound here + (binds_here, final_uds) = dumpUDs body_uds new_ids [] + in + returnSM (new_ids, mkCoLetsNoUnboxed binds_here body, final_uds) + ) + +-- ToDo: Opportunity here to common-up dictionaries with same type, +-- thus avoiding recomputation. +\end{code} + +A variable bound in a lambda or case is normally monomorphic so no +specialised versions will be required. This is just as well since we +do not know what code to specialise! + +Unfortunately this is not always the case. For example a class Foo +with polymorphic methods gives rise to a dictionary with polymorphic +components as follows: + +\begin{verbatim} +class Foo a where + op1 :: a -> b -> a + op2 :: a -> c -> a + +instance Foo Int where + op1 = op1Int + op2 = op2Int + +... op1 1 3# ... + +==> + +d.Foo.Int :: ( \/b . Int -> b -> Int, \/c . Int -> c -> Int ) +d.Foo.Int = (op1_Int, op2_Int) + +op1 = /\ a b -> \ dFoo -> case dFoo of (meth1, _) -> meth1 b + +... op1 {Int Int#} d.Foo.Int 1 3# ... +\end{verbatim} + +N.B. The type of the dictionary is not Hindley Milner! + +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: + +op1_Int_Int# = case d.Foo.Int of (meth1, _) -> meth1 {Int#} + +Though this is still invalid, after further simplification we get: + +op1_Int_Int# = opInt1 {Int#} + +Another round of specialisation will result in the specialised +version of op1Int being called directly. + +For now we PANIC if a polymorphic lambda/case bound variable is found +in a call instance with an unboxed type. Other call instances, arising +from overloaded type arguments, are discarded since the unspecialised +version extracted from the method can be called as normal. + +ToDo: Implement and test second round of specialisation. + + +%************************************************************************ +%* * +\subsubsection{Specialising case alternatives} +%* * +%************************************************************************ + + +\begin{code} +specAlts (CoAlgAlts alts deflt) scrutinee_ty args + = mapSM specTy ty_args `thenSM` \ ty_args -> + mapAndUnzipSM (specAlgAlt ty_args) alts `thenSM` \ (alts, alts_uds_s) -> + specDeflt deflt args `thenSM` \ (deflt, deflt_uds) -> + returnSM (CoAlgAlts alts deflt, + unionUDList alts_uds_s `unionUDs` deflt_uds) + + where + -- We use ty_args of scrutinee type to identify specialisation of alternatives + (_, ty_args, _) = getUniDataTyCon scrutinee_ty + + specAlgAlt ty_args (con,binders,rhs) + = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> + mkTyConInstance con ty_args `thenSM` \ con_uds -> + returnSM ((con,binders,rhs), rhs_uds `unionUDs` con_uds) + +{- UNUSED: creating specialised constructors in case alts + specAlgAlt ty_args (con,binders,rhs) + = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> + mkTyConInstance con ty_args `thenSM` \ con_uds -> + lookupId con `thenSM` \ con -> + mkConstrCall con ty_args `thenSM` \ ~(spec_con, _) -> + returnSM ((spec_con,binders,rhs), rhs_uds `unionUDs` con_uds) +-} + +specAlts (CoPrimAlts alts deflt) scrutinee_ty args + = mapAndUnzipSM specPrimAlt alts `thenSM` \ (alts, alts_uds_s) -> + specDeflt deflt args `thenSM` \ (deflt, deflt_uds) -> + returnSM (CoPrimAlts alts deflt, + unionUDList alts_uds_s `unionUDs` deflt_uds) + where + specPrimAlt (lit,rhs) = specExpr rhs args `thenSM` \ (rhs, uds) -> + returnSM ((lit,rhs), uds) + + +specDeflt CoNoDefault args = returnSM (CoNoDefault, emptyUDs) +specDeflt (CoBindDefault binder rhs) args + = specLambdaOrCaseBody [binder] rhs args `thenSM` \ ([binder], rhs, uds) -> + returnSM (CoBindDefault binder rhs, uds) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Specialising an atom} +%* * +%************************************************************************ + +\begin{code} +specAtom :: PlainCoreAtom -> SpecM (PlainCoreAtom, UsageDetails, + PlainCoreExpr -> PlainCoreExpr) + +specAtom (CoLitAtom lit) + = returnSM (CoLitAtom lit, emptyUDs, id) + +specAtom (CoVarAtom v) + = lookupId v `thenSM` \ vlookup -> + case vlookup of + Lifted vl vu + -> returnSM (CoVarAtom vu, singleFvUDs (CoVarAtom vl), bindUnlift vl vu) + + NoLift vatom + -> returnSM (vatom, singleFvUDs vatom, id) + + +specArg :: PlainCoreArg -> SpecM (PlainCoreArg, UsageDetails, + PlainCoreExpr -> PlainCoreExpr) + +specArg (ValArg arg) -- unprocessed; spec the atom + = specAtom arg `thenSM` \ (arg, uds, unlift) -> + returnSM (ValArg arg, uds, unlift) + +specArg (TypeArg ty) -- already speced; no action + = returnSM (TypeArg ty, emptyUDs, id) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Specialising bindings} +%* * +%************************************************************************ + +A classic case of when having a polymorphic recursive function would help! + +\begin{code} +data BindsOrExpr = ItsABinds [PlainCoreBinding] + | ItsAnExpr PlainCoreExpr +\end{code} + +\begin{code} +specBindAndScope + :: Bool -- True <=> a top level group + -> PlainCoreBinding -- As yet unprocessed + -> SpecM (BindsOrExpr, UsageDetails) -- Something to do the scope of the bindings + -> SpecM ([PlainCoreBinding], -- Processed + BindsOrExpr, -- Combined result + UsageDetails) -- Usage details of the whole lot + +specBindAndScope is_top_level_group bind scopeM + = cloneLetrecBinders binders `thenSM` \ (new_binders, clone_infos) -> + + -- Two cases now: either this is a bunch of dictionaries, in + -- which case we float them; or its a bunch of other values, + -- in which case we see if they correspond to any + -- call-instances we have in hand. + + if all (\id -> isDictTy (getIdUniType id) || isConstMethodId id) binders then + -- Ha! A group of dictionary bindings, or constant methods. + -- The reason for the latter is interesting. Consider + -- + -- dfun.Eq.Foo = /\a \ d -> ... + -- + -- constmeth1 = ... + -- constmeth2 = ... + -- dict = (constmeth1,constmeth2) + -- + -- ...(dfun.Eq.Foo dict)... + -- + -- Now, the defn of dict can't float above the constant-method + -- decls, so the call-instance for dfun.Eq.Foo will be dropped. + -- + -- Solution: float the constant methods in the same way as dictionaries + -- + -- The other interesting bit is the test for dictionary-hood. + -- Constant dictionaries, like dict above, are sometimes built + -- as zero-arity dfuns, so isDictId alone won't work. + + bindIds binders clone_infos ( + + -- Process the dictionary bindings themselves + specBind new_binders bind `thenSM` \ (bind, rhs_uds) -> + + -- Process their scope + scopeM `thenSM` \ (thing, scope_uds) -> + let + -- Add the bindings to the current stuff + final_uds = addDictBinds new_binders bind rhs_uds scope_uds + in + returnSM ([], thing, final_uds) + ) + else + -- Ho! A group of ordinary (non-dict) bindings + fixSM (\ ~(_, _, _, rec_spec_infos) -> + + bindSpecIds binders clone_infos rec_spec_infos ( + -- It's ok to have new binders in scope in + -- non-recursive decls too, cos name shadowing is gone by now + + -- Do the scope of the bindings + scopeM `thenSM` \ (thing, scope_uds) -> + let + (call_insts_these_binders, gotci_scope_uds) = getCIs new_binders scope_uds + in + + -- Do the bindings themselves + specBind new_binders bind `thenSM` \ (spec_bind, spec_uds) -> + + -- Create any necessary instances + instBind new_binders bind call_insts_these_binders + `thenSM` \ (inst_binds, inst_uds, spec_infos) -> + + let + -- Dump any dictionary bindings from the scope + -- which mention things bound here + (dict_binds, final_scope_uds) = dumpUDs gotci_scope_uds new_binders [] + -- The spec_ids can't appear anywhere in uds, because they only + -- appear in SpecInfos. + + -- Build final binding group + -- see note below about dependecies + final_binds = [spec_bind, + CoRec (pairsFromCoreBinds (inst_binds ++ dict_binds)) + ] + + in + -- Combine the results together + returnSM (final_binds, + thing, + spec_uds `unionUDs` final_scope_uds `unionUDs` inst_uds, + -- inst_uds comes last, because there may be dict bindings + -- floating outward in final_scope_uds which are mentioned + -- in the call-instances, and hence in spec_uds. + -- This ordering makes sure that the precedence order + -- among the dict bindings finally floated out is maintained. + spec_infos) + ) + ) `thenSM` \ (binds, thing, final_uds, spec_infos) -> + returnSM (binds, thing, final_uds) + where + binders = bindersOf bind +\end{code} + +We place the spec_binds and dict_binds in a CoRec as there may be some +nasty dependencies. These don't actually require a CoRec, but its the +simplest solution. (The alternative would require some tricky dependency +analysis.) We leave it to the real dependency analyser to sort it all +out during a subsequent simplification pass. + +Where do these dependencies arise? Consider this case: + + data Foo a = ... + + {- instance Eq a => Eq (Foo a) where ... -} + dfun.Eq.(Foo *) d.eq.a = + + d2 = dfun.Eq.(Foo *) Char# d.Eq.Char# + d1 = dfun.Eq.(Foo *) (Foo Char#) d2 + +Now, when specialising we must write the Char# instance of dfun.Eq.(Foo *) before +that for the (Foo Char#) instance: + + dfun.Eq.(Foo *) d.eq.a = + + dfun.Eq.(Foo *)@Char# = [d.Eq.Char#/d.eq.a] + d2 = dfun.Eq.(Foo *)@Char# + + dfun.Eq.(Foo *)@(Foo Char#) = [d2/d.eq.a] + d1 = dfun.Eq.(Foo *)@(Foo Char#) + +The definition of dfun.Eq.(Foo *)@(Foo Char#) uses d2!!! So it must +come after the definition of dfun.Eq.(Foo *)@Char#. +AAARGH! + + + +\begin{code} +specBind :: [Id] -> PlainCoreBinding -> SpecM (PlainCoreBinding, UsageDetails) + -- The UsageDetails returned has already had stuff to do with this group + -- of binders deleted; that's why new_binders is passed in. +specBind new_binders (CoNonRec binder rhs) + = specOneBinding new_binders (binder,rhs) `thenSM` \ ((binder,rhs), rhs_uds) -> + returnSM (CoNonRec binder rhs, rhs_uds) + +specBind new_binders (CoRec pairs) + = mapAndUnzipSM (specOneBinding new_binders) pairs `thenSM` \ (pairs, rhs_uds_s) -> + returnSM (CoRec pairs, unionUDList rhs_uds_s) + + +specOneBinding :: [Id] -> (Id,PlainCoreExpr) -> SpecM ((Id,PlainCoreExpr), UsageDetails) + +specOneBinding new_binders (binder, rhs) + = lookupId binder `thenSM` \ blookup -> + specExpr rhs [] `thenSM` \ (rhs, rhs_uds) -> + let + specid_maybe_maybe = isSpecPragmaId_maybe binder + is_specid = maybeToBool specid_maybe_maybe + Just specinfo_maybe = specid_maybe_maybe + specid_with_info = maybeToBool specinfo_maybe + Just spec_info = specinfo_maybe + + pragma_uds + = if is_specid && specid_with_info then + -- Have a SpecInfo stored in a SpecPragmaId binder + -- This contains the SpecInfo for a specialisation pragma + -- with an explicit SpecId specified + -- We remove any cis for orig_id (there should only be one) + -- and add the explicit ci to the usage details + let + (SpecInfo spec_tys _ spec_id) = spec_info + Just (orig_id, _) = isSpecId_maybe spec_id + in + ASSERT(toplevelishId orig_id) -- must not be cloned! + explicitCI orig_id spec_tys spec_info + else + emptyUDs + + (binds_here, final_uds) = dumpUDs rhs_uds new_binders [] + in + case blookup of + Lifted lift_binder unlift_binder + -> -- We may need to record an unboxed instance of + -- the _Lift data type in the usage details + mkTyConInstance liftDataCon [getIdUniType unlift_binder] + `thenSM` \ lift_uds -> + returnSM ((lift_binder, + mkCoLetsNoUnboxed binds_here (liftExpr unlift_binder rhs)), + final_uds `unionUDs` pragma_uds `unionUDs` lift_uds) + + NoLift (CoVarAtom binder) + -> returnSM ((binder, mkCoLetsNoUnboxed binds_here rhs), + final_uds `unionUDs` pragma_uds) +\end{code} + + +%************************************************************************ +%* * +\subsection{@instBind@} +%* * +%************************************************************************ + +\begin{code} +instBind main_ids@(first_binder:other_binders) bind call_insts_for_main_ids + | all same_overloading other_binders + = let + -- Collect up identical call instances + equiv_classes = equivClasses cmpCI_tys call_insts_for_main_ids + in + -- For each equivalence class, build an instance + mapAndUnzip3SM do_this_class equiv_classes `thenSM` \ (inst_binds, inst_uds_s, spec_infos) -> + + -- Add in the remaining UDs + returnSM (catMaybes inst_binds, + unionUDList inst_uds_s, + spec_infos + ) + + | otherwise -- Incompatible overloadings; see below by same_overloading + = (if null (filter isUnboxedCI call_insts_for_main_ids) + then (\ x y -> y) -- pprTrace "dumpCIs: not same overloading ... \n" + else pprTrace "dumpCIs: not same overloading ... WITH UNBOXED TYPES!\n") + (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"]) + 4 (ppAboves (map pprCI call_insts_for_main_ids))) + (returnSM ([], emptyUDs, [])) + + where + (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading first_binder + tyvar_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls + + no_of_tyvars = length tyvar_tmpls + no_of_dicts = length class_tyvar_pairs + + do_this_class equiv_cis + | not (null explicit_cis) + = if (length main_ids > 1 || length explicit_cis > 1) then + -- ToDo: If this situation arose we would need to go through + -- checking cis for each main_id and only creating an + -- instantiation if we had no explicit_cis for that main_id + pprPanic "Specialise:instBind:explicit call instances\n" + (ppAboves [ppCat [ppStr "{", ppr PprDebug main_ids, ppStr "}"], + ppAboves (map pprCI equiv_cis)]) + else + getSwitchCheckerSM `thenSM` \ sw_chkr -> + (if sw_chkr SpecialiseTrace then + let + SpecInfo spec_tys _ spec_id = explicit_spec_info + in + pprTrace "Specialising:" + (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"]) + 4 (ppAboves [ + ppCat (ppStr "at types:" : [pprMaybeTy PprDebug ty | ty <- spec_tys]), + ppCat [ppStr "spec ids:", ppr PprDebug [spec_id], ppStr "(explicit)"]])) + else id) ( + + returnSM (Nothing, emptyUDs, [explicit_spec_info]) + ) + | otherwise + = mkOneInst (head equiv_cis) no_of_dicts main_ids bind + where + explicit_cis = filter isExplicitCI equiv_cis + [CallInstance _ _ _ _ (Just explicit_spec_info)] = explicit_cis + + + -- same_overloading tests whether the types of all the binders + -- are "compatible"; ie have the same type and dictionary abstractions + -- Almost always this is the case, because a recursive group is abstracted + -- all together. But, it can happen that it ain't the case, because of + -- code generated from instance decls: + -- + -- rec + -- dfun.Foo.Int :: (forall a. a -> Int, Int) + -- dfun.Foo.Int = (const.op1.Int, const.op2.Int) + -- + -- const.op1.Int :: forall a. a -> Int + -- const.op1.Int a = defm.Foo.op1 Int a dfun.Foo.Int + -- + -- const.op2.Int :: Int + -- const.op2.Int = 3 + -- + -- Note that the first two defns have different polymorphism, but they are + -- mutually recursive! + + same_overloading :: Id -> Bool + same_overloading id + = no_of_tyvars == length this_id_tyvars -- Same no of tyvars + && + no_of_dicts == length this_id_class_tyvar_pairs -- Same no of vdicts + && + and (zipWith same_ov class_tyvar_pairs this_id_class_tyvar_pairs) -- Same overloading + where + (this_id_tyvars, this_id_class_tyvar_pairs) = getIdOverloading id + tyvar_pairs = this_id_tyvars `zip` tyvar_tmpls + + same_ov (clas1,tyvar1) (clas2,tyvar2) + = clas1 == clas2 && + tyvar1 == assoc "same_overloading" tyvar_pairs tyvar2 +\end{code} + +OK, so we have: + - a call instance eg f [t1,t2,t3] [d1,d2] + - the rhs of the function eg orig_rhs + - a constraint vector, saying which of eg [T,F,T] + the functions type args are constrained + (ie overloaded) + +We return a new definition + + f@t1//t3 = /\a -> orig_rhs t1 a t3 d1 d2 + +The SpecInfo for f will be (the "2" indicates 2 dictionaries to eat) + + SpecInfo [Just t1, Nothing, Just t3] 2 f@t1//t3 + +Based on this SpecInfo, a call instance of f + + ...(f t1 t2 t3 d1 d2)... + +should get replaced by + + ...(f@t1//t3 t2)... + +(But that is the business of @mkCall@.) + +\begin{code} +mkOneInst :: CallInstance + -> Int -- No of dicts to specialise + -> [Id] -- New binders + -> PlainCoreBinding -- Unprocessed + -> SpecM (Maybe PlainCoreBinding, -- Instantiated version of input + UsageDetails, + [SpecInfo] -- One for each id in the original binding + ) + +mkOneInst (CallInstance _ spec_tys dict_args _ _) no_of_dicts_to_specialise main_ids orig_bind + = ASSERT (no_of_dicts_to_specialise == length dict_args) + newSpecIds main_ids spec_tys no_of_dicts_to_specialise copy_inline_info + `thenSM` \ spec_ids -> + newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars -> + let + -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys + -- which correspond to unspeciailsed args + arg_tys :: [UniType] + (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys + + args :: [PlainCoreArg] + args = map TypeArg arg_tys ++ dict_args + + (one_spec_id:_) = spec_ids + + do_bind (CoNonRec binder rhs) + = do_one_rhs rhs `thenSM` \ (rhs, rhs_uds) -> + returnSM (CoNonRec one_spec_id rhs, rhs_uds) + + do_bind (CoRec pairs) + = mapAndUnzipSM do_one_rhs [rhs | (_,rhs) <- pairs] `thenSM` \ (rhss, rhss_uds_s) -> + returnSM (CoRec (spec_ids `zip` rhss), unionUDList rhss_uds_s) + + -- Apply the specialiser to (orig_rhs t1 a t3 d1 d2) + do_one_rhs orig_rhs = specExpr orig_rhs args `thenSM` \ (inst_rhs, inst_uds) -> + let + (binds_here, final_uds) = dumpUDs inst_uds main_ids [] + -- NB: main_ids!! not spec_ids!! Why? Because the free-var + -- stuff knows nowt about spec_ids; it'll just have the + -- original polymorphic main_ids as free. Belgh + in + returnSM (mkCoLetsNoUnboxed binds_here (mkCoTyLam poly_tyvars inst_rhs), + final_uds) + in + getSwitchCheckerSM `thenSM` \ sw_chkr -> + (if sw_chkr SpecialiseTrace then + pprTrace "Specialising:" + (ppHang (ppBesides [ppStr "{", ppr PprDebug main_ids, ppStr "}"]) + 4 (ppAboves [ + ppBesides [ppStr "with args: ", ppInterleave ppNil (map pp_arg args)], + ppBesides [ppStr "spec ids: ", ppr PprDebug spec_ids]])) + else id) ( + + do_bind orig_bind `thenSM` \ (inst_bind, inst_uds) -> + + returnSM (Just inst_bind, + inst_uds, + [SpecInfo spec_tys no_of_dicts_to_specialise spec_id | spec_id <- spec_ids] + ) + ) + where + -- debugging + pp_arg (ValArg a) = ppBesides [ppLparen, ppStr "ValArg ", ppr PprDebug a, ppRparen] + pp_arg (TypeArg t) = ppBesides [ppLparen, ppStr "TypeArg ", ppr PprDebug t, ppRparen] + + do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar) + do_the_wotsit tyvars (Just ty) = (tyvars, ty) + + copy_inline_info new_id old_uf_info = addIdUnfolding new_id old_uf_info +\end{code} + +%************************************************************************ +%* * +\subsection[Misc]{Miscellaneous junk} +%* * +%************************************************************************ + +@getIdOverloading@ grabs the type of an Id, and returns a +list of its polymorphic variables, and the initial segment of +its ThetaType, in which the classes constrain only type variables. +For example, if the Id's type is + + forall a,b,c. Eq a -> Ord [a] -> tau + +we'll return + + ([a,b,c], [(Eq,a)]) + +This seems curious at first. For a start, the type above looks odd, +because we usually only have dictionary args whose types are of +the form (C a) where a is a type variable. But this doesn't hold for +the functions arising from instance decls, which sometimes get +arguements with types of form (C (T a)) for some type constructor T. + +Should we specialise wrt this compound-type dictionary? This is +a heuristic judgement, as indeed is the fact that we specialise wrt +only dictionaries. We choose *not* to specialise wrt compound dictionaries +because at the moment the only place they show up is in instance decls, +where they are simply plugged into a returned dictionary. So nothing is +gained by specialising wrt them. + +\begin{code} +getIdOverloading :: Id + -> ([TyVarTemplate], [(Class,TyVarTemplate)]) +getIdOverloading id + = (tyvars, tyvar_part_of theta) + where + (tyvars, theta, _) = splitType (getIdUniType id) + + tyvar_part_of [] = [] + tyvar_part_of ((clas,ty) : theta) = case getTyVarTemplateMaybe ty of + Nothing -> [] + Just tyvar -> (clas, tyvar) : tyvar_part_of theta +\end{code} + +\begin{code} +mkCallInstance :: Id + -> Id + -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)] + -> SpecM UsageDetails + +mkCallInstance old_id new_id args + = recordCallInst old_id args `thenSM` \ record_call -> + case record_call of + Nothing -- No specialisation required + -> -- pprTrace "NoSpecReqd:" + -- (ppCat [ppr PprDebug old_id, ppStr "at", ppCat (map (ppr PprDebug) args)]) + + (returnSM call_fv_uds) + + Just (True, spec_tys, dict_args, rest_args) -- Requires specialisation: spec already exists + -> -- pprTrace "SpecExists:" + -- (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args), + -- ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], + -- ppCat [ppr PprDebug dict | dict <- dict_args], + -- ppStr ")"]]) + + (returnSM call_fv_uds) + + Just (False, spec_tys, dict_args, rest_args) -- Requires specialisation: record call-instance + -> -- pprTrace "CallInst:" + -- (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args), + -- ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], + -- ppCat [ppr PprDebug dict | dict <- dict_args], + -- ppStr ")"]]) + + (returnSM (singleCI new_id spec_tys dict_args `unionUDs` call_fv_uds)) + where + call_fv_uds = singleFvUDs (CoVarAtom new_id) `unionUDs` unionUDList [uds | (_,uds,_) <- args] +\end{code} + +\begin{code} +recordCallInst :: Id + -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)] + -> SpecM (Maybe (Bool, [Maybe UniType], [PlainCoreArg], + [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)])) + +recordCallInst id [] -- No args => no call instance + = returnSM Nothing + +recordCallInst id args + | isBottomingId id -- No specialised versions for "error" and friends are req'd. + = returnSM Nothing -- This is a special case in core lint etc. + + -- No call instances for Ids associated with a Class declaration, + -- i.e. default methods, super-dict selectors and class ops. + -- We rely on the instance declarations to provide suitable specialisations. + -- These are dealt with in mkCall. + + | isDefaultMethodId id + = returnSM Nothing + + | maybeToBool (isSuperDictSelId_maybe id) + = returnSM Nothing + + | isClassOpId id + = returnSM Nothing + + -- Finally, the default case ... + + | otherwise + = getSwitchCheckerSM `thenSM` \ sw_chkr -> + let + spec_overloading = sw_chkr SpecialiseOverloaded + spec_unboxed = sw_chkr SpecialiseUnboxed + spec_all = sw_chkr SpecialiseAll + + (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading id + constraint_vec = mkConstraintVector tyvar_tmpls class_tyvar_pairs + + arg_res = take_type_args tyvar_tmpls class_tyvar_pairs args + enough_args = maybeToBool arg_res + + (Just (inst_tys, dict_args, rest_args)) = arg_res + spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading + constraint_vec inst_tys + + spec_exists = maybeToBool (lookupSpecEnv + (getIdSpecialisation id) + inst_tys) + + -- We record the call instance if there is some meaningful + -- type which we want to specialise on ... + record_spec = any (not . isTyVarTy) (catMaybes spec_tys) + in + if (not enough_args) then + pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t" + (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ]) + else + if record_spec then + returnSM (Just (spec_exists, spec_tys, dict_args, rest_args)) + else + returnSM Nothing + + +take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args) + = case take_type_args tyvars class_tyvar_pairs args of + Nothing -> Nothing + Just (tys, dicts, others) -> Just (ty:tys, dicts, others) +take_type_args (_:tyvars) class_tyvar_pairs [] + = Nothing +take_type_args [] class_tyvar_pairs args + = 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) +\end{code} + +\begin{code} +mkCall :: Id + -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)] + -> SpecM PlainCoreExpr + +mkCall main_id args + | isDefaultMethodId main_id + && any isUnboxedDataType ty_args + -- No specialisations for default methods + -- Unboxed calls to DefaultMethodIds should not occur + -- The method should be specified in the instance declaration + = panic "Specialise:mkCall:DefaultMethodId" + + | maybeToBool (isSuperDictSelId_maybe main_id) + && any isUnboxedDataType ty_args + -- No specialisations for super-dict selectors + -- Specialise unboxed calls to SuperDictSelIds by extracting + -- the super class dictionary directly form the super class + -- NB: This should be dead code since all uses of this dictionary should + -- have been specialised. We only do this to keep keep core-lint happy. + = let + Just (_, super_class) = isSuperDictSelId_maybe main_id + super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of + Nothing -> panic "Specialise:mkCall:SuperDictId" + Just id -> id + in + returnSM (CoVar super_dict_id) + + | otherwise + = case lookupSpecEnv (getIdSpecialisation main_id) ty_args of + Nothing -> checkUnspecOK main_id ty_args ( + returnSM unspec_call + ) + + Just (spec_id, tys_left, dicts_to_toss) + -> checkSpecOK main_id ty_args spec_id tys_left ( + let + args_left = toss_dicts dicts_to_toss val_args + in + + -- The resulting spec_id may be an unboxed constant method + -- eg: pi Double# d.Floating.Double# ==> pi.Double# + -- Since it is a top level id pi.Double# will have been lifted. + -- We must add code to unlift such a spec_id + + if isUnboxedDataType (getIdUniType spec_id) then + ASSERT (null tys_left && null args_left) + if isConstMethodId spec_id then + liftId spec_id `thenSM` \ (lifted_spec_id, unlifted_spec_id) -> + returnSM (bindUnlift lifted_spec_id unlifted_spec_id + (CoVar unlifted_spec_id)) + else + -- ToDo: Are there other cases where we have an unboxed spec_id ??? + pprPanic "Specialise:mkCall: unboxed spec_id ...\n" + (ppCat [ppr PprDebug main_id, + ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args), + ppStr "==>", + ppr PprDebug spec_id]) + else + let + (vals_left, _, unlifts_left) = unzip3 args_left + applied_tys = mkCoTyApps (CoVar spec_id) tys_left + applied_vals = applyToArgs applied_tys vals_left + in + returnSM (applyBindUnlifts unlifts_left applied_vals) + ) + where + (tys_and_vals, _, unlifts) = unzip3 args + unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar main_id) tys_and_vals) + + + -- ty_args is the types at the front of the arg list + -- val_args is the rest of the arg-list + + (ty_args, val_args) = get args + where + get ((TypeArg 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 +\end{code} + +\begin{code} +checkUnspecOK :: Id -> [UniType] -> a -> a +checkUnspecOK check_id tys + = if isLocallyDefined check_id && any isUnboxedDataType tys + then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" + (ppCat [ppr PprDebug check_id, + ppInterleave ppNil (map (pprParendUniType PprDebug) tys)]) + else id + +checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a +checkSpecOK check_id tys spec_id tys_left + = if any isUnboxedDataType tys_left + then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" + (ppAboves [ppCat [ppr PprDebug check_id, + ppInterleave ppNil (map (pprParendUniType PprDebug) tys)], + ppCat [ppr PprDebug spec_id, + ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]]) + else id +\end{code} + +\begin{code} +mkTyConInstance :: Id + -> [UniType] + -> SpecM UsageDetails +mkTyConInstance con tys + = recordTyConInst con tys `thenSM` \ record_inst -> + case record_inst of + Nothing -- No TyCon instance + -> -- pprTrace "NoTyConInst:" + -- (ppCat [ppr PprDebug tycon, ppStr "at", + -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys)]) + (returnSM (singleConUDs con)) + + Just spec_tys -- Record TyCon instance + -> -- pprTrace "TyConInst:" + -- (ppCat [ppr PprDebug tycon, ppStr "at", + -- ppr PprDebug con, ppCat (map (ppr PprDebug) tys), + -- ppBesides [ppStr "(", + -- ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys], + -- ppStr ")"]]) + (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con)) + where + tycon = getDataConTyCon con +\end{code} + +\begin{code} +recordTyConInst :: Id + -> [UniType] + -> SpecM (Maybe [Maybe UniType]) + +recordTyConInst con tys + = let + spec_tys = specialiseConstrTys tys + + do_tycon_spec = maybeToBool (firstJust spec_tys) + + spec_exists = maybeToBool (lookupSpecEnv + (getIdSpecialisation con) + tys) + in + -- pprTrace "ConSpecExists?: " + -- (ppAboves [ppStr (if spec_exists then "True" else "False"), + -- ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)]) + (if (not spec_exists && do_tycon_spec) + then returnSM (Just spec_tys) + else returnSM Nothing) +\end{code} + +\begin{code} +{- UNUSED: create specilaised constructor calls in Core +mkConstrCall :: PlainCoreAtom -> [UniType] -- This constructor at these types + -> SpecM (Id, [UniType]) -- The specialised constructor and reduced types + +mkConstrCall (CoVarAtom con_id) tys + = case lookupSpecEnv (getIdSpecialisation con_id) tys of + Nothing -> checkUnspecOK con_id tys ( + returnSM (con_id, tys) + ) + Just (spec_id, tys_left, 0) + -> checkSpecOK con_id tys spec_id tys_left ( + returnSM (spec_id, tys_left) + ) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[monad-Specialise]{Monad used in specialisation} +%* * +%************************************************************************ + +Monad has: + + inherited: control flags and + recordInst functions with flags cached + + environment mapping tyvars to types + environment mapping Ids to Atoms + + threaded in and out: unique supply + +\begin{code} +type SpecM result + = (GlobalSwitch -> Bool) + -> TypeEnv + -> SpecIdEnv + -> SplitUniqSupply + -> result + +initSM m sw_chker uniqs + = m sw_chker 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 + = case splitUniqSupply us of { (s1, s2) -> + case (m sw_chkr tvenv idenv s1) of { r -> + k r sw_chkr tvenv idenv s2 }} + +returnSM r sw_chkr tvenv idenv us = r + +fixSM k sw_chkr 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 +\end{code} + +The only interesting bit is figuring out the type of the SpecId! + +\begin{code} +newSpecIds :: [Id] -- The id of which to make a specialised version + -> [Maybe UniType] -- Specialise to these types + -> Int -- No of dicts to specialise + -> (Id -> UnfoldingDetails -> Id) -- copies any arity info required + -> SpecM [Id] + +newSpecIds main_ids maybe_tys dicts_to_ignore copy_id_info sw_chkr tvenv idenv us + = spec_ids + where + uniqs = getSUniques (length main_ids) us + spec_id_ty id = specialiseTy (getIdUniType id) maybe_tys dicts_to_ignore + spec_ids = [ copy_id_info (mkSpecId uniq id maybe_tys (spec_id_ty id) noIdInfo) (getIdUnfolding id) + | (id,uniq) <- main_ids `zip` uniqs + ] + +newTyVars :: Int -> SpecM [TyVar] +newTyVars n sw_chkr tvenv idenv us + = map mkPolySysTyVar uniqs + where + uniqs = getSUniques n us +\end{code} + +@cloneLambdaOrCaseBinders@ and @cloneLetrecBinders@ take a bunch of +binders, and build ``clones'' for them. The clones differ from the +originals in three ways: + + (a) they have a fresh unique + (b) they have the current type environment applied to their type + (c) for letrec binders which have been specialised to unboxed values + the clone will have a lifted type + +As well as returning the list of cloned @Id@s they also return a list of +@CloneInfo@s which the original binders should be bound to. + +\begin{code} +cloneLambdaOrCaseBinders :: [Id] -- Old binders + -> SpecM ([Id], [CloneInfo]) -- New ones + +cloneLambdaOrCaseBinders old_ids sw_chkr tvenv idenv us + = let + uniqs = getSUniques (length old_ids) us + in + unzip (zipWith clone_it old_ids uniqs) + where + clone_it old_id uniq + = (new_id, NoLift (CoVarAtom new_id)) + where + new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id uniq) + +cloneLetrecBinders :: [Id] -- Old binders + -> SpecM ([Id], [CloneInfo]) -- New ones + +cloneLetrecBinders old_ids sw_chkr tvenv idenv us + = let + uniqs = getSUniques (2 * length old_ids) us + in + unzip (clone_them old_ids uniqs) + where + clone_them [] [] = [] + + clone_them (old_id:olds) (u1:u2:uniqs) + | toplevelishId old_id + = (old_id, + NoLift (CoVarAtom old_id)) : clone_rest + + -- Don't clone if it is a top-level thing. Why not? + -- (a) we don't want to change the uniques + -- on such things (see TopLevId in Id.lhs) + -- (b) we don't have to be paranoid about name capture + -- (c) the thing is polymorphic so no need to subst + + | otherwise + = if (isUnboxedDataType new_ty && not (isUnboxedDataType old_ty)) + then (lifted_id, + Lifted lifted_id unlifted_id) : clone_rest + else (new_id, + NoLift (CoVarAtom new_id)) : clone_rest + + where + clone_rest = clone_them olds uniqs + + new_id = applyTypeEnvToId tvenv (mkIdWithNewUniq old_id u1) + new_ty = getIdUniType new_id + old_ty = getIdUniType old_id + + (lifted_id, unlifted_id) = mkLiftedId new_id u2 + + +cloneTyVarSM :: TyVar -> SpecM TyVar + +cloneTyVarSM old_tyvar sw_chkr tvenv idenv us + = let + uniq = getSUnique us + in + cloneTyVar old_tyvar uniq -- new_tyvar + +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 + +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 + +bindSpecIds :: [Id] -- Old + -> [(CloneInfo)] -- New + -> [[SpecInfo]] -- Corresponding specialisations + -- Each sub-list corresponds to a different type, + -- and contains one spec_info for each id + -> 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 + where + old_to_clone = mk_old_to_clone olds clones spec_infos + + -- The important thing here is that we are *lazy* in spec_infos + mk_old_to_clone [] [] _ = [] + mk_old_to_clone (old:rest_olds) (clone:rest_clones) spec_infos + = (old, add_spec_info clone) : + mk_old_to_clone rest_olds rest_clones spec_infos_rest + where + add_spec_info (NoLift (CoVarAtom new)) + = NoLift (CoVarAtom (new `addIdSpecialisation` + (mkSpecEnv spec_infos_this_id))) + add_spec_info lifted + = lifted -- no specialised instances for unboxed lifted values + + spec_infos_this_id = map head spec_infos + spec_infos_rest = map tail spec_infos + +{- UNUSED: creating specialised constructors +bindConIds :: [Id] -- Old constructors + -> [[SpecInfo]] -- Corresponding specialisations to be added + -- Each sub-list corresponds to one constructor, and + -- gives all its specialisations + -> SpecM thing + -> SpecM thing + +bindConIds ids spec_infos specm sw_chkr tvenv idenv us + = specm sw_chkr tvenv (growIdEnvList idenv id_to_newspec) us + where + id_to_newspec = mk_id_to_newspec ids spec_infos + + -- The important thing here is that we are *lazy* in spec_infos + mk_id_to_newspec [] _ = [] + mk_id_to_newspec (id:rest_ids) spec_infos + = (id, CoVarAtom id_with_spec) : + mk_id_to_newspec rest_ids spec_infos_rest + where + id_with_spec = id `addIdSpecialisation` (mkSpecEnv spec_infos_this_id) + spec_infos_this_id = head spec_infos + spec_infos_rest = tail spec_infos +-} + +bindTyVar :: TyVar -> UniType -> SpecM thing -> SpecM thing + +bindTyVar tyvar ty specm sw_chkr tvenv idenv us + = specm sw_chkr (growTyVarEnvList tvenv [(tyvar,ty)]) idenv us +\end{code} + +\begin{code} +lookupId :: Id -> SpecM CloneInfo + +lookupId id sw_chkr tvenv idenv us + = case lookupIdEnv idenv id of + Nothing -> NoLift (CoVarAtom id) + Just info -> info +\end{code} + +\begin{code} +specTy :: UniType -> SpecM UniType -- Apply the current type envt to the type + +specTy ty sw_chkr tvenv idenv us + = applyTypeEnvToTy tvenv ty +\end{code} + +\begin{code} +liftId :: Id -> SpecM (Id, Id) +liftId id sw_chkr tvenv idenv us + = let + uniq = getSUnique us + in + mkLiftedId id uniq +\end{code} + +In other monads these @mapSM@ things are usually called @listM@. +I think @mapSM@ is a much better name. The `2' and `3' variants are +when you want to return two or three results, and get at them +separately. It saves you having to do an (unzip stuff) right after. + +\begin{code} +mapSM :: (a -> SpecM b) -> [a] -> SpecM [b] +mapAndUnzipSM :: (a -> SpecM (b1, b2)) -> [a] -> SpecM ([b1],[b2]) +mapAndUnzip3SM :: (a -> SpecM (b1, b2, b3)) -> [a] -> SpecM ([b1],[b2],[b3]) +mapAndUnzip4SM :: (a -> SpecM (b1, b2, b3, b4)) -> [a] -> SpecM ([b1],[b2],[b3],[b4]) + +mapSM f [] = returnSM [] +mapSM f (x:xs) = f x `thenSM` \ r -> + mapSM f xs `thenSM` \ rs -> + returnSM (r:rs) + +mapAndUnzipSM f [] = returnSM ([],[]) +mapAndUnzipSM f (x:xs) = f x `thenSM` \ (r1, r2) -> + mapAndUnzipSM f xs `thenSM` \ (rs1,rs2) -> + returnSM ((r1:rs1),(r2:rs2)) + +mapAndUnzip3SM f [] = returnSM ([],[],[]) +mapAndUnzip3SM f (x:xs) = f x `thenSM` \ (r1,r2,r3) -> + mapAndUnzip3SM f xs `thenSM` \ (rs1,rs2,rs3) -> + returnSM ((r1:rs1),(r2:rs2),(r3:rs3)) + +mapAndUnzip4SM f [] = returnSM ([],[],[],[]) +mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) -> + mapAndUnzip4SM f xs `thenSM` \ (rs1,rs2,rs3,rs4) -> + returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4)) +\end{code} diff --git a/ghc/compiler/stgSyn/CoreToStg.hi b/ghc/compiler/stgSyn/CoreToStg.hi new file mode 100644 index 0000000..2aace5e --- /dev/null +++ b/ghc/compiler/stgSyn/CoreToStg.hi @@ -0,0 +1,23 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CoreToStg where +import BasicLit(BasicLit) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import PrimOps(PrimOp) +import SplitUniq(SplitUniqSupply) +import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgExpr, StgRhs, UpdateFlag) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-} +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data StgRhs a b {-# GHC_PRAGMA StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] #-} +topCoreBindsToStg :: SplitUniqSupply -> [CoreBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(ALA)S" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs new file mode 100644 index 0000000..4b21fb3 --- /dev/null +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -0,0 +1,698 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[CoreToStg]{Converting core syntax to STG syntax} +%* * +%************************************************************************ + +Convert a @CoreSyntax@ program to a @StgSyntax@ program. + + +\begin{code} +#include "HsVersions.h" + +module CoreToStg ( + topCoreBindsToStg, + + -- and to make the interface self-sufficient... + SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding, + StgRhs, StgBinderInfo + ) where + +import PlainCore -- input +import AnnCoreSyn -- intermediate form on which all work is done +import StgSyn -- output +import SplitUniq +import Unique -- the UniqueSupply monadery used herein + +import AbsPrel ( unpackCStringId, stringTy, + integerTy, rationalTy, ratioDataCon, + PrimOp(..), -- For Int2IntegerOp etc + integerZeroId, integerPlusOneId, integerMinusOneId + IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) + +import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon ) +import Bag -- Bag operations +import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly... +import CostCentre ( noCostCentre, CostCentre ) +import Id ( mkSysLocal, getIdUniType, isBottomingId + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import IdEnv +import Maybes ( Maybe(..), catMaybes ) +import Outputable ( isExported ) +import Pretty -- debugging only! +import SpecTyFuns ( mkSpecialisedCon ) +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import Util +\end{code} + + + *************** OVERVIEW ********************* + + +The business of this pass is to convert Core to Stg. On the way: + +* We discard type lambdas and applications. In so doing we discard + "trivial" bindings such as + x = y t1 t2 + where t1, t2 are types + +* We make the representation of NoRep literals explicit, and + float their bindings to the top level + +* We do *not* pin on the correct free/live var info; that's done later. + Instead we use bOGUS_LVS and _FVS as a placeholder. + +* We convert case x of {...; x' -> ...x'...} + to + case x of {...; _ -> ...x... } + + See notes in SimplCase.lhs, near simplDefault for the reasoning here. + + +%************************************************************************ +%* * +\subsection[coreToStg-programs]{Converting a core program and core bindings} +%* * +%************************************************************************ + +Because we're going to come across ``boring'' bindings like +\tr{let x = /\ tyvars -> y in ...}, we want to keep a small +environment, so we can just replace all occurrences of \tr{x} +with \tr{y}. + +\begin{code} +type StgEnv = IdEnv PlainStgAtom +\end{code} + +No free/live variable information is pinned on in this pass; it's added +later. For this pass +we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders. + +\begin{code} +bOGUS_LVs :: PlainStgLiveVars +bOGUS_LVs = panic "bOGUS_LVs" + +bOGUS_FVs :: [Id] +bOGUS_FVs = panic "bOGUS_FVs" +\end{code} + +\begin{code} +topCoreBindsToStg :: SplitUniqSupply -- name supply + -> [PlainCoreBinding] -- input + -> [PlainStgBinding] -- output + +topCoreBindsToStg us core_binds + = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of + (_, stuff) -> stuff + where + binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding] + + binds_to_stg env [] = returnSUs [] + binds_to_stg env (b:bs) + = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) -> + binds_to_stg new_env bs `thenSUs` \ new_bs -> + returnSUs (bagToList float_binds ++ -- Literals + new_b ++ + new_bs) + + do_top_bind env bind@(CoRec pairs) + = coreBindToStg env bind + + do_top_bind env bind@(CoNonRec var rhs) + = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) -> + + case stg_binds of + [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> + -- Mega-special case; there's still a binding there + -- no fvs (of course), *no args*, "let" rhs + let + (extra_float_binds, rhs_body') = seek_liftable [] rhs_body + in + returnSUs (extra_float_binds ++ + [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')], + new_env, + float_binds) + + other -> returnSUs (stg_binds, new_env, float_binds) + + -------------------- + -- HACK: look for very simple, obviously-liftable bindings + -- that can come up to the top level; those that couldn't + -- 'cause they were big-lambda constrained in the Core world. + + seek_liftable :: [PlainStgBinding] -- accumulator... + -> PlainStgExpr -- look for top-lev liftables + -> ([PlainStgBinding], PlainStgExpr) -- result + + seek_liftable acc expr@(StgLet inner_bind body) + | is_liftable inner_bind + = seek_liftable (inner_bind : acc) body + + seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished + + -------------------- + is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body)) + = not (null args) -- it's manifestly a function... + || isLeakFreeType [] (getIdUniType binder) + || is_whnf body + -- ToDo: use a decent manifestlyWHNF function for STG? + where + is_whnf (StgConApp _ _ _) = True + is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v + is_whnf other = False + + is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)]) + = not (null args) -- it's manifestly a (recursive) function... + + is_liftable anything_else = False +\end{code} + +%************************************************************************ +%* * +\subsection[coreToStg-binds]{Converting bindings} +%* * +%************************************************************************ + +\begin{code} +coreBindToStg :: StgEnv + -> PlainCoreBinding + -> SUniqSM ([PlainStgBinding], -- Empty or singleton + StgEnv, -- New envt + Bag PlainStgBinding) -- Floats + +coreBindToStg env (CoNonRec binder rhs) + = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + + let + -- Binds to return if RHS is trivial + triv_binds = if isExported binder then + [StgNonRec binder stg_rhs] -- Retain it + else + [] -- Discard it + in + case stg_rhs of + StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> + -- Trivial RHS, so augment envt, and ditch the binding + returnSUs (triv_binds, new_env, rhs_binds) + where + new_env = addOneToIdEnv env binder atom + + StgRhsCon cc con_id [] -> + -- Trivial RHS, so augment envt, and ditch the binding + returnSUs (triv_binds, new_env, rhs_binds) + where + new_env = addOneToIdEnv env binder (StgVarAtom con_id) + + other -> -- Non-trivial RHS, so don't augment envt + returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds) + +coreBindToStg env (CoRec pairs) + = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** + -- (possibly ToDo) + let + (binders, rhss) = unzip pairs + in + mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) -> + returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-rhss]{Converting right hand sides} +%* * +%************************************************************************ + +\begin{code} +coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding) + +coreRhsToStg env core_rhs + = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) -> + + let stg_rhs = case stg_expr of + StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _) + | var1 == var2 -> rhs + -- This curious stuff is to unravel what a lambda turns into + -- We have to do it this way, rather than spot a lambda in the + -- incoming rhs + + StgConApp con args _ -> StgRhsCon noCostCentre con args + + other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc -- safe + bOGUS_FVs + Updatable -- Be pessimistic + [] + stg_expr + in + returnSUs (stg_rhs, stg_binds) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-lits]{Converting literals} +%* * +%************************************************************************ + +Literals: the NoRep kind need to be de-no-rep'd. +We always replace them with a simple variable, and float a suitable +binding out to the top level. + +If an Integer is small enough (Haskell implementations must support +Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@; +otherwise, wrap with @litString2Integer@. + +\begin{code} +tARGET_MIN_INT, tARGET_MAX_INT :: Integer +tARGET_MIN_INT = -536870912 +tARGET_MAX_INT = 536870912 + +litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding) + +litToStgAtom (NoRepStr s) + = newStgVar stringTy `thenSUs` \ var -> + let + rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc -- safe + bOGUS_FVs + Updatable -- OLD: ReEntrant (see note below) + [] -- No arguments + val + +-- We used not to update strings, so that they wouldn't clog up the heap, +-- but instead be unpacked each time. But on some programs that costs a lot +-- [eg hpg], so now we update them. + + val = StgApp (StgVarAtom unpackCStringId) + [StgLitAtom (MachStr s)] + bOGUS_LVs + in + returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs)) + +litToStgAtom (NoRepInteger i) + -- extremely convenient to look out for a few very common + -- Integer literals! + | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag) + | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag) + | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag) + + | otherwise + = newStgVar integerTy `thenSUs` \ var -> + let + rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc -- safe + bOGUS_FVs + Updatable -- Update an integer + [] -- No arguments + val + + val + | i > tARGET_MIN_INT && i < tARGET_MAX_INT + = -- Start from an Int + StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs + + | otherwise + = -- Start from a string + StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs + in + returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs)) + +litToStgAtom (NoRepRational r) + = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) -> + litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) -> + newStgVar rationalTy `thenSUs` \ var -> + let + rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) + ratioDataCon -- Constructor + [num_atom, denom_atom] + in + returnSUs (StgVarAtom var, binds1 `unionBags` + binds2 `unionBags` + unitBag (StgNonRec var rhs)) + +litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag) +\end{code} + + +%************************************************************************ +%* * +\subsection[coreToStg-atoms{Converting atoms} +%* * +%************************************************************************ + +\begin{code} +coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding) + +coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag) +coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit +\end{code} + +There's not anything interesting we can ASSERT about \tr{var} if it +isn't in the StgEnv. (WDP 94/06) +\begin{code} +stgLookup :: StgEnv -> Id -> PlainStgAtom + +stgLookup env var = case (lookupIdEnv env var) of + Nothing -> StgVarAtom var + Just atom -> atom +\end{code} + +%************************************************************************ +%* * +\subsection[coreToStg-exprs]{Converting core expressions} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg :: StgEnv + -> PlainCoreExpr + -> SUniqSM (PlainStgExpr, -- Result + Bag PlainStgBinding) -- Float these to top level +\end{code} + +\begin{code} +coreExprToStg env (CoLit lit) + = litToStgAtom lit `thenSUs` \ (atom, binds) -> + returnSUs (StgApp atom [] bOGUS_LVs, binds) + +coreExprToStg env (CoVar var) + = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) + +coreExprToStg env (CoCon con types args) + = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds) + where + spec_con = mkSpecialisedCon con types + +coreExprToStg env (CoPrim op tys args) + = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-type-stuff]{Type application and abstraction} +%* * +%************************************************************************ + +This type information dies in this Core-to-STG translation. + +\begin{code} +coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr +coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-lambdas]{Lambda abstractions} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg env expr@(CoLam binders body) + = coreExprToStg env body `thenSUs` \ (stg_body, binds) -> + newStgVar (typeOfCoreExpr expr) `thenSUs` \ var -> + returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre + stgArgOcc + bOGUS_FVs + ReEntrant -- binders is non-empty + binders + stg_body)) + (StgApp (StgVarAtom var) [] bOGUS_LVs), + binds) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-applications]{Applications} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg env expr@(CoApp _ _) + = -- Deal with the arguments + mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) -> + + -- Now deal with the function + case fun of + CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, + unionManyBags arg_binds) + + other -> -- A non-variable applied to things; better let-bind it. + newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id -> + coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) -> + let + fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) + stgArgOcc + bOGUS_FVs + SingleEntry -- Only entered once + [] + stg_fun + in + returnSUs (StgLet (StgNonRec fun_id fun_rhs) + (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs), + unionManyBags arg_binds `unionBags` + fun_binds) + where + (fun,args) = collect_args expr [] + + -- Collect arguments, discarding type applications + collect_args (CoApp fun arg) args = collect_args fun (arg:args) + collect_args (CoTyApp e t) args = collect_args e args + collect_args fun args = (fun, args) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-cases]{Case expressions} +%* * +%************************************************************************ + +At this point, we *mangle* cases involving fork# and par# in the +discriminant. The original templates for these primops (see +@PrelVals.lhs@) constructed case expressions with boolean results +solely to fool the strictness analyzer, the simplifier, and anyone +else who might want to fool with the evaluation order. Now, we +believe that once the translation to STG code is performed, our +evaluation order is safe. Therefore, we convert expressions of the +form: + + case par# e of + True -> rhs + False -> parError# + +to + + case par# e of + _ -> rhs + +\begin{code} + +coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts) + | funnyParallelOp op = + getSUnique `thenSUs` \ uniq -> + coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) -> + alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> + returnSUs ( + StgCase stg_discrim + bOGUS_LVs + bOGUS_LVs + uniq + stg_alts, + discrim_binds `unionBags` alts_binds + ) + where + funnyParallelOp SeqOp = True + funnyParallelOp ParOp = True + funnyParallelOp ForkOp = True + funnyParallelOp _ = False + + discrim_ty = typeOfCoreExpr discrim + + alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs)) + = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + let + stg_deflt = StgBindDefault binder False stg_rhs + in + returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) + +-- OK, back to real life... + +coreExprToStg env (CoCase discrim alts) + = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) -> + alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) -> + getSUnique `thenSUs` \ uniq -> + returnSUs ( + StgCase stg_discrim + bOGUS_LVs + bOGUS_LVs + uniq + stg_alts, + discrim_binds `unionBags` alts_binds + ) + where + discrim_ty = typeOfCoreExpr discrim + (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty + + alts_to_stg discrim (CoAlgAlts alts deflt) + = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) -> + mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> + returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt, + deflt_binds `unionBags` unionManyBags alts_binds) + where + boxed_alt_to_stg (con, bs, rhs) + = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), + rhs_binds) + where + spec_con = mkSpecialisedCon con discrim_ty_args + + alts_to_stg discrim (CoPrimAlts alts deflt) + = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) -> + mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> + returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt, + deflt_binds `unionBags` unionManyBags alts_binds) + where + unboxed_alt_to_stg (lit, rhs) + = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + returnSUs ((lit, stg_rhs), rhs_binds) + +#ifdef DPH + alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt) + = default_to_stg deflt `thenSUs` \ stg_deflt -> + mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts -> + returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt) + where + boxed_alt_to_stg (con, rhs) + = coreExprToStg env rhs `thenSUs` \ stg_rhs -> + returnSUs (con, stg_rhs) + + alts_to_stg (CoParPrimAlts tycon ctxt alts deflt) + = default_to_stg deflt `thenSUs` \ stg_deflt -> + mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts -> + returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt) + where + unboxed_alt_to_stg (lit, rhs) + = coreExprToStg env rhs `thenSUs` \ stg_rhs -> + returnSUs (lit, stg_rhs) +#endif {- Data Parallel Haskell -} + + default_to_stg discrim CoNoDefault + = returnSUs (StgNoDefault, emptyBag) + + default_to_stg discrim (CoBindDefault binder rhs) + = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> + returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, + rhs_binds) + where + + + -- We convert case x of {...; x' -> ...x'...} + -- to + -- case x of {...; _ -> ...x... } + -- + -- See notes in SimplCase.lhs, near simplDefault for the reasoning. + -- It's quite easily done: simply extend the environment to bind the + -- default binder to the scrutinee. + -- + new_env = case discrim of + CoVar v -> addOneToIdEnv env binder (StgVarAtom v) + other -> env +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-let(rec)]{Let and letrec expressions} +%* * +%************************************************************************ + +\begin{code} +coreExprToStg env (CoLet bind body) + = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) -> + coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) -> + returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) +\end{code} + + +%************************************************************************ +%* * +\subsubsection[coreToStg-scc]{SCC expressions} +%* * +%************************************************************************ + +Covert core @scc@ expression directly to STG @scc@ expression. +\begin{code} +coreExprToStg env (CoSCC cc expr) + = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) -> + returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds) +\end{code} + +%************************************************************************ +%* * +\subsubsection[coreToStg-dataParallel]{Data Parallel expressions} +%* * +%************************************************************************ +\begin{code} +#ifdef DPH +coreExprToStg env (_, AnnCoParCon con ctxt types args) + = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (mkStgLets (catMaybes stg_binds) + (StgParConApp con ctxt stg_atoms bOGUS_LVs)) + +coreExprToStg env (_,AnnCoParComm ctxt expr comm) + = coreExprToStg env expr `thenSUs` \ stg_expr -> + annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) -> + returnSUs (mkStgLets (catMaybes stg_binds) + (StgParComm ctxt stg_expr stg_comm)) + )) + where + annComm_to_stg (AnnCoParSend args) + = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgParSend stg_atoms,stg_binds) + + annComm_to_stg (AnnCoParFetch args) + = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> + returnSUs (StgParFetch stg_atoms,stg_binds) + + annComm_to_stg (AnnCoToPodized) + = returnSUs (StgToPodized,[]) + annComm_to_stg (AnnCoFromPodized) + = returnSUs (StgFromPodized,[]) +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +coreExprToStg env other = panic "coreExprToStg: it really failed here" +\end{code} + +%************************************************************************ +%* * +\subsection[coreToStg-misc]{Miscellaneous helping functions} +%* * +%************************************************************************ + +Utilities. + +Invent a fresh @Id@: +\begin{code} +newStgVar :: UniType -> SUniqSM Id +newStgVar ty + = getSUnique `thenSUs` \ uniq -> + returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) +\end{code} + +\begin{code} +mkStgLets :: [PlainStgBinding] + -> PlainStgExpr -- body of let + -> PlainStgExpr + +mkStgLets binds body = foldr StgLet body binds +\end{code} diff --git a/ghc/compiler/stgSyn/Jmakefile b/ghc/compiler/stgSyn/Jmakefile new file mode 100644 index 0000000..32b8199 --- /dev/null +++ b/ghc/compiler/stgSyn/Jmakefile @@ -0,0 +1,5 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +/*LIT2LATEX_OPTS=-ttgrind*/ + +LitDocRootTarget(root,lit) diff --git a/ghc/compiler/stgSyn/StgFuns.hi b/ghc/compiler/stgSyn/StgFuns.hi new file mode 100644 index 0000000..83ce7be --- /dev/null +++ b/ghc/compiler/stgSyn/StgFuns.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgFuns where +import Id(Id) +import StgSyn(StgRhs) +mapStgBindeesRhs :: (Id -> Id) -> StgRhs Id Id -> StgRhs Id Id + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/StgFuns.lhs b/ghc/compiler/stgSyn/StgFuns.lhs new file mode 100644 index 0000000..8dd3f87 --- /dev/null +++ b/ghc/compiler/stgSyn/StgFuns.lhs @@ -0,0 +1,93 @@ +x% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[StgFuns]{Utility functions for @STG@ programs} + +\begin{code} +#include "HsVersions.h" + +module StgFuns ( + mapStgBindeesRhs + ) where + +import StgSyn + +import UniqSet +import Unique + +import Util +\end{code} + +This utility function simply applies the given function to every +bindee in the program. + +\begin{code} +mapStgBindeesBind :: (Id -> Id) -> PlainStgBinding -> PlainStgBinding + +mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs) +mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] + +------------------ +mapStgBindeesRhs :: (Id -> Id) -> PlainStgRhs -> PlainStgRhs + +mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr) + = StgRhsClosure + cc bi + (map fn fvs) + u + (map fn args) + (mapStgBindeesExpr fn expr) + +mapStgBindeesRhs fn (StgRhsCon cc con atoms) + = StgRhsCon cc con (map (mapStgBindeesAtom fn) atoms) + +------------------ +mapStgBindeesExpr :: (Id -> Id) -> PlainStgExpr -> PlainStgExpr + +mapStgBindeesExpr fn (StgApp f args lvs) + = StgApp (mapStgBindeesAtom fn f) + (map (mapStgBindeesAtom fn) args) + (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgConApp con atoms lvs) + = StgConApp con (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgPrimApp op atoms lvs) + = StgPrimApp op (map (mapStgBindeesAtom fn) atoms) (mapUniqSet fn lvs) + +mapStgBindeesExpr fn (StgLet bind expr) + = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr) + +mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body) + = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs) + (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body) + +mapStgBindeesExpr fn (StgSCC ty label expr) + = StgSCC ty label (mapStgBindeesExpr fn expr) + +mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts) + = StgCase (mapStgBindeesExpr fn expr) + (mapUniqSet fn lvs1) + (mapUniqSet fn lvs2) + uniq + (mapStgBindeesAlts alts) + where + mapStgBindeesAlts (StgAlgAlts ty alts deflt) + = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt) + where + mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr) + + mapStgBindeesAlts (StgPrimAlts ty alts deflt) + = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt) + where + mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr) + + mapStgBindeesDeflt StgNoDefault = StgNoDefault + mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr) + +------------------ +mapStgBindeesAtom :: (Id -> Id) -> PlainStgAtom -> PlainStgAtom + +mapStgBindeesAtom fn a@(StgLitAtom _) = a +mapStgBindeesAtom fn a@(StgVarAtom id) = StgVarAtom (fn id) +\end{code} diff --git a/ghc/compiler/stgSyn/StgLint.hi b/ghc/compiler/stgSyn/StgLint.hi new file mode 100644 index 0000000..0bf1754 --- /dev/null +++ b/ghc/compiler/stgSyn/StgLint.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgLint where +import CmdLineOpts(GlobalSwitch) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Pretty(PprStyle) +import StgSyn(PlainStgBinding(..), StgBinding, StgRhs) +import UniType(UniType) +import Unique(Unique) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type PlainStgBinding = StgBinding Id Id +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +lintStgBindings :: PprStyle -> [Char] -> [StgBinding Id Id] -> [StgBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LLS" _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs new file mode 100644 index 0000000..9f1e5ba --- /dev/null +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -0,0 +1,541 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[StgLint]{A ``lint'' pass to check for Stg correctness} + +\begin{code} +#include "HsVersions.h" + +module StgLint ( + lintStgBindings, + + PprStyle, StgBinding, PlainStgBinding(..), Id + ) where + +IMPORT_Trace + +import AbsPrel ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType +import Bag +import BasicLit ( typeOfBasicLit, BasicLit ) +import Id ( getIdUniType, isNullaryDataCon, isDataCon, + isBottomingId, + getInstantiatedDataConSig, Id + IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) + ) +import Maybes +import Outputable +import Pretty +import SrcLoc ( SrcLoc ) +import StgSyn +import UniqSet +import Util + +infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` +\end{code} + +Checks for + (a) *some* type errors + (b) locally-defined variables used but not defined + +%************************************************************************ +%* * +\subsection{``lint'' for various constructs} +%* * +%************************************************************************ + +@lintStgBindings@ is the top-level interface function. + +\begin{code} +lintStgBindings :: PprStyle -> String -> [PlainStgBinding] -> [PlainStgBinding] + +lintStgBindings sty whodunnit binds + = BSCC("StgLint") + case (initL (lint_binds binds)) of + Nothing -> binds + Just msg -> pprPanic "" (ppAboves [ + ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"), + msg sty, + ppStr "*** Offending Program ***", + ppAboves (map (pprPlainStgBinding sty) binds), + ppStr "*** End of Offense ***"]) + ESCC + where + lint_binds :: [PlainStgBinding] -> LintM () + + lint_binds [] = returnL () + lint_binds (bind:binds) + = lintStgBinds bind `thenL` \ binders -> + addInScopeVars binders ( + lint_binds binds + ) +\end{code} + + +\begin{code} +lintStgAtom :: PlainStgAtom -> LintM (Maybe UniType) + +lintStgAtom (StgLitAtom lit) = returnL (Just (typeOfBasicLit lit)) +lintStgAtom a@(StgVarAtom v) + = checkInScope v `thenL_` + returnL (Just (getIdUniType v)) +\end{code} + +\begin{code} +lintStgBinds :: PlainStgBinding -> LintM [Id] -- Returns the binders +lintStgBinds (StgNonRec binder rhs) + = lint_binds_help (binder,rhs) `thenL_` + returnL [binder] + +lintStgBinds (StgRec pairs) + = addInScopeVars binders ( + mapL lint_binds_help pairs `thenL_` + returnL binders + ) + where + binders = [b | (b,_) <- pairs] + +lint_binds_help (binder, rhs) + = addLoc (RhsOf binder) ( + -- Check the rhs + lintStgRhs rhs `thenL` \ maybe_rhs_ty -> + + -- Check match to RHS type + (case maybe_rhs_ty of + Nothing -> returnL () + Just rhs_ty -> checkTys (getIdUniType binder) + rhs_ty + (mkRhsMsg binder rhs_ty) + ) `thenL_` + + returnL () + ) +\end{code} + +\begin{code} +lintStgRhs :: PlainStgRhs -> LintM (Maybe UniType) + +lintStgRhs (StgRhsClosure _ _ _ _ binders expr) + = addLoc (LambdaBodyOf binders) ( + addInScopeVars binders ( + lintStgExpr expr `thenMaybeL` \ body_ty -> + returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders)) + )) + +lintStgRhs (StgRhsCon _ con args) + = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys) + where + con_ty = getIdUniType con +\end{code} + +\begin{code} +lintStgExpr :: PlainStgExpr -> LintM (Maybe UniType) -- Nothing if error found + +lintStgExpr e@(StgApp fun args _) + = lintStgAtom fun `thenMaybeL` \ fun_ty -> + mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e) + +lintStgExpr e@(StgConApp con args _) + = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e) + where + con_ty = getIdUniType con + +lintStgExpr e@(StgPrimApp op args _) + = mapMaybeL lintStgAtom args `thenL` \ maybe_arg_tys -> + case maybe_arg_tys of + Nothing -> returnL Nothing + Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e) + where + op_ty = typeOfPrimOp op + +lintStgExpr (StgLet binds body) + = lintStgBinds binds `thenL` \ binders -> + addLoc (BodyOfLetRec binders) ( + addInScopeVars binders ( + lintStgExpr body + )) + +lintStgExpr (StgLetNoEscape _ _ binds body) + = lintStgBinds binds `thenL` \ binders -> + addLoc (BodyOfLetRec binders) ( + addInScopeVars binders ( + lintStgExpr body + )) + +lintStgExpr (StgSCC _ _ expr) = lintStgExpr expr + +lintStgExpr e@(StgCase scrut _ _ _ alts) + = lintStgExpr scrut `thenMaybeL` \ _ -> + + -- Check that it is a data type + case getUniDataTyCon_maybe scrut_ty of + Nothing -> addErrL (mkCaseDataConMsg e) `thenL_` + returnL Nothing + Just (tycon, _, _) + -> lintStgAlts alts scrut_ty tycon + where + scrut_ty = get_ty alts + + get_ty (StgAlgAlts ty _ _) = ty + get_ty (StgPrimAlts ty _ _) = ty +\end{code} + +\begin{code} +lintStgAlts :: PlainStgCaseAlternatives + -> UniType -- Type of scrutinee + -> TyCon -- TyCon pinned on the case + -> LintM (Maybe UniType) -- Type of alternatives + +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) + + StgPrimAlts _ prim_alts deflt -> + mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys -> + lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty -> + returnL (maybe_deflt_ty : maybe_alt_tys) + ) `thenL` \ maybe_result_tys -> + -- Check the result types + case catMaybes (maybe_result_tys) of + [] -> returnL Nothing + + (first_ty:tys) -> mapL check tys `thenL_` + 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 getUniDataTyCon_maybe scrut_ty of + Nothing -> + addErrL (mkAlgAltMsg1 scrut_ty) + Just (tycon, tys_applied, cons) -> + let + (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied + in + checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_` + checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) + `thenL_` + mapL check (arg_tys `zipEqual` args) `thenL_` + returnL () + ) `thenL_` + addInScopeVars args ( + lintStgExpr rhs + ) + where + check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg) + + -- elem: yes, the elem-list here can sometimes be long-ish, + -- but as it's use-once, probably not worth doing anything different + -- We give it its own copy, so it isn't overloaded. + elem _ [] = False + elem x (y:ys) = x==y || elem x ys + +lintPrimAlt scrut_ty alt@(lit,rhs) + = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt) `thenL_` + lintStgExpr rhs + +lintDeflt StgNoDefault scrut_ty = returnL Nothing +lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty + = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt) `thenL_` + addInScopeVars [binder] ( + lintStgExpr rhs + ) +\end{code} + + +%************************************************************************ +%* * +\subsection[lint-monad]{The Lint monad} +%* * +%************************************************************************ + +\begin{code} +type LintM a = [LintLocInfo] -- Locations + -> UniqSet Id -- Local vars in scope + -> Bag ErrMsg -- Error messages so far + -> (a, Bag ErrMsg) -- Result and error messages (if any) + +type ErrMsg = PprStyle -> Pretty + +data LintLocInfo + = RhsOf Id -- The variable bound + | LambdaBodyOf [Id] -- The lambda-binder + | BodyOfLetRec [Id] -- One of the binders + +instance Outputable LintLocInfo where + ppr sty (RhsOf v) + = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"] + + ppr sty (LambdaBodyOf bs) + = ppBesides [ppr sty (getSrcLoc (head bs)), + ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"] + + ppr sty (BodyOfLetRec bs) + = ppBesides [ppr sty (getSrcLoc (head bs)), + ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"] + +pp_binders :: PprStyle -> [Id] -> Pretty +pp_binders sty bs + = ppInterleave ppComma (map pp_binder bs) + where + pp_binder b + = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)] +\end{code} + +\begin{code} +initL :: LintM a -> Maybe ErrMsg +initL m + = case (m [] emptyUniqSet emptyBag) of { (_, errs) -> + if isEmptyBag errs then + Nothing + else + Just ( \ sty -> + ppAboves [ msg sty | msg <- bagToList errs ] + ) + } + +returnL :: a -> LintM a +returnL r loc scope errs = (r, errs) + +thenL :: LintM a -> (a -> LintM b) -> LintM b +thenL m k loc scope errs + = case m loc scope errs of + (r, errs') -> k r loc scope errs' + +thenL_ :: LintM a -> LintM b -> LintM b +thenL_ m k loc scope errs + = case m loc scope errs of + (_, errs') -> k loc scope errs' + +thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b) +thenMaybeL m k loc scope errs + = case m loc scope errs of + (Nothing, errs2) -> (Nothing, errs2) + (Just r, errs2) -> k r loc scope errs2 + +thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b) +thenMaybeL_ m k loc scope errs + = case m loc scope errs of + (Nothing, errs2) -> (Nothing, errs2) + (Just _, errs2) -> k loc scope errs2 + +mapL :: (a -> LintM b) -> [a] -> LintM [b] +mapL f [] = returnL [] +mapL f (x:xs) + = f x `thenL` \ r -> + mapL f xs `thenL` \ rs -> + returnL (r:rs) + +mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b]) + -- Returns Nothing if anything fails +mapMaybeL f [] = returnL (Just []) +mapMaybeL f (x:xs) + = f x `thenMaybeL` \ r -> + mapMaybeL f xs `thenMaybeL` \ rs -> + returnL (Just (r:rs)) +\end{code} + +\begin{code} +checkL :: Bool -> ErrMsg -> LintM () +checkL True msg loc scope errs = ((), errs) +checkL False msg loc scope errs = ((), addErr errs msg loc) + +addErrL :: ErrMsg -> LintM () +addErrL msg loc scope errs = ((), addErr errs msg loc) + +addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg + +addErr errs_so_far msg locs + = errs_so_far `snocBag` ( \ sty -> + ppHang (ppr sty (head locs)) 4 (msg sty) + ) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m loc scope errs + = m (extra_loc:loc) scope errs + +addInScopeVars :: [Id] -> LintM a -> LintM a +addInScopeVars ids m loc scope errs + = -- We check if these "new" ids are already + -- in scope, i.e., we have *shadowing* going on. + -- For now, it's just a "trace"; we may make + -- a real error out of it... + let + new_set = mkUniqSet ids + + shadowed = scope `intersectUniqSets` new_set + in +-- After adding -fliberate-case, Simon decided he likes shadowed +-- names after all. WDP 94/07 +-- (if isEmptyUniqSet shadowed +-- then id +-- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) ( + m loc (scope `unionUniqSets` new_set) errs +-- ) +\end{code} + +\begin{code} +checkFunApp :: UniType -- The function type + -> [UniType] -- The arg type(s) + -> ErrMsg -- Error messgae + -> LintM (Maybe UniType) -- The result type + +checkFunApp fun_ty arg_tys msg loc scope errs + = cfa res_ty expected_arg_tys arg_tys + where + (_, 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) + + 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 + = (Just res_ty, errs) + | otherwise + = case splitTyArgs (unDictifyTy res_ty) of + ([], _) -> (Nothing, addErr errs msg loc) -- Too many args + (new_expected, new_res) -> cfa new_res new_expected arg_tys + + cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys) + = case (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 +\end{code} + +\begin{code} +checkInScope :: Id -> LintM () +checkInScope id loc scope errs + = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then + ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc) + else + ((), errs) + +checkTys :: UniType -> UniType -> ErrMsg -> LintM () +checkTys ty1 ty2 msg loc scope errs + = case (sleazy_cmp_ty ty1 ty2) of + EQ_ -> ((), errs) + other -> ((), addErr errs msg loc) +\end{code} + +\begin{code} +mkCaseAltMsg :: PlainStgCaseAlternatives -> ErrMsg +mkCaseAltMsg alts sty + = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:") + -- LATER: (ppr sty alts) + (panic "mkCaseAltMsg") + +mkCaseDataConMsg :: PlainStgExpr -> ErrMsg +mkCaseDataConMsg expr sty + = ppAbove (ppStr "A case scrutinee not a type-constructor type:") + (pp_expr sty expr) + +mkCaseAbstractMsg :: TyCon -> ErrMsg +mkCaseAbstractMsg tycon sty + = ppAbove (ppStr "An algebraic case on an abstract type:") + (ppr sty tycon) + +mkDefltMsg :: PlainStgCaseDefault -> ErrMsg +mkDefltMsg deflt sty + = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:") + --LATER: (ppr sty deflt) + (panic "mkDefltMsg") + +mkFunAppMsg :: UniType -> [UniType] -> PlainStgExpr -> ErrMsg +mkFunAppMsg fun_ty arg_tys expr sty + = ppAboves [ppStr "In a function application, function type doesn't match arg types:", + ppHang (ppStr "Function type:") 4 (ppr sty fun_ty), + ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)), + ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] + +mkRhsConMsg :: UniType -> [UniType] -> ErrMsg +mkRhsConMsg fun_ty arg_tys sty + = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:", + ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty), + ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))] + +mkUnappTyMsg :: Id -> UniType -> ErrMsg +mkUnappTyMsg var ty sty + = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.", + ppBeside (ppStr "Var: ") (ppr sty var), + ppBeside (ppStr "Its type: ") (ppr sty ty)] + +mkAlgAltMsg1 :: UniType -> ErrMsg +mkAlgAltMsg1 ty sty + = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") + (ppr sty ty) + +mkAlgAltMsg2 :: UniType -> Id -> ErrMsg +mkAlgAltMsg2 ty con sty + = ppAboves [ + ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", + ppr sty ty, + ppr sty con + ] + +mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg +mkAlgAltMsg3 con alts sty + = ppAboves [ + ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:", + ppr sty con, + ppr sty alts + ] + +mkAlgAltMsg4 :: UniType -> Id -> ErrMsg +mkAlgAltMsg4 ty arg sty + = ppAboves [ + ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:", + ppr sty ty, + ppr sty arg + ] + +mkPrimAltMsg :: (BasicLit, PlainStgExpr) -> ErrMsg +mkPrimAltMsg alt sty + = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:") + (ppr sty alt) + +mkRhsMsg :: Id -> UniType -> ErrMsg +mkRhsMsg binder ty sty + = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:", + ppr sty binder], + ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)], + ppCat [ppStr "Rhs type:", ppr sty ty] + ] + +pp_expr :: PprStyle -> PlainStgExpr -> Pretty +pp_expr sty expr = ppr sty expr + +sleazy_cmp_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 + in + cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22 + }} +\end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.hi b/ghc/compiler/stgSyn/StgSyn.hi new file mode 100644 index 0000000..31c584e --- /dev/null +++ b/ghc/compiler/stgSyn/StgSyn.hi @@ -0,0 +1,443 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StgSyn where +import Bag(Bag) +import BasicLit(BasicLit, isLitLitLit) +import CharSeq(CSeq) +import Class(Class, ClassOp, cmpClass) +import CmdLineOpts(GlobalSwitch) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import HsBinds(Bind, Binds, Sig) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo) +import Inst(Inst) +import InstEnv(InstTemplate) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import PrimOps(PrimOp) +import SimplEnv(UnfoldingDetails) +import SrcLoc(SrcLoc) +import TyCon(TyCon, cmpTyCon) +import TyVar(TyVar, TyVarTemplate, cmpTyVar) +import TyVarEnv(TyVarEnv(..)) +import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType, cmpUniType) +import UniqFM(UniqFM) +import UniqSet(UniqSet(..)) +import Unique(Unique) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-} +data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +type PlainStgAtom = StgAtom Id +type PlainStgBinding = StgBinding Id Id +type PlainStgCaseAlternatives = StgCaseAlternatives Id Id +type PlainStgCaseDefault = StgCaseDefault Id Id +type PlainStgExpr = StgExpr Id Id +type PlainStgLiveVars = UniqFM Id +type PlainStgProgram = [StgBinding Id Id] +type PlainStgRhs = StgRhs Id Id +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data StgAtom a = StgVarAtom a | StgLitAtom BasicLit +data StgBinderInfo = NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool +data StgBinding a b = StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] +data StgCaseAlternatives a b = StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) +data StgCaseDefault a b = StgNoDefault | StgBindDefault a Bool (StgExpr a b) +data StgExpr a b = StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) +type StgLiveVars a = UniqFM a +data StgRhs a b = StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UpdateFlag = ReEntrant | Updatable | SingleEntry +isLitLitLit :: BasicLit -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit MachLitLit (u1 :: _PackedString) (u2 :: PrimKind) -> _!_ True [] []; (u3 :: BasicLit) -> _!_ False [] [] } _N_ #-} +cmpClass :: Class -> Class -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpTyVar :: TyVar -> TyVar -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +collectExportedStgBinders :: [StgBinding Id Id] -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +getAtomKind :: StgAtom Id -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: StgAtom Id) -> case u0 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u1 :: Id) -> _APP_ _ORIG_ Id getIdKind [ u1 ]; _ORIG_ StgSyn StgLitAtom (u2 :: BasicLit) -> _APP_ _ORIG_ BasicLit kindOfBasicLit [ u2 ]; _NO_DEFLT_ } _N_ #-} +isLitLitStgAtom :: StgAtom a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: StgAtom u0) -> case u1 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u2 :: u0) -> _!_ False [] []; _ORIG_ StgSyn StgLitAtom (u3 :: BasicLit) -> _APP_ _ORIG_ BasicLit isLitLitLit [ u3 ]; _NO_DEFLT_ } _N_ #-} +pprPlainStgBinding :: PprStyle -> StgBinding Id Id -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +stgArgOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgArity :: StgRhs Id Id -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: StgRhs Id Id) -> case u0 of { _ALG_ _ORIG_ StgSyn StgRhsCon (u1 :: CostCentre) (u2 :: Id) (u3 :: [StgAtom Id]) -> _!_ I# [] [0#]; _ORIG_ StgSyn StgRhsClosure (u4 :: CostCentre) (u5 :: StgBinderInfo) (u6 :: [Id]) (u7 :: UpdateFlag) (u8 :: [Id]) (u9 :: StgExpr Id Id) -> _APP_ _TYAPP_ _ORIG_ PreludeList length { Id } [ u8 ]; _NO_DEFLT_ } _N_ #-} +stgFakeFunAppOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgNoUpdHeapOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgNormalOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgStdHeapOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +stgUnsatOcc :: StgBinderInfo + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instance Eq BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Eq PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing a => NamedThing (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-} +instance NamedThing Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_, + getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-} +instance NamedThing ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-} +instance NamedThing TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable BasicLit + {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_ + ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b) + {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b) + {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-} +instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b) + {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-} +instance Outputable a => Outputable (InPat a) + {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable Id + {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-} +instance Outputable FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimKind + {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_ + ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable PrimOp + {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-} +instance Outputable a => Outputable (StgAtom a) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _F_ _IF_ARGS_ 1 3 XXC 8 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: StgAtom u0) -> case u3 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u4 :: u0) -> _APP_ u1 [ u2, u4 ]; _ORIG_ StgSyn StgLitAtom (u5 :: BasicLit) -> _APP_ _CONSTM_ Outputable ppr (BasicLit) [ u2, u5 ]; _NO_DEFLT_ } _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgBinding a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-} +instance (Outputable a, Outputable b, Ord b) => Outputable (StgRhs a b) + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLS" _N_ _N_ #-} +instance Outputable UpdateFlag + {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (UpdateFlag) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "ALLA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_ + ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs new file mode 100644 index 0000000..577498d --- /dev/null +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -0,0 +1,882 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} + +This data type represents programs just before code generation +(conversion to @AbstractC@): basically, what we have is a stylised +form of @CoreSyntax@, the style being one that happens to be ideally +suited to spineless tagless code generation. + +\begin{code} +#include "HsVersions.h" + +module StgSyn ( + StgAtom(..), + StgLiveVars(..), + + StgBinding(..), StgExpr(..), StgRhs(..), + StgCaseAlternatives(..), StgCaseDefault(..), +#ifdef DPH + StgParCommunicate(..), +#endif {- Data Parallel Haskell -} + + UpdateFlag(..), + + StgBinderInfo(..), + stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc, + stgNormalOcc, stgFakeFunAppOcc, + combineStgBinderInfo, + + -- a set of synonyms for the most common (only :-) parameterisation + PlainStgAtom(..), PlainStgLiveVars(..), PlainStgProgram(..), + PlainStgBinding(..), PlainStgExpr(..), PlainStgRhs(..), + PlainStgCaseAlternatives(..), PlainStgCaseDefault(..), + + pprPlainStgBinding, +--UNUSED: fvsFromAtoms, + getAtomKind, + isLitLitStgAtom, + stgArity, + collectExportedStgBinders, + + -- and to make the interface self-sufficient... + Outputable(..), NamedThing(..), Pretty(..), + Unique, ExportFlag, SrcLoc, PprStyle, PrettyRep, + + BasicLit, Class, ClassOp, + + Binds, Expr, GRHS, GRHSsAndBinds, InPat, + + Id, IdInfo, Maybe, Name, FullName, ShortName, + PrimKind, PrimOp, CostCentre, TyCon, TyVar, + UniqSet(..), UniqFM, Bag, + TyVarTemplate, UniType, TauType(..), + ThetaType(..), SigmaType(..), + TyVarEnv(..), IdEnv(..) + + IF_ATTACK_PRAGMAS(COMMA isLitLitLit) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) where + +import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..), + PrimOp, PrimKind + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsSyn ( Binds, Expr, GRHS, GRHSsAndBinds, InPat ) +import AbsUniType +import BasicLit ( typeOfBasicLit, kindOfBasicLit, isLitLitLit, + BasicLit(..) -- (..) for pragmas + ) +import Id ( getIdUniType, getIdKind, toplevelishId, + isTopLevId, Id, IdInfo + ) +import Maybes ( Maybe(..), catMaybes ) +import Outputable +import Pretty +import PrimKind ( PrimKind ) +import CostCentre ( showCostCentre, CostCentre ) +import UniqSet +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[StgBinding]{@StgBinding@} +%* * +%************************************************************************ + +As usual, expressions are interesting; other things are boring. Here +are the boring things [except note the @StgRhs@], parameterised with +respect to binder and bindee information (just as in @CoreSyntax@): +\begin{code} +data StgBinding binder bindee + = StgNonRec binder (StgRhs binder bindee) + | StgRec [(binder, StgRhs binder bindee)] +\end{code} + +An @StgProgram@ is just a list of @StgBindings@; the +properties/restrictions-on this list are the same as for a +@CoreProgram@ (a list of @CoreBindings@). +\begin{code} +--type StgProgram binder bindee = [StgBinding binder bindee] +\end{code} + +%************************************************************************ +%* * +\subsection[StgAtom]{@StgAtom@} +%* * +%************************************************************************ + +\begin{code} +data StgAtom bindee + = StgVarAtom bindee + | StgLitAtom BasicLit +\end{code} + +\begin{code} +getAtomKind (StgVarAtom local) = getIdKind local +getAtomKind (StgLitAtom lit) = kindOfBasicLit lit + +{- UNUSED happily +fvsFromAtoms :: [PlainStgAtom] -> (UniqSet Id) -- ToDo: this looks like a HACK to me (WDP) +fvsFromAtoms as = mkUniqSet [ id | (StgVarAtom id) <- as, not (toplevelishId id) ] +-} + +isLitLitStgAtom (StgLitAtom x) = isLitLitLit x +isLitLitStgAtom _ = False +\end{code} + +%************************************************************************ +%* * +\subsection[StgExpr]{STG expressions} +%* * +%************************************************************************ + +The @StgExpr@ data type is parameterised on binder and bindee info, as +before. + +%************************************************************************ +%* * +\subsubsection[StgExpr-application]{@StgExpr@ application} +%* * +%************************************************************************ + +An application is of a function to a list of atoms [not expressions]. +Operationally, we want to push the arguments on the stack and call the +function. (If the arguments were expressions, we would have to build +their closures first.) + +There is no constructor for a lone variable; it would appear as +@StgApp var [] _@. +\begin{code} +type StgLiveVars bindee = UniqSet bindee + +data StgExpr binder bindee + = StgApp + (StgAtom bindee) -- function + [StgAtom bindee] -- arguments + (StgLiveVars bindee) -- Live vars in continuation; ie not + -- including the function and args + + -- NB: a literal is: StgApp [] ... +\end{code} + +%************************************************************************ +%* * +\subsubsection[StgExpr-apps]{@StgConApp@ and @StgPrimApp@---saturated applications} +%* * +%************************************************************************ + +There are two specialised forms of application, for +constructors and primitives. +\begin{code} + | StgConApp -- always saturated + Id -- data constructor + [StgAtom bindee] + (StgLiveVars bindee) -- Live vars in continuation; ie not + -- including the constr and args + + | StgPrimApp -- always saturated + PrimOp + [StgAtom bindee] + (StgLiveVars bindee) -- Live vars in continuation; ie not + -- including the op and args +\end{code} +These forms are to do ``inline versions,'' as it were. +An example might be: @f x = x:[]@. + +%************************************************************************ +%* * +\subsubsection[StgExpr-case]{@StgExpr@: case-expressions} +%* * +%************************************************************************ + +This has the same boxed/unboxed business as Core case expressions. +\begin{code} + | StgCase + (StgExpr binder bindee) + -- the thing to examine + + (StgLiveVars bindee) -- Live vars of whole case + -- expression; i.e., those which mustn't be + -- overwritten + + (StgLiveVars bindee) -- Live vars of RHSs; + -- i.e., those which must be saved before eval. + -- + -- note that an alt's constructor's + -- binder-variables are NOT counted in the + -- free vars for the alt's RHS + + Unique -- Occasionally needed to compile case + -- statements, as the uniq for a local + -- variable to hold the tag of a primop with + -- algebraic result + + (StgCaseAlternatives binder bindee) +\end{code} + +%************************************************************************ +%* * +\subsubsection[StgExpr-lets]{@StgExpr@: @let(rec)@-expressions} +%* * +%************************************************************************ + +The various forms of let(rec)-expression encode most of the +interesting things we want to do. +\begin{enumerate} +\item +\begin{verbatim} +let-closure x = [free-vars] expr [args] +in e +\end{verbatim} +is equivalent to +\begin{verbatim} +let x = (\free-vars -> \args -> expr) free-vars +\end{verbatim} +\tr{args} may be empty (and is for most closures). It isn't under +circumstances like this: +\begin{verbatim} +let x = (\y -> y+z) +\end{verbatim} +This gets mangled to +\begin{verbatim} +let-closure x = [z] [y] (y+z) +\end{verbatim} +The idea is that we compile code for @(y+z)@ in an environment in which +@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an +offset from the stack pointer. + +(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) + +\item +\begin{verbatim} +let-constructor x = Constructor [args] +in e +\end{verbatim} + +(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) + +\item +Letrec-expressions are essentially the same deal as +let-closure/let-constructor, so we use a common structure and +distinguish between them with an @is_recursive@ boolean flag. + +\item +\begin{verbatim} +let-unboxed u = an arbitrary arithmetic expression in unboxed values +in e +\end{verbatim} +All the stuff on the RHS must be fully evaluated. No function calls either! + +(We've backed away from this toward case-expressions with +suitably-magical alts ...) + +\item +~[Advanced stuff here! Not to start with, but makes pattern matching +generate more efficient code.] + +\begin{verbatim} +let-escapes-not fail = expr +in e' +\end{verbatim} +Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, +or pass it to another function. All @e'@ will ever do is tail-call @fail@. +Rather than build a closure for @fail@, all we need do is to record the stack +level at the moment of the @let-escapes-not@; then entering @fail@ is just +a matter of adjusting the stack pointer back down to that point and entering +the code for it. + +Another example: +\begin{verbatim} +f x y = let z = huge-expression in + if y==1 then z else + if y==2 then z else + 1 +\end{verbatim} + +(A let-escapes-not is an @StgLetNoEscape@.) + +\item +We may eventually want: +\begin{verbatim} +let-literal x = BasicLit +in e +\end{verbatim} + +(ToDo: is this obsolete?) +\end{enumerate} + +And so the code for let(rec)-things: +\begin{code} + | StgLet + (StgBinding binder bindee) -- right hand sides (see below) + (StgExpr binder bindee) -- body + + | StgLetNoEscape -- remember: ``advanced stuff'' + (StgLiveVars bindee) -- Live in the whole let-expression + -- Mustn't overwrite these stack slots + -- *Doesn't* include binders of the let(rec). + + (StgLiveVars bindee) -- Live in the right hand sides (only) + -- These are the ones which must be saved on + -- the stack if they aren't there already + -- *Does* include binders of the let(rec) if recursive. + + (StgBinding binder bindee) -- right hand sides (see below) + (StgExpr binder bindee) -- body +\end{code} + +%************************************************************************ +%* * +\subsubsection[StgExpr-scc]{@StgExpr@: @scc@ expressions} +%* * +%************************************************************************ + +Finally for @scc@ expressions we introduce a new STG construct. + +\begin{code} + | StgSCC + UniType -- the type of the body + CostCentre -- label of SCC expression + (StgExpr binder bindee) -- scc expression +\end{code} + +%************************************************************************ +%* * +\subsection[DataParallel]{Data parallel extensions to STG syntax} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH + | StgParConApp -- saturated parallel constructor + Id + Int -- What parallel context + [StgAtom bindee] + (StgLiveVars bindee) + + | StgParComm + Int + (StgExpr binder bindee) -- The thing we are communicating + (StgParCommunicate binder bindee) +#endif {- Data Parallel Haskell -} + -- end of StgExpr +\end{code} + +%************************************************************************ +%* * +\subsection[StgRhs]{STG right-hand sides} +%* * +%************************************************************************ + +Here's the rest of the interesting stuff for @StgLet@s; the first +flavour is for closures: +\begin{code} +data StgRhs binder bindee + = StgRhsClosure + CostCentre -- cost centre to be attached (default is CCC) + StgBinderInfo -- Info about how this binder is used (see below) + [bindee] -- non-global free vars; a list, rather than + -- a set, because order is important + UpdateFlag -- ReEntrant | Updatable | SingleEntry + [binder] -- arguments; if empty, then not a function; + -- as above, order is important + (StgExpr binder bindee) -- body +\end{code} +An example may be in order. Consider: +\begin{verbatim} +let t = \x -> \y -> ... x ... y ... p ... q in e +\end{verbatim} +Pulling out the free vars and stylising somewhat, we get the equivalent: +\begin{verbatim} +let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q +\end{verbatim} +Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are +offsets from @Node@ into the closure, and the code ptr for the closure +will be exactly that in parentheses above. + +The second flavour of right-hand-side is for constructors (simple but important): +\begin{code} + | StgRhsCon + CostCentre -- Cost centre to be attached (default is CCC). + -- Top-level (static) ones will end up with + -- DontCareCC, because we don't count static + -- data in heap profiles, and we don't set CCC + -- from static closure. + Id -- constructor + [StgAtom bindee] -- args +\end{code} + +Here's the @StgBinderInfo@ type, and its combining op: +\begin{code} +data StgBinderInfo + = NoStgBinderInfo + + | StgBinderInfo + Bool -- At least one occurrence as an argument + + Bool -- At least one occurrence in an unsaturated application + + Bool -- This thing (f) has at least occurrence of the form: + -- x = [..] \u [] -> f a b c + -- where the application is saturated + + Bool -- Ditto for non-updatable x. + + Bool -- At least one fake application occurrence, that is + -- an StgApp f args where args is an empty list + -- This is due to the fact that we do not have a + -- StgVar constructor. + -- Used by the lambda lifter. + -- True => "at least one unsat app" is True too + +stgArgOcc = StgBinderInfo True False False False False +stgUnsatOcc = StgBinderInfo False True False False False +stgStdHeapOcc = StgBinderInfo False False True False False +stgNoUpdHeapOcc = StgBinderInfo False False False True False +stgNormalOcc = StgBinderInfo False False False False False +-- [Andre] can't think of a good name for the last one. +stgFakeFunAppOcc = StgBinderInfo False True False False True + +combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo + +combineStgBinderInfo NoStgBinderInfo info2 = info2 +combineStgBinderInfo info1 NoStgBinderInfo = info1 +combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) + (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2) + = StgBinderInfo (arg1 || arg2) + (unsat1 || unsat2) + (std_heap1 || std_heap2) + (upd_heap1 || upd_heap2) + (fkap1 || fkap2) +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-case-alternatives]{STG case alternatives} +%* * +%************************************************************************ + +Just like in @CoreSyntax@ (except no type-world stuff). + +\begin{code} +data StgCaseAlternatives binder bindee + = StgAlgAlts UniType -- so we can find out things about constructor family + [(Id, -- alts: data constructor, + [binder], -- constructor's parameters, + [Bool], -- "use mask", same length as + -- parameters; a True in a + -- param's position if it is + -- used in the ... + StgExpr binder bindee)] -- ...right-hand side. + (StgCaseDefault binder bindee) + | StgPrimAlts UniType -- so we can find out things about constructor family + [(BasicLit, -- alts: unboxed literal, + StgExpr binder bindee)] -- rhs. + (StgCaseDefault binder bindee) +#ifdef DPH + | StgParAlgAlts + UniType + Int -- What context we are in + [binder] + [(Id,StgExpr binder bindee)] + (StgCaseDefault binder bindee) + | StgParPrimAlts UniType + Int -- What context we are in + [(BasicLit, -- alts: unboxed literal, + StgExpr binder bindee)] -- rhs. + (StgCaseDefault binder bindee) +#endif {- Data Parallel Haskell -} + +data StgCaseDefault binder bindee + = StgNoDefault -- small con family: all + -- constructor accounted for + | StgBindDefault binder -- form: var -> expr + Bool -- True <=> var is used in rhs + -- i.e., False <=> "_ -> expr" + (StgExpr binder bindee) +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-parComummunicate]{Communication operations} +%* * +%************************************************************************ + +\begin{code} +#ifdef DPH +data StgParCommunicate binder bindee + = StgParSend + [StgAtom bindee] -- Sending PODs + + | StgParFetch + [StgAtom bindee] -- Fetching PODs + + | StgToPodized -- Convert a POD to the podized form + + | StgFromPodized -- Convert a POD from the podized form +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[PlainStg]{The Plain STG parameterisation} +%* * +%************************************************************************ + +This happens to be the only one we use at the moment. + +\begin{code} +type PlainStgProgram = [StgBinding Id Id] +type PlainStgBinding = StgBinding Id Id +type PlainStgAtom = StgAtom Id +type PlainStgLiveVars= UniqSet Id +type PlainStgExpr = StgExpr Id Id +type PlainStgRhs = StgRhs Id Id +type PlainStgCaseAlternatives = StgCaseAlternatives Id Id +type PlainStgCaseDefault = StgCaseDefault Id Id +\end{code} + +%************************************************************************ +%* * +\subsubsection[UpdateFlag-datatype]{@UpdateFlag@} +%* * +%************************************************************************ + +This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. + +\begin{code} +data UpdateFlag = ReEntrant | Updatable | SingleEntry + +instance Outputable UpdateFlag where + ppr sty u + = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-utility-functions]{Utility functions} +%* * +%************************************************************************ + + +For doing interfaces, we want the exported top-level Ids from the +final pre-codegen STG code, so as to be sure we have the +latest/greatest pragma info. + +\begin{code} +collectExportedStgBinders + :: [PlainStgBinding] -- input: PlainStgProgram + -> [Id] -- exported top-level Ids + +collectExportedStgBinders binds + = exported_from_here [] binds + where + exported_from_here es [] = es + + exported_from_here es ((StgNonRec b _) : binds) + = if not (isExported b) then + exported_from_here es binds + else + exported_from_here (b:es) binds + + exported_from_here es ((StgRec []) : binds) + = exported_from_here es binds + + exported_from_here es ((StgRec ((b, rhs) : pairs)) : binds) + = exported_from_here + es + (StgNonRec b rhs : (StgRec pairs : binds)) + -- OK, a total hack; laziness rules +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-pretty-printing]{Pretty-printing} +%* * +%************************************************************************ + +Robin Popplestone asked for semi-colon separators on STG binds; here's +hoping he likes terminators instead... Ditto for case alternatives. + +\begin{code} +pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => + PprStyle -> StgBinding bndr bdee -> Pretty + +pprStgBinding sty (StgNonRec binder rhs) + = ppHang (ppCat [ppr sty binder, ppEquals]) + 4 (ppBeside (ppr sty rhs) ppSemi) + +pprStgBinding sty (StgRec pairs) + = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) : + (map (ppr_bind sty) pairs)) + where + ppr_bind sty (binder, expr) + = ppHang (ppCat [ppr sty binder, ppEquals]) + 4 (ppBeside (ppr sty expr) ppSemi) + +pprPlainStgBinding :: PprStyle -> PlainStgBinding -> Pretty +pprPlainStgBinding sty b = pprStgBinding sty b +\end{code} + +\begin{code} +instance (Outputable bdee) => Outputable (StgAtom bdee) where + ppr = pprStgAtom + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgBinding bndr bdee) where + ppr = pprStgBinding + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgExpr bndr bdee) where + ppr = pprStgExpr + +{- OLD: +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgCaseDefault bndr bdee) where + ppr sty deflt = panic "ppr:StgCaseDefault" +-} + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (StgRhs bndr bdee) where + ppr sty rhs = pprStgRhs sty rhs +\end{code} + +\begin{code} +pprStgAtom :: (Outputable bdee) => PprStyle -> StgAtom bdee -> Pretty + +pprStgAtom sty (StgVarAtom var) = ppr sty var +pprStgAtom sty (StgLitAtom lit) = ppr sty lit +\end{code} + +\begin{code} +pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => + PprStyle -> StgExpr bndr bdee -> Pretty +-- special case +pprStgExpr sty (StgApp func [] lvs) + = ppBeside (ppr sty func) (pprStgLVs sty lvs) + +-- general case +pprStgExpr sty (StgApp func args lvs) + = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs)) + 4 (ppSep (map (ppr sty) args)) +\end{code} + +\begin{code} +pprStgExpr sty (StgConApp con args lvs) + = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs), + ppStr "! [", interppSP sty args, ppStr "]" ] + +pprStgExpr sty (StgPrimApp op args lvs) + = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs, + ppStr " [", interppSP sty args, ppStr "]" ] +\end{code} + +\begin{code} +-- special case: let v = +-- in +-- let ... +-- in +-- ... +-- +-- Very special! Suspicious! (SLPJ) + +pprStgExpr sty (StgLet (StgNonRec binder (StgRhsClosure cc bi free_vars upd_flag args rhs)) + expr@(StgLet _ _)) + = ppAbove + (ppHang (ppBesides [ppStr "let { ", ppr sty binder, ppStr " = ", + ppStr (showCostCentre sty True{-as string-} cc), + pp_binder_info sty bi, + ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\", + ppr sty upd_flag, ppStr " [", + interppSP sty args, ppStr "]"]) + 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]])) + (ppr sty expr) + +-- special case: let ... in let ... + +pprStgExpr sty (StgLet bind expr@(StgLet _ _)) + = ppAbove + (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])]) + (ppr sty expr) + +-- general case +pprStgExpr sty (StgLet bind expr) + = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind), + ppHang (ppStr "} in ") 2 (ppr sty expr)] + +pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr) + = ppSep [ppHang (ppStr "let-no-escape {") + 2 (pprStgBinding sty bind), + ppHang (ppBeside (ppStr "} in ") + (ifPprDebug sty ( + ppNest 4 ( + ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), + ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), + ppStr "]"])))) + 2 (ppr sty expr)] +\end{code} + +\begin{code} +pprStgExpr sty (StgSCC ty cc expr) + = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)], + pprStgExpr sty expr ] +\end{code} + +\begin{code} +pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) + = ppSep [ppSep [ppStr "case", + ppNest 4 (ppCat [pprStgExpr sty expr, + ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]), + ppStr "of {"], + ifPprDebug sty ( + ppNest 4 ( + ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), + ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), + ppStr "]; uniq: ", pprUnique uniq])), + ppNest 2 (ppr_alts sty alts), + ppStr "}"] + where + pp_ty (StgAlgAlts ty _ _) = ppr sty ty + pp_ty (StgPrimAlts ty _ _) = ppr sty ty + + ppr_alts sty (StgAlgAlts ty alts deflt) + = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_bxd_alt sty (con, params, use_mask, expr) + = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"]) + 4 (ppBeside (ppr sty expr) ppSemi) + where + ppr_con sty con + = if isOpLexeme con + then ppBesides [ppLparen, ppr sty con, ppRparen] + else ppr sty con + + ppr_alts sty (StgPrimAlts ty alts deflt) + = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_ubxd_alt sty (lit, expr) + = ppHang (ppCat [ppr sty lit, ppStr "->"]) + 4 (ppBeside (ppr sty expr) ppSemi) + +#ifdef DPH + ppr_alts sty (StgParAlgAlts ty dim params alts deflt) + = ppAboves [ ppBeside (ppCat (map (ppr sty) params)) + (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]), + ppAboves (map (ppr_bxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_bxd_alt sty (con, expr) + = ppHang (ppCat [ppStr "\\/", ppr_con sty con, ppStr "->"]) + 4 (ppr sty expr) + where + ppr_con sty con + = if isOpLexeme con + then ppBesides [ppLparen, ppr sty con, ppRparen] + else ppr sty con + + ppr_alts sty (StgParPrimAlts ty dim alts deflt) + = ppAboves [ ifPprShowAll sty (ppr sty ty), + ppCat [ppStr "|" , ppr sty dim , ppStr "|"], + ppAboves (map (ppr_ubxd_alt sty) alts), + ppr_default sty deflt ] + where + ppr_ubxd_alt sty (lit, expr) + = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr) +#endif {- Data Parallel Haskell -} + + ppr_default sty StgNoDefault = ppNil + ppr_default sty (StgBindDefault binder used expr) + = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) + where + pp_binder = if used then ppr sty binder else ppChar '_' +\end{code} + +\begin{code} +#ifdef DPH +pprStgExpr sty (StgParConApp con dim args lvs) + = ppBesides [ppr sty con, pprStgLVs sty lvs, ppStr "!<<" ,ppr sty dim , + ppStr ">> [", interppSP sty args, ppStr "]" ] + +pprStgExpr sty (StgParComm dim expr comm) + = ppSep [ppSep [ppStr "COMM ", + ppNest 2 (pprStgExpr sty expr),ppStr "{"], + ppNest 2 (ppr_comm sty comm), + ppStr "}"] + where + ppr_comm sty (StgParSend args) + = ppSep [ppStr "SEND [",interppSP sty args, ppStr "]" ] + ppr_comm sty (StgParFetch args) + = ppSep [ppStr "FETCH [",interppSP sty args, ppStr "]" ] + ppr_comm sty (StgToPodized) + = ppStr "ToPodized" + ppr_comm sty (StgFromPodized) + = ppStr "FromPodized" +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +-- pprStgLVs :: PprStyle -> StgLiveVars bindee -> Pretty + +pprStgLVs PprForUser lvs = ppNil + +pprStgLVs sty lvs + = if isEmptyUniqSet lvs then + ppNil + else + ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"] +\end{code} + +\begin{code} +pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => + PprStyle -> StgRhs bndr bdee -> Pretty + +-- special case +pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) + = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), + pp_binder_info sty bi, + ppStr " [", ifPprDebug sty (ppr sty free_var), + ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ] +-- general case +pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body) + = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), + pp_binder_info sty bi, + ppStr " [", ifPprDebug sty (interppSP sty free_vars), + ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"]) + 4 (ppr sty body) + +pprStgRhs sty (StgRhsCon cc con args) + = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), + ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ] + +-------------- +pp_binder_info PprForUser _ = ppNil + +pp_binder_info sty NoStgBinderInfo = ppNil + +-- cases so boring that we print nothing +pp_binder_info sty (StgBinderInfo True b c d e) = ppNil + +-- general case +pp_binder_info sty (StgBinderInfo a b c d e) + = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')'] + where + pp_bool x = ppr (panic "pp_bool") x +\end{code} + +Collect @IdInfo@ stuff that is most easily just snaffled straight +from the STG bindings. + +\begin{code} +stgArity :: PlainStgRhs -> Int + +stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied +stgArity (StgRhsClosure _ _ _ _ args _ ) = length args +\end{code} diff --git a/ghc/compiler/stgSyn/root.lit b/ghc/compiler/stgSyn/root.lit new file mode 100644 index 0000000..9842848 --- /dev/null +++ b/ghc/compiler/stgSyn/root.lit @@ -0,0 +1,9 @@ +\documentstyle[11pt,literate,a4wide]{article} + +\begin{document} +\author{Simon and friends} +\title{STG Syntax} +\maketitle + +\input{StgSyn.lhs} +\end{document} diff --git a/ghc/compiler/stranal/SaAbsInt.hi b/ghc/compiler/stranal/SaAbsInt.hi new file mode 100644 index 0000000..e250613 --- /dev/null +++ b/ghc/compiler/stranal/SaAbsInt.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SaAbsInt where +import CoreSyn(CoreExpr) +import Id(Id) +import IdInfo(Demand) +import SaLib(AbsVal, AbsValEnv, AnalysisKind) +import UniType(UniType) +absEval :: AnalysisKind -> CoreExpr Id Id -> AbsValEnv -> AbsVal + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSL" _N_ _N_ #-} +findDemand :: AbsValEnv -> AbsValEnv -> CoreExpr Id Id -> Id -> Demand + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LLLU(LSLL)" _N_ _N_ #-} +findStrictness :: [UniType] -> AbsVal -> AbsVal -> [Demand] + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-} +fixpoint :: AnalysisKind -> [Id] -> [CoreExpr Id Id] -> AbsValEnv -> [AbsVal] + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LSLL" _N_ _N_ #-} +isBot :: AbsVal -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +widen :: AnalysisKind -> AbsVal -> AbsVal + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "ES" _N_ _N_ #-} + diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs new file mode 100644 index 0000000..9cdb3d4 --- /dev/null +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -0,0 +1,1043 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[SaAbsInt]{Abstract interpreter for strictness analysis} + +\begin{code} +#include "HsVersions.h" + +module SaAbsInt ( + findStrictness, + findDemand, + absEval, + widen, + fixpoint, + isBot + ) where + +IMPORT_Trace -- ToDo: rm +import Pretty +--import FiniteMap +import Outputable + +import AbsPrel ( PrimOp(..), PrimKind ) +import AbsUniType ( isPrimType, getUniDataTyCon_maybe, + maybeSingleConstructorTyCon, + returnsRealWorld, + isEnumerationTyCon, TyVarTemplate, TyCon + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import Id ( getIdStrictness, getIdUniType, getIdUnfolding, + getDataConSig, getInstantiatedDataConSig, + DataCon(..), isBottomingId + ) + +import IdInfo -- various bits +import IdEnv +import CoreFuns ( unTagBinders ) +import Maybes ( maybeToBool, Maybe(..) ) +import PlainCore +import SaLib +import SimplEnv ( FormSummary(..) ) -- nice data abstraction, huh? (WDP 95/03) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[AbsVal-ops]{Operations on @AbsVals@} +%* * +%************************************************************************ + +Least upper bound, greatest lower bound. + +\begin{code} +lub, glb :: AbsVal -> AbsVal -> AbsVal + +lub val1 val2 | isBot val1 = val2 -- The isBot test includes the case where +lub val1 val2 | isBot val2 = val1 -- one of the val's is a function which + -- always returns bottom, such as \y.x, + -- when x is bound to bottom. + +lub (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys) + AbsProd (zipWith lub xs ys) + +lub _ _ = AbsTop -- Crude, but conservative + -- The crudity only shows up if there + -- are functions involved + +-- Slightly funny glb; for absence analysis only; +-- AbsBot is the safe answer. +-- +-- Using anyBot rather than just testing for AbsBot is important. +-- Consider: +-- +-- f = \a b -> ... +-- +-- g = \x y z -> case x of +-- [] -> f x +-- (p:ps) -> f p +-- +-- Now, the abstract value of the branches of the case will be an +-- AbsFun, but when testing for z's absence we want to spot that it's +-- an AbsFun which can't possibly return AbsBot. So when glb'ing we +-- mustn't be too keen to bale out and return AbsBot; the anyBot test +-- spots that (f x) can't possibly return AbsBot. + +-- We have also tripped over the following interesting case: +-- case x of +-- [] -> \y -> 1 +-- (p:ps) -> f +-- +-- Now, suppose f is bound to AbsTop. Does this expression mention z? +-- Obviously not. But the case will take the glb of AbsTop (for f) and +-- an AbsFun (for \y->1). We should not bale out and give AbsBot, because +-- that would say that it *does* mention z (or anything else for that matter). +-- Nor can we always return AbsTop, because the AbsFun might be something +-- like (\y->z), which obviously does mention z. The point is that we're +-- glbing two functions, and AbsTop is not actually the top of the function +-- lattice. It is more like (\xyz -> x|y|z); that is, AbsTop returns +-- poison iff any of its arguments do. + +-- Deal with functions specially, because AbsTop isn't the +-- top of their domain. + +glb v1 v2 + | is_fun v1 || is_fun v2 + = if not (anyBot v1) && not (anyBot v2) + then + AbsTop + else + AbsBot + where + is_fun (AbsFun _ _ _) = True + is_fun (AbsApproxFun _) = True -- Not used, but the glb works ok + is_fun other = False + +-- The non-functional cases are quite straightforward + +glb (AbsProd xs) (AbsProd ys) = ASSERT (length xs == length ys) + AbsProd (zipWith glb xs ys) + +glb AbsTop v2 = v2 +glb v1 AbsTop = v1 + +glb _ _ = AbsBot -- Be pessimistic + + + +combineCaseValues + :: AnalysisKind + -> AbsVal -- Value of scrutinee + -> [AbsVal] -- Value of branches (at least one) + -> AbsVal -- Result + +-- For strictness analysis, see if the scrutinee is bottom; if so +-- return bottom; otherwise, the lub of the branches. + +combineCaseValues StrAnal AbsBot branches = AbsBot +combineCaseValues StrAnal other_scrutinee branches + -- Scrutinee can only be AbsBot, AbsProd or AbsTop + = ASSERT(ok_scrutinee) + foldr1 lub branches + where + ok_scrutinee + = case other_scrutinee of { + AbsTop -> True; -- i.e., cool + AbsProd _ -> True; -- ditto + _ -> False -- party over + } + +-- For absence analysis, check if the scrutinee is all poison (isBot) +-- If so, return poison (AbsBot); otherwise, any nested poison will come +-- out from looking at the branches, so just glb together the branches +-- to get the worst one. + +combineCaseValues AbsAnal AbsBot branches = AbsBot +combineCaseValues AbsAnal other_scrutinee branches + -- Scrutinee can only be AbsBot, AbsProd or AbsTop + = ASSERT(ok_scrutinee) + let + result = foldr1 glb branches + + tracer = if at_least_one_AbsFun && at_least_one_AbsTop + && no_AbsBots then + pprTrace "combineCase:" (ppr PprDebug branches) + else + id + in +-- tracer ( + result +-- ) + where + ok_scrutinee + = case other_scrutinee of { + AbsTop -> True; -- i.e., cool + AbsProd _ -> True; -- ditto + _ -> False -- party over + } + + at_least_one_AbsFun = foldr ((||) . is_AbsFun) False branches + at_least_one_AbsTop = foldr ((||) . is_AbsTop) False branches + no_AbsBots = foldr ((&&) . is_not_AbsBot) True branches + + is_AbsFun x = case x of { AbsFun _ _ _ -> True; _ -> False } + is_AbsTop x = case x of { AbsTop -> True; _ -> False } + is_not_AbsBot x = case x of { AbsBot -> False; _ -> True } +\end{code} + +@isBot@ returns True if its argument is (a representation of) bottom. The +``representation'' part is because we need to detect the bottom {\em function} +too. To detect the bottom function, bind its args to top, and see if it +returns bottom. + +Used only in strictness analysis: +\begin{code} +isBot :: AbsVal -> Bool + +isBot AbsBot = True +isBot (AbsFun args body env) = isBot (absEval StrAnal body env) + -- Don't bother to extend the envt because + -- unbound variables default to AbsTop anyway +isBot other = False +\end{code} + +Used only in absence analysis: +\begin{code} +anyBot :: AbsVal -> Bool + +anyBot AbsBot = True -- poisoned! +anyBot AbsTop = False +anyBot (AbsProd vals) = any anyBot vals +anyBot (AbsFun args body env) = anyBot (absEval AbsAnal body env) +anyBot (AbsApproxFun demands) = False + + -- AbsApproxFun can only arise in absence analysis from the Demand + -- info of an imported value; whatever it is we're looking for is + -- certainly not present over in the imported value. +\end{code} + +@widen@ takes an @AbsVal@, $val$, and returns and @AbsVal@ which is +approximated by $val$. Furthermore, the result has no @AbsFun@s in +it, so it can be compared for equality by @sameVal@. + +\begin{code} +widen :: AnalysisKind -> AbsVal -> AbsVal + +widen StrAnal (AbsFun args body env) + | isBot (absEval StrAnal body env) = AbsBot + | otherwise + = ASSERT (not (null args)) + AbsApproxFun (map (findDemandStrOnly env body) args) + + -- It's worth checking for a function which is unconditionally + -- bottom. Consider + -- + -- f x y = let g y = case x of ... + -- in (g ..) + (g ..) + -- + -- Here, when we are considering strictness of f in x, we'll + -- evaluate the body of f with x bound to bottom. The current + -- strategy is to bind g to its *widened* value; without the isBot + -- (...) test above, we'd bind g to an AbsApproxFun, and deliver + -- Top, not Bot as the value of f's rhs. The test spots the + -- unconditional bottom-ness of g when x is bottom. (Another + -- alternative here would be to bind g to its exact abstract + -- value, but that entails lots of potential re-computation, at + -- every application of g.) + +widen StrAnal (AbsProd vals) = AbsProd (map (widen StrAnal) vals) +widen StrAnal other_val = other_val + + +widen AbsAnal (AbsFun args body env) + | anyBot (absEval AbsAnal body env) = AbsBot + -- In the absence-analysis case it's *essential* to check + -- that the function has no poison in its body. If it does, + -- anywhere, then the whole function is poisonous. + + | otherwise + = ASSERT (not (null args)) + AbsApproxFun (map (findDemandAbsOnly env body) args) + +widen AbsAnal (AbsProd vals) = AbsProd (map (widen AbsAnal) vals) + + -- It's desirable to do a good job of widening for product + -- values. Consider + -- + -- let p = (x,y) + -- in ...(case p of (x,y) -> x)... + -- + -- Now, is y absent in this expression? Currently the + -- analyser widens p before looking at p's scope, to avoid + -- lots of recomputation in the case where p is a function. + -- So if widening doesn't have a case for products, we'll + -- widen p to AbsBot (since when searching for absence in y we + -- bind y to poison ie AbsBot), and now we are lost. + +widen AbsAnal other_val = other_val + +-- OLD if anyBot val then AbsBot else AbsTop +-- Nowadays widen is doing a better job on functions for absence analysis. +\end{code} + +@crudeAbsWiden@ is used just for absence analysis, and always +returns AbsTop or AbsBot, so it widens to a two-point domain + +\begin{code} +crudeAbsWiden :: AbsVal -> AbsVal +crudeAbsWiden val = if anyBot val then AbsBot else AbsTop +\end{code} + +@sameVal@ compares two abstract values for equality. It can't deal with +@AbsFun@, but that should have been removed earlier in the day by @widen@. + +\begin{code} +sameVal :: AbsVal -> AbsVal -> Bool -- Can't handle AbsFun! + +#ifdef DEBUG +sameVal (AbsFun _ _ _) _ = panic "sameVal: AbsFun: arg1" +sameVal _ (AbsFun _ _ _) = panic "sameVal: AbsFun: arg2" +#endif + +sameVal AbsBot AbsBot = True +sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot + +sameVal AbsTop AbsTop = True +sameVal AbsTop other = False -- Right? + +sameVal (AbsProd vals1) (AbsProd vals2) = ASSERT (length vals1 == length vals2) + and (zipWith sameVal vals1 vals2) +sameVal (AbsProd _) AbsTop = False +sameVal (AbsProd _) AbsBot = False + +sameVal (AbsApproxFun str1) (AbsApproxFun str2) = str1 == str2 +sameVal (AbsApproxFun _) AbsTop = False +sameVal (AbsApproxFun _) AbsBot = False + +sameVal val1 val2 = panic "sameVal: type mismatch or AbsFun encountered" +\end{code} + + +@evalStrictness@ compares a @Demand@ with an abstract value, returning +@True@ iff the abstract value is {\em less defined} than the demand. +(@True@ is the exciting answer; @False@ is always safe.) + +\begin{code} +evalStrictness :: Demand + -> AbsVal + -> Bool -- True iff the value is sure + -- to be less defined than the Demand + +evalStrictness (WwLazy _) _ = False +evalStrictness WwStrict val = isBot val +evalStrictness WwEnum val = isBot val + +evalStrictness (WwUnpack demand_info) val + = case val of + AbsTop -> False + AbsBot -> True + AbsProd vals -> ASSERT (length vals == length demand_info) + or (zipWith evalStrictness demand_info vals) + _ -> trace "evalStrictness?" False + +evalStrictness WwPrim val + = case val of + AbsTop -> False + + other -> -- A primitive value should be defined, never bottom; + -- hence this paranoia check + pprPanic "evalStrictness: WwPrim:" (ppr PprDebug other) +\end{code} + +For absence analysis, we're interested in whether "poison" in the +argument (ie a bottom therein) can propagate to the result of the +function call; that is, whether the specified demand can {\em +possibly} hit poison. + +\begin{code} +evalAbsence (WwLazy True) _ = False -- Can't possibly hit poison + -- with Absent demand + +evalAbsence (WwUnpack demand_info) val + = case val of + AbsTop -> False -- No poison in here + AbsBot -> True -- Pure poison + AbsProd vals -> ASSERT (length demand_info == length vals) + or (zipWith evalAbsence demand_info vals) + _ -> panic "evalAbsence: other" + +evalAbsence other val = anyBot val + -- The demand is conservative; even "Lazy" *might* evaluate the + -- argument arbitrarily so we have to look everywhere for poison +\end{code} + +%************************************************************************ +%* * +\subsection[absEval]{Evaluate an expression in the abstract domain} +%* * +%************************************************************************ + +\begin{code} +-- The isBottomingId stuf is now dealt with via the Id's strictness info +-- absId anal var env | isBottomingId var +-- = case anal of +-- StrAnal -> AbsBot -- See discussion below +-- AbsAnal -> AbsTop -- Just want to see if there's any poison in + -- error's arg + +absId anal var env + = let + result = + case (lookupAbsValEnv env var, getIdStrictness var, getIdUnfolding var) of + + (Just abs_val, _, _) -> + abs_val -- Bound in the environment + + (Nothing, NoStrictnessInfo, LiteralForm _) -> + AbsTop -- Literals all terminate, and have no poison + + (Nothing, NoStrictnessInfo, ConstructorForm _ _ _) -> + AbsTop -- An imported constructor won't have + -- bottom components, nor poison! + + (Nothing, NoStrictnessInfo, GeneralForm _ _ unfolding _) -> + -- We have an unfolding for the expr + -- Assume the unfolding has no free variables since it + -- came from inside the Id + absEval anal (unTagBinders unfolding) env + -- Notice here that we only look in the unfolding if we don't + -- have strictness info (an unusual situation). + -- We could have chosen to look in the unfolding if it exists, + -- and only try the strictness info if it doesn't, and that would + -- give more accurate results, at the cost of re-abstract-interpreting + -- the unfolding every time. + -- We found only one place where the look-at-unfolding-first + -- method gave better results, which is in the definition of + -- showInt in the Prelude. In its defintion, fromIntegral is + -- not inlined (it's big) but ab-interp-ing its unfolding gave + -- a better result than looking at its strictness only. + -- showInt :: Integral a => a -> [Char] -> [Char] + -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_ + -- "U(U(U(U(SA)AAAAAAAAL)AA)AAAAASAAASA)" {...} _N_ _N_ #-} + -- --- 42,44 ---- + -- showInt :: Integral a => a -> [Char] -> [Char] + -- ! {-# GHC_PRAGMA _A_ 1 _U_ 122 _S_ + -- "U(U(U(U(SL)LLLLLLLLL)LL)LLLLLSLLLLL)" _N_ _N_ #-} + + + (Nothing, strictness_info, _) -> + -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails + -- Try the strictness info + absValFromStrictness anal strictness_info + + + -- Done via strictness now + -- GeneralForm _ BottomForm _ _ -> AbsBot + in + -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) ( + result + -- ) + where + pp_anal StrAnal = ppStr "STR" + pp_anal AbsAnal = ppStr "ABS" + +absEvalAtom anal (CoVarAtom v) env = absId anal v env +absEvalAtom anal (CoLitAtom _) env = AbsTop +\end{code} + +\begin{code} +absEval :: AnalysisKind -> PlainCoreExpr -> AbsValEnv -> AbsVal + +absEval anal (CoVar var) env = absId anal var env + +absEval anal (CoLit _) env = AbsTop + -- What if an unboxed literal? That's OK: it terminates, so its + -- abstract value is AbsTop. + + -- For absence analysis, a literal certainly isn't the "poison" variable +\end{code} + +Discussion about \tr{error} (following/quoting Lennart): Any expression +\tr{error e} is regarded as bottom (with HBC, with the +\tr{-ffail-strict} flag, on with \tr{-O}). + +Regarding it as bottom gives much better strictness properties for +some functions. E.g. +\begin{verbatim} + f [x] y = x+y + f (x:xs) y = f xs (x+y) +i.e. + f [] _ = error "no match" + f [x] y = x+y + f (x:xs) y = f xs (x+y) +\end{verbatim} +is strict in \tr{y}, which you really want. But, it may lead to +transformations that turn a call to \tr{error} into non-termination. +(The odds of this happening aren't good.) + + +Things are a little different for absence analysis, because we want +to make sure that any poison (?????) + +\begin{code} +absEval StrAnal (CoPrim SeqOp [t] [e]) env + = if isBot (absEvalAtom StrAnal e env) then AbsBot else AbsTop + -- This is a special case to ensure that seq# is strict in its argument. + -- The comments below (for most normal PrimOps) do not apply. + +absEval StrAnal (CoPrim op ts es) env = AbsTop + -- 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. + + -- Actually, I believe we are saying that either (1) the + -- primOp uses unboxed args and they've been eval'ed, so + -- there's no need to force strictness here, _or_ the primOp + -- uses boxed args and we don't know whether or not it's + -- strict, so we assume laziness. (JSM) + +absEval AbsAnal (CoPrim op ts as) env + = if any anyBot [absEvalAtom AbsAnal a env | a <- as] + then AbsBot + else AbsTop + -- For absence analysis, we want to see if the poison shows up... + +absEval anal (CoCon con ts as) env + | has_single_con + = AbsProd [absEvalAtom anal a env | a <- as] + + | otherwise -- Not single-constructor + = case anal of + StrAnal -> -- Strictness case: it's easy: it certainly terminates + AbsTop + AbsAnal -> -- In the absence case we need to be more + -- careful: look to see if there's any + -- poison in the components + if any anyBot [absEvalAtom AbsAnal a env | a <- as] + then AbsBot + else AbsTop + where + (_,_,_, tycon) = getDataConSig con + has_single_con = maybeToBool (maybeSingleConstructorTyCon tycon) +\end{code} + +\begin{code} +absEval anal (CoLam [] body) env = absEval anal body env -- paranoia +absEval anal (CoLam binders body) env = AbsFun binders body env +absEval anal (CoTyLam ty expr) env = absEval anal expr env +absEval anal (CoApp e1 e2) env = absApply anal (absEval anal e1 env) + (absEvalAtom anal e2 env) +absEval anal (CoTyApp expr ty) env = absEval anal expr env +\end{code} + +For primitive cases, just GLB the branches, then LUB with the expr part. + +\begin{code} +absEval anal (CoCase expr (CoPrimAlts alts deflt)) env + = let + expr_val = absEval anal expr env + abs_alts = [ absEval anal rhs env | (_, rhs) <- alts ] + -- Don't bother to extend envt, because unbound vars + -- default to the conservative AbsTop + + abs_deflt = absEvalDefault anal expr_val deflt env + in + combineCaseValues anal expr_val + (abs_deflt ++ abs_alts) + +absEval anal (CoCase expr (CoAlgAlts alts deflt)) env + = let + expr_val = absEval anal expr env + abs_alts = [ absEvalAlgAlt anal expr_val alt env | alt <- alts ] + abs_deflt = absEvalDefault anal expr_val deflt env + in + let + result = + combineCaseValues anal expr_val + (abs_deflt ++ abs_alts) + in +{- + (case anal of + StrAnal -> id + _ -> pprTrace "absCase:ABS:" (ppAbove (ppCat [ppr PprDebug expr, ppr PprDebug result, ppr PprDebug expr_val, ppr PprDebug abs_deflt, ppr PprDebug abs_alts]) (ppr PprDebug (keysFM env `zip` eltsFM env))) + ) +-} + result +\end{code} + +For @CoLets@ we widen the value we get. This is nothing to +do with fixpointing. The reason is so that we don't get an explosion +in the amount of computation. For example, consider: +\begin{verbatim} + let + g a = case a of + q1 -> ... + q2 -> ... + f x = case x of + p1 -> ...g r... + p2 -> ...g s... + in + f e +\end{verbatim} +If we bind @f@ and @g@ to their exact abstract value, then we'll +``execute'' one call to @f@ and {\em two} calls to @g@. This can blow +up exponentially. Widening cuts it off by making a fixed +approximation to @f@ and @g@, so that the bodies of @f@ and @g@ are +not evaluated again at all when they are called. + +Of course, this can lose useful joint strictness, which is sad. An +alternative approach would be to try with a certain amount of ``fuel'' +and be prepared to bale out. + +\begin{code} +absEval anal (CoLet (CoNonRec binder e1) e2) env + = let + new_env = addOneToAbsValEnv env binder (widen anal (absEval anal e1 env)) + in + -- The binder of a CoNonRec should *not* be of unboxed type, + -- hence no need to strictly evaluate the Rhs. + absEval anal e2 new_env + +absEval anal (CoLet (CoRec pairs) body) env + = let + (binders,rhss) = unzip pairs + rhs_vals = cheapFixpoint anal binders rhss env -- Returns widened values + new_env = growAbsValEnvList env (binders `zip` rhs_vals) + in + absEval anal body new_env +\end{code} + +\begin{code} +absEval anal (CoSCC cc expr) env = absEval anal expr env + +-- ToDo: add DPH stuff here +\end{code} + +\begin{code} +absEvalAlgAlt :: AnalysisKind -> AbsVal -> (Id,[Id],PlainCoreExpr) -> AbsValEnv -> AbsVal + +absEvalAlgAlt anal (AbsProd arg_vals) (con, args, rhs) env + = -- The scrutinee is a product value, so it must be of a single-constr + -- type; so the constructor in this alternative must be the right one + -- so we can go ahead and bind the constructor args to the components + -- of the product value. + ASSERT(length arg_vals == length args) + let + new_env = growAbsValEnvList env (args `zip` arg_vals) + in + absEval anal rhs new_env + +absEvalAlgAlt anal other_scrutinee (con, args, rhs) env + = -- Scrutinised value is Top or Bot (it can't be a function!) + -- So just evaluate the rhs with all constr args bound to Top. + -- (If the scrutinee is Top we'll never evaluated this function + -- call anyway!) + ASSERT(ok_scrutinee) + absEval anal rhs env + where + ok_scrutinee + = case other_scrutinee of { + AbsTop -> True; -- i.e., OK + AbsBot -> True; -- ditto + _ -> False -- party over + } + + +absEvalDefault :: AnalysisKind + -> AbsVal -- Value of scrutinee + -> PlainCoreCaseDefault + -> AbsValEnv + -> [AbsVal] -- Empty or singleton + +absEvalDefault anal scrut_val CoNoDefault env = [] +absEvalDefault anal scrut_val (CoBindDefault binder expr) env + = [absEval anal expr (addOneToAbsValEnv env binder scrut_val)] +\end{code} + +%************************************************************************ +%* * +\subsection[absApply]{Apply an abstract function to an abstract argument} +%* * +%************************************************************************ + +Easy ones first: + +\begin{code} +absApply :: AnalysisKind -> AbsVal -> AbsVal -> AbsVal + +absApply anal AbsBot arg = AbsBot + -- AbsBot represents the abstract bottom *function* too + +absApply StrAnal AbsTop arg = AbsTop +absApply AbsAnal AbsTop arg = if anyBot arg + then AbsBot + else AbsTop + -- To be conservative, we have to assume that a function about + -- which we know nothing (AbsTop) might look at some part of + -- its argument +\end{code} + +An @AbsFun@ with only one more argument needed---bind it and eval the +result. A @CoLam@ with two or more args: return another @AbsFun@ with +an augmented environment. + +\begin{code} +absApply anal (AbsFun [binder] body env) arg + = absEval anal body (addOneToAbsValEnv env binder arg) + +absApply anal (AbsFun (binder:bs) body env) arg + = AbsFun bs body (addOneToAbsValEnv env binder arg) +\end{code} + +\begin{code} +absApply StrAnal (AbsApproxFun (arg1_demand:ds)) arg + = if evalStrictness arg1_demand arg + then AbsBot + else case ds of + [] -> AbsTop + other -> AbsApproxFun ds + +absApply AbsAnal (AbsApproxFun (arg1_demand:ds)) arg + = if evalAbsence arg1_demand arg + then AbsBot + else case ds of + [] -> AbsTop + other -> AbsApproxFun ds + +#ifdef DEBUG +absApply anal (AbsApproxFun []) arg = panic ("absApply: Duff function: AbsApproxFun." ++ show anal) +absApply anal (AbsFun [] _ _) arg = panic ("absApply: Duff function: AbsFun." ++ show anal) +absApply anal (AbsProd _) arg = panic ("absApply: Duff function: AbsProd." ++ show anal) +#endif +\end{code} + + + + +%************************************************************************ +%* * +\subsection[findStrictness]{Determine some binders' strictness} +%* * +%************************************************************************ + +@findStrictness@ applies the function \tr{\ ids -> expr} to +\tr{[bot,top,top,...]}, \tr{[top,bot,top,top,...]}, etc., (i.e., once +with @AbsBot@ in each argument position), and evaluates the resulting +abstract value; it returns a vector of @Demand@s saying whether the +result of doing this is guaranteed to be bottom. This tells the +strictness of the function in each of the arguments. + +If an argument is of unboxed type, then we declare that function to be +strict in that argument. + +We don't really have to make up all those lists of mostly-@AbsTops@; +unbound variables in an @AbsValEnv@ are implicitly mapped to that. + +See notes on @addStrictnessInfoToId@. + +\begin{code} +findStrictness :: [UniType] -- Types of args in which strictness is wanted + -> AbsVal -- Abstract strictness value of function + -> AbsVal -- Abstract absence value of function + -> [Demand] -- Resulting strictness annotation + +findStrictness [] str_val abs_val = [] + +findStrictness (ty:tys) str_val abs_val + = let + demand = findRecDemand [] str_fn abs_fn ty + str_fn val = absApply StrAnal str_val val + abs_fn val = absApply AbsAnal abs_val val + + demands = findStrictness tys (absApply StrAnal str_val AbsTop) + (absApply AbsAnal abs_val AbsTop) + in + -- pprTrace "findRecDemand:" (ppCat [ppr PprDebug demand, ppr PprDebug ty]) ( + demand : demands + -- ) +\end{code} + + +\begin{code} +findDemandStrOnly str_env expr binder -- Only strictness environment available + = findRecDemand [] str_fn abs_fn (getIdUniType binder) + where + str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val) + abs_fn val = AbsBot -- Always says poison; so it looks as if + -- nothing is absent; safe + + +findDemandAbsOnly abs_env expr binder -- Only absence environment available + = findRecDemand [] str_fn abs_fn (getIdUniType binder) + where + str_fn val = AbsBot -- Always says non-termination; + -- that'll make findRecDemand peer into the + -- structure of the value. + abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val) + + +findDemand str_env abs_env expr binder + = findRecDemand [] str_fn abs_fn (getIdUniType binder) + where + str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val) + abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val) +\end{code} + +@findRecDemand@ is where we finally convert strictness/absence info +into ``Demands'' which we can pin on Ids (etc.). + +NOTE: What do we do if something is {\em both} strict and absent? +Should \tr{f x y z = error "foo"} says that \tr{f}'s arguments are all +strict (because of bottoming effect of \tr{error}) or all absent +(because they're not used)? + +Well, for practical reasons, we prefer absence over strictness. In +particular, it makes the ``default defaults'' for class methods (the +ones that say \tr{defm.foo dict = error "I don't exist"}) come out +nicely [saying ``the dict isn't used''], rather than saying it is +strict in every component of the dictionary [massive gratuitious +casing to take the dict apart]. + +But you could have examples where going for strictness would be better +than absence. Consider: +\begin{verbatim} + let x = something big + in + f x y z + g x +\end{verbatim} + +If \tr{x} is marked absent in \tr{f}, but not strict, and \tr{g} is +lazy, then the thunk for \tr{x} will be built. If \tr{f} was strict, +then we'd let-to-case it: +\begin{verbatim} + case something big of + x -> f x y z + g x +\end{verbatim} +Ho hum. + +\begin{code} +findRecDemand :: [TyCon] -- TyCons already seen; used to avoid + -- zooming into recursive types + -> (AbsVal -> AbsVal) -- The strictness function + -> (AbsVal -> AbsVal) -- The absence function + -> UniType -- The type of the argument + -> Demand + +findRecDemand seen str_fn abs_fn ty + = if isPrimType ty then -- It's a primitive type! + wwPrim + + else if not (anyBot (abs_fn AbsBot)) then -- It's absent + -- We prefer absence over strictness: see NOTE above. + WwLazy True + + else if not (isBot (str_fn AbsBot)) then -- It's not strict + WwLazy False + + else -- It's strict! + + case getUniDataTyCon_maybe ty of + + Nothing -> wwStrict + + Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen -> + -- Single constructor case, tycon not already seen higher up + let + (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys + prod_len = length cmpnt_tys + + compt_strict_infos + = [ findRecDemand (tycon:seen) + (\ cmpnt_val -> + str_fn (mkMainlyTopProd prod_len i cmpnt_val) + ) + (\ cmpnt_val -> + abs_fn (mkMainlyTopProd prod_len i cmpnt_val) + ) + cmpnt_ty + | (cmpnt_ty, i) <- cmpnt_tys `zip` [1..] ] + in + if null compt_strict_infos then + if isEnumerationTyCon tycon then wwEnum else wwStrict + else + wwUnpack compt_strict_infos + where + not_elem = isn'tIn "findRecDemand" + + Just (tycon,_,_) -> + -- Multi-constr data types, *or* an abstract data + -- types, *or* things we don't have a way of conveying + -- the info over module boundaries (class ops, + -- superdict sels, dfns). + if isEnumerationTyCon tycon then + wwEnum + else + wwStrict + where + -- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of + -- them) except for a given value in the "i"th position. + + mkMainlyTopProd :: Int -> Int -> AbsVal -> AbsVal + + mkMainlyTopProd n i val + = let + befores = nOfThem (i-1) AbsTop + afters = nOfThem (n-i) AbsTop + in + AbsProd (befores ++ (val : afters)) +\end{code} + +%************************************************************************ +%* * +\subsection[fixpoint]{Fixpointer for the strictness analyser} +%* * +%************************************************************************ + +The @fixpoint@ functions take a list of \tr{(binder, expr)} pairs, an +environment, and returns the abstract value of each binder. + +The @cheapFixpoint@ function makes a conservative approximation, +by binding each of the variables to Top in their own right hand sides. +That allows us to make rapid progress, at the cost of a less-than-wonderful +approximation. + +\begin{code} +cheapFixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal] + +cheapFixpoint AbsAnal [id] [rhs] env + = [crudeAbsWiden (absEval AbsAnal rhs new_env)] + where + new_env = addOneToAbsValEnv env id AbsTop -- Unsafe starting point! + -- In the just-one-binding case, we guarantee to + -- find a fixed point in just one iteration, + -- because we are using only a two-point domain. + -- This improves matters in cases like: + -- + -- f x y = letrec g = ...g... + -- in g x + -- + -- Here, y isn't used at all, but if g is bound to + -- AbsBot we simply get AbsBot as the next + -- iteration too. + +cheapFixpoint anal ids rhss env + = [widen anal (absEval anal rhs new_env) | rhs <- rhss] + -- We do just one iteration, starting from a safe + -- approximation. This won't do a good job in situations + -- like: + -- \x -> letrec f = ...g... + -- g = ...f...x... + -- in + -- ...f... + -- Here, f will end up bound to Top after one iteration, + -- and hence we won't spot the strictness in x. + -- (A second iteration would solve this. ToDo: try the effect of + -- really searching for a fixed point.) + where + new_env = growAbsValEnvList env [(id,safe_val) | id <- ids] + + safe_val + = case anal of -- The safe starting point + StrAnal -> AbsTop + AbsAnal -> AbsBot +\end{code} + +\begin{verbatim} +mkLookupFun :: (key -> key -> Bool) -- Equality predicate + -> (key -> key -> Bool) -- Less-than predicate + -> [(key,val)] -- The assoc list + -> key -- The key + -> Maybe val -- The corresponding value + +mkLookupFun eq lt alist s + = case [a | (s',a) <- alist, s' `eq` s] of + [] -> Nothing + (a:_) -> Just a +\end{verbatim} + +\begin{code} +fixpoint :: AnalysisKind -> [Id] -> [PlainCoreExpr] -> AbsValEnv -> [AbsVal] + +fixpoint anal [] _ env = [] + +fixpoint anal ids rhss env + = fix_loop initial_vals + where + initial_val id + = case anal of -- The (unsafe) starting point + StrAnal -> if (returnsRealWorld (getIdUniType id)) + then AbsTop -- this is a massively horrible hack (SLPJ 95/05) + else AbsBot + AbsAnal -> AbsTop + + initial_vals = [ initial_val id | id <- ids ] + + fix_loop :: [AbsVal] -> [AbsVal] + + fix_loop current_widened_vals + = let + new_env = growAbsValEnvList env (ids `zip` current_widened_vals) + new_vals = [ absEval anal rhs new_env | rhs <- rhss ] + new_widened_vals = map (widen anal) new_vals + in + if (and (zipWith sameVal current_widened_vals new_widened_vals)) then + current_widened_vals + + -- Return the widened values. We might get a slightly + -- better value by returning new_vals (which we used to + -- do, see below), but alas that means that whenever the + -- function is called we have to re-execute it, which is + -- expensive. + + -- OLD VERSION + -- new_vals + -- Return the un-widened values which may be a bit better + -- than the widened ones, and are guaranteed safe, since + -- they are one iteration beyond current_widened_vals, + -- which itself is a fixed point. + else + fix_loop new_widened_vals +\end{code} + +For absence analysis, we make do with a very very simple approach: +look for convergence in a two-point domain. + +We used to use just one iteration, starting with the variables bound +to @AbsBot@, which is safe. + +Prior to that, we used one iteration starting from @AbsTop@ (which +isn't safe). Why isn't @AbsTop@ safe? Consider: +\begin{verbatim} + letrec + x = ...p..d... + d = (x,y) + in + ... +\end{verbatim} +Here, if p is @AbsBot@, then we'd better {\em not} end up with a ``fixed +point'' of @d@ being @(AbsTop, AbsTop)@! An @AbsBot@ initial value is +safe because it gives poison more often than really necessary, and +thus may miss some absence, but will never claim absence when it ain't +so. + +Anyway, one iteration starting with everything bound to @AbsBot@ give +bad results for + + f = \ x -> ...f... + +Here, f would always end up bound to @AbsBot@, which ain't very +clever, because then it would introduce poison whenever it was +applied. Much better to start with f bound to @AbsTop@, and widen it +to @AbsBot@ if any poison shows up. In effect we look for convergence +in the two-point @AbsTop@/@AbsBot@ domain. + +What we miss (compared with the cleverer strictness analysis) is +spotting that in this case + + f = \ x y -> ...y...(f x y')... + +\tr{x} is actually absent, since it is only passed round the loop, never +used. But who cares about missing that? + +NB: despite only having a two-point domain, we may still have many +iterations, because there are several variables involved at once. diff --git a/ghc/compiler/stranal/SaLib.hi b/ghc/compiler/stranal/SaLib.hi new file mode 100644 index 0000000..a8fab1a --- /dev/null +++ b/ghc/compiler/stranal/SaLib.hi @@ -0,0 +1,48 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface SaLib where +import BasicLit(BasicLit) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(Demand, IdInfo, StrictnessInfo) +import Maybes(Labda) +import Outputable(Outputable) +import PlainCore(PlainCoreExpr(..)) +import PrimOps(PrimOp) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data AbsVal = AbsTop | AbsBot | AbsProd [AbsVal] | AbsFun [Id] (CoreExpr Id Id) AbsValEnv | AbsApproxFun [Demand] +data AbsValEnv {-# GHC_PRAGMA AbsValEnv Bool (UniqFM AbsVal) #-} +type AbsenceEnv = AbsValEnv +data AnalysisKind = StrAnal | AbsAnal +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +type PlainCoreExpr = CoreExpr Id Id +type StrictEnv = AbsValEnv +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-} +addOneToAbsValEnv :: AbsValEnv -> Id -> AbsVal -> AbsValEnv + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(LL)LL" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +growAbsValEnvList :: AbsValEnv -> [(Id, AbsVal)] -> AbsValEnv + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupAbsValEnv :: AbsValEnv -> Id -> Labda AbsVal + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(EL)L" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _N_ #-} +nullAbsValEnv :: Bool -> AbsValEnv + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +instance Outputable AbsVal + {-# GHC_PRAGMA _M_ SaLib {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +instance Text AnalysisKind + {-# GHC_PRAGMA _M_ SaLib {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(AnalysisKind, [Char])]), (Int -> AnalysisKind -> [Char] -> [Char]), ([Char] -> [([AnalysisKind], [Char])]), ([AnalysisKind] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (AnalysisKind), _CONSTM_ Text showsPrec (AnalysisKind), _CONSTM_ Text readList (AnalysisKind), _CONSTM_ Text showList (AnalysisKind)] _N_ + readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(AnalysisKind, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_, + showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs new file mode 100644 index 0000000..873bfbe --- /dev/null +++ b/ghc/compiler/stranal/SaLib.lhs @@ -0,0 +1,122 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[SaLib]{Basic datatypes, functions for the strictness analyser} + +See also: the ``library'' for the ``back end'' (@SaBackLib@). + +\begin{code} +#include "HsVersions.h" + +module SaLib ( + AbsVal(..), + AnalysisKind(..), + AbsValEnv{-abstract-}, StrictEnv(..), AbsenceEnv(..), + nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList, + lookupAbsValEnv, + absValFromStrictness, + + -- and to make the interface self-sufficient... + CoreExpr, Id, IdEnv(..), UniqFM, Unique, + Demand, PlainCoreExpr(..) + ) where + +import IdEnv +import IdInfo +--import FiniteMap -- debugging only +import Outputable +import PlainCore +import Pretty +import Util -- for pragmas only +\end{code} + +%************************************************************************ +%* * +\subsection[AbsVal-datatype]{@AbsVal@: abstract values (and @AbsValEnv@)} +%* * +%************************************************************************ + +@AnalysisKind@ tells what kind of analysis is being done. + +\begin{code} +data AnalysisKind + = StrAnal -- We're doing strictness analysis + | AbsAnal -- We're doing absence analysis + deriving Text +\end{code} + +@AbsVal@ is the data type of HNF abstract values. + +\begin{code} +data AbsVal + = AbsTop -- AbsTop is the completely uninformative + -- value + + | AbsBot -- An expression whose abstract value is + -- AbsBot is sure to fail to terminate. + -- AbsBot represents the abstract + -- *function* bottom too. + + | AbsProd [AbsVal] -- (Lifted) product of abstract values + -- "Lifted" means that AbsBot is *different* from + -- AbsProd [AbsBot, ..., AbsBot] + + | AbsFun -- An abstract function, with the given: + [Id] -- arguments + PlainCoreExpr -- body + AbsValEnv -- and environment + + | AbsApproxFun -- This is used to represent a coarse + [Demand] -- approximation to a function value. It's an + -- abstract function which is strict in its i'th + -- argument if the i'th element of the Demand + -- list so indicates. + -- The list of arguments is always non-empty. + -- In effect, AbsApproxFun [] = AbsTop + +instance Outputable AbsVal where + ppr sty AbsTop = ppStr "AbsTop" + ppr sty AbsBot = ppStr "AbsBot" + ppr sty (AbsProd prod) = ppCat [ppStr "AbsProd", ppr sty prod] + ppr sty (AbsFun args body env) + = ppCat [ppStr "AbsFun{", ppr sty args, + ppStr "???", -- ppStr "}{env:", ppr sty (keysFM env `zip` eltsFM env), + ppStr "}" ] + ppr sty (AbsApproxFun demands) + = ppCat [ppStr "AbsApprox{", ppr sty demands, ppStr "}" ] +\end{code} + +%----------- + +An @AbsValEnv@ maps @Ids@ to @AbsVals@. Any unbound @Ids@ are +implicitly bound to @AbsTop@, the completely uninformative, +pessimistic value---see @absEval@ of a @CoVar@. + +\begin{code} +data AbsValEnv = AbsValEnv StrAnalFlags (IdEnv AbsVal) +type StrAnalFlags = Bool -- True <=> make everything strict + +type StrictEnv = AbsValEnv -- Environment for strictness analysis +type AbsenceEnv = AbsValEnv -- Environment for absence analysis + +nullAbsValEnv x = AbsValEnv x nullIdEnv +addOneToAbsValEnv (AbsValEnv x idenv) y z = AbsValEnv x (addOneToIdEnv idenv y z) +growAbsValEnvList (AbsValEnv x idenv) ys = AbsValEnv x (growIdEnvList idenv ys) + +lookupAbsValEnv (AbsValEnv do_all_strict idenv) y + = if do_all_strict + then Just AbsBot + else lookupIdEnv idenv y +\end{code} + +\begin{code} +absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal + +absValFromStrictness anal NoStrictnessInfo = AbsTop + +absValFromStrictness StrAnal BottomGuaranteed = AbsBot -- Guaranteed bottom +absValFromStrictness AbsAnal BottomGuaranteed = AbsTop -- Check for poison in + -- arguments (if any) +absValFromStrictness anal (StrictnessInfo [] _) = AbsTop +absValFromStrictness anal (StrictnessInfo args_info _) = AbsApproxFun args_info +\end{code} diff --git a/ghc/compiler/stranal/StrictAnal.hi b/ghc/compiler/stranal/StrictAnal.hi new file mode 100644 index 0000000..a3304ac --- /dev/null +++ b/ghc/compiler/stranal/StrictAnal.hi @@ -0,0 +1,11 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface StrictAnal where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import Id(Id) +import SplitUniq(SplitUniqSupply) +saTopBinds :: Bool -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +saWwTopBinds :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "LSL" _N_ _N_ #-} + diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs new file mode 100644 index 0000000..d51908a --- /dev/null +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -0,0 +1,502 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[StrictAnal]{``Simple'' Mycroft-style strictness analyser} + +The original version(s) of all strictness-analyser code (except the +Semantique analyser) was written by Andy Gill. + +\begin{code} +#include "HsVersions.h" + +module StrictAnal ( saWwTopBinds, saTopBinds ) where + +IMPORT_Trace +import Outputable +import Pretty + +import CmdLineOpts ( GlobalSwitch(..) ) +import CoreSyn -- ToDo: get pprCoreBinding straight from PlainCore? +import Id ( addIdDemandInfo, isWrapperId, addIdStrictness, + getIdUniType, getIdDemandInfo + IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling + ) +import IdEnv +import IdInfo +import PlainCore +import SaAbsInt +import SaLib +import SplitUniq +import Unique +import Util +import WorkWrap -- "back-end" of strictness analyser +import WwLib ( WwM(..) ) +\end{code} + + +%************************************************************************ +%* * +\subsection[Thoughts]{Random thoughts} +%* * +%************************************************************************ + +A note about worker-wrappering. If we have + + f :: Int -> Int + f = let v = + in \x -> + +and we deduce that f is strict, it is nevertheless NOT safe to worker-wapper to + + f = \x -> case x of Int x# -> fw x# + fw = \x# -> let x = Int x# + in + let v = + in + +because this obviously loses laziness, since now +is done each time. Alas. + +WATCH OUT! This can mean that something is unboxed only to be +boxed again. For example + + g x y = f x + +Here g is strict, and *will* split into worker-wrapper. A call to +g, with the wrapper inlined will then be + + case arg of Int a# -> gw a# + +Now g calls f, which has no wrapper, so it has to box it. + + gw = \a# -> f (Int a#) + +Alas and alack. + + +%************************************************************************ +%* * +\subsection[iface-StrictAnal]{Interface to the outside world} +%* * +%************************************************************************ + +\begin{code} +saWwTopBinds :: SplitUniqSupply + -> (GlobalSwitch -> Bool) + -> [PlainCoreBinding] + -> [PlainCoreBinding] + +saWwTopBinds us switch_chker binds + = let + do_all_strict = switch_chker AllStrict + + -- mark each binder with its strictness +#ifndef OMIT_STRANAL_STATS + (binds_w_strictness, sa_stats) + = sa_top_binds do_all_strict binds nullSaStats +#else + binds_w_strictness + = sa_top_binds do_all_strict binds +#endif + in + -- possibly show what we decided about strictness... + (if switch_chker D_dump_stranal + then pprTrace "Strictness:\n" (ppAboves ( + map (pprCoreBinding PprDebug pprBigCoreBinder pprBigCoreBinder ppr) binds_w_strictness)) + else id + ) + -- possibly show how many things we marked as demanded... + ((if switch_chker D_simplifier_stats +#ifndef OMIT_STRANAL_STATS + then pp_stats sa_stats +#else + then id +#endif + else id + ) + -- create worker/wrappers, and mark binders with their + -- "strictness info" [which encodes their + -- worker/wrapper-ness] + (workersAndWrappers binds_w_strictness us switch_chker)) +#ifndef OMIT_STRANAL_STATS + where + pp_stats (SaStats tlam dlam tc dc tlet dlet) + = pprTrace "Binders marked demanded: " + (ppBesides [ppStr "Lambda vars: ", ppInt IBOX(dlam), ppChar '/', ppInt IBOX(tlam), + ppStr "; Case vars: ", ppInt IBOX(dc), ppChar '/', ppInt IBOX(tc), + ppStr "; Let vars: ", ppInt IBOX(dlet), ppChar '/', ppInt IBOX(tlet) + ]) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[saBinds]{Strictness analysis of bindings} +%* * +%************************************************************************ + +[Some of the documentation about types, etc., in \tr{SaLib} may be +helpful for understanding this module.] + +@saTopBinds@ tags each binder in the program with its @Demand@. +That tells how each binder is {\em used}; if @Strict@, then the binder +is sure to be evaluated to HNF; if @NonStrict@ it may or may not be; +if @Absent@, then it certainly is not used. [DATED; ToDo: update] + +(The above info is actually recorded for posterity in each binder's +IdInfo, notably its @DemandInfo@.) + +We proceed by analysing the bindings top-to-bottom, building up an +environment which maps @Id@s to their abstract values (i.e., an +@AbsValEnv@ maps an @Id@ to its @AbsVal@). + +\begin{code} +saTopBinds :: Bool -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported +sa_top_binds :: Bool -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported + +saTopBinds do_all_strict binds +#ifndef OMIT_STRANAL_STATS + = fst (sa_top_binds do_all_strict binds nullSaStats) +#else + = sa_top_binds do_all_strict binds +#endif + +sa_top_binds do_all_strict binds + = do_it (nullAbsValEnv do_all_strict) (nullAbsValEnv False) binds + where + do_it _ _ [] = returnSa [] + do_it senv aenv (b:bs) + = saTopBind senv aenv b `thenSa` \ (senv2, aenv2, new_b) -> + do_it senv2 aenv2 bs `thenSa` \ new_bs -> + returnSa (new_b : new_bs) +\end{code} + +@saTopBind@ is only used for the top level. We don't add any demand +info to these ids because we can't work it out. In any case, it +doesn't do us any good to know whether top-level binders are sure to +be used; we can't turn top-level @let@s into @case@s. + +\begin{code} +saTopBind :: StrictEnv -> AbsenceEnv + -> PlainCoreBinding + -> SaM (StrictEnv, AbsenceEnv, PlainCoreBinding) + +saTopBind str_env abs_env (CoNonRec binder rhs) + = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + let + str_rhs = absEval StrAnal rhs str_env + abs_rhs = absEval AbsAnal rhs abs_env + + widened_str_rhs = widen StrAnal str_rhs + widened_abs_rhs = widen AbsAnal abs_rhs + -- The widening above is done for efficiency reasons. + -- See notes on CoLet case in SaAbsInt.lhs + + new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs + binder + rhs + + -- Augment environments with a mapping of the + -- binder to its abstract values, computed by absEval + new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs + new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs + in + returnSa (new_str_env, new_abs_env, CoNonRec new_binder new_rhs) + +saTopBind str_env abs_env (CoRec pairs) + = let + (binders,rhss) = unzip pairs + str_rhss = fixpoint StrAnal binders rhss str_env + abs_rhss = fixpoint AbsAnal binders rhss abs_env + -- fixpoint returns widened values + new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss) + new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss) + new_binders = zipWith4 addStrictnessInfoToId str_rhss abs_rhss binders rhss + in + mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + let + new_pairs = new_binders `zip` new_rhss + in + returnSa (new_str_env, new_abs_env, CoRec new_pairs) +\end{code} + +%************************************************************************ +%* * +\subsection[saExpr]{Strictness analysis of an expression} +%* * +%************************************************************************ + +@saExpr@ computes the strictness of an expression within a given +environment. + +\begin{code} +saExpr :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> SaM PlainCoreExpr + +saExpr _ _ e@(CoVar _) = returnSa e +saExpr _ _ e@(CoLit _) = returnSa e +saExpr _ _ e@(CoCon _ _ _) = returnSa e +saExpr _ _ e@(CoPrim _ _ _) = returnSa e + +saExpr str_env abs_env (CoLam args body) + = saExpr str_env abs_env body `thenSa` \ new_body -> + let + new_args = addDemandInfoToIds str_env abs_env body args + in + tickLambdas new_args `thenSa_` -- stats + returnSa (CoLam new_args new_body) + +saExpr str_env abs_env (CoTyLam ty expr) + = saExpr str_env abs_env expr `thenSa` \ new_expr -> + returnSa (CoTyLam ty new_expr) + +saExpr str_env abs_env (CoApp fun arg) + = saExpr str_env abs_env fun `thenSa` \ new_fun -> + returnSa (CoApp new_fun arg) + +saExpr str_env abs_env (CoTyApp expr ty) + = saExpr str_env abs_env expr `thenSa` \ new_expr -> + returnSa (CoTyApp new_expr ty) + +saExpr str_env abs_env (CoSCC cc expr) + = saExpr str_env abs_env expr `thenSa` \ new_expr -> + returnSa (CoSCC cc new_expr) + +saExpr str_env abs_env (CoCase expr (CoAlgAlts alts deflt)) + = saExpr str_env abs_env expr `thenSa` \ new_expr -> + saDefault str_env abs_env deflt `thenSa` \ new_deflt -> + mapSa sa_alt alts `thenSa` \ new_alts -> + returnSa (CoCase new_expr (CoAlgAlts new_alts new_deflt)) + where + sa_alt (con, binders, rhs) + = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + let + new_binders = addDemandInfoToIds str_env abs_env rhs binders + in + tickCases new_binders `thenSa_` -- stats + returnSa (con, new_binders, new_rhs) + +saExpr str_env abs_env (CoCase expr (CoPrimAlts alts deflt)) + = saExpr str_env abs_env expr `thenSa` \ new_expr -> + saDefault str_env abs_env deflt `thenSa` \ new_deflt -> + mapSa sa_alt alts `thenSa` \ new_alts -> + returnSa (CoCase new_expr (CoPrimAlts new_alts new_deflt)) + where + sa_alt (lit, rhs) + = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + returnSa (lit, new_rhs) + +saExpr str_env abs_env (CoLet (CoNonRec binder rhs) body) + = -- Analyse the RHS in the environment at hand + saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + let + -- Bind this binder to the abstract value of the RHS; analyse + -- the body of the `let' in the extended environment. + str_rhs_val = absEval StrAnal rhs str_env + abs_rhs_val = absEval AbsAnal rhs abs_env + + widened_str_rhs = widen StrAnal str_rhs_val + widened_abs_rhs = widen AbsAnal abs_rhs_val + -- The widening above is done for efficiency reasons. + -- See notes on CoLet case in SaAbsInt.lhs + + new_str_env = addOneToAbsValEnv str_env binder widened_str_rhs + new_abs_env = addOneToAbsValEnv abs_env binder widened_abs_rhs + + -- Now determine the strictness of this binder; use that info + -- to record DemandInfo/StrictnessInfo in the binder. + new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs + (addDemandInfoToId str_env abs_env body binder) + rhs + in + tickLet new_binder `thenSa_` -- stats + saExpr new_str_env new_abs_env body `thenSa` \ new_body -> + returnSa (CoLet (CoNonRec new_binder new_rhs) new_body) + +saExpr str_env abs_env (CoLet (CoRec pairs) body) + = let + (binders,rhss) = unzip pairs + str_vals = fixpoint StrAnal binders rhss str_env + abs_vals = fixpoint AbsAnal binders rhss abs_env + -- fixpoint returns widened values + new_str_env = growAbsValEnvList str_env (binders `zip` str_vals) + new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_vals) + in + saExpr new_str_env new_abs_env body `thenSa` \ new_body -> + mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> + let +-- new_binders = addDemandInfoToIds new_str_env new_abs_env body binders +-- DON'T add demand info in a CoRec! +-- a) it's useless: we can't do let-to-case +-- b) it's incorrect. Consider +-- letrec x = ...y... +-- y = ...x... +-- in ...x... +-- When we ask whether y is demanded we'll bind y to bottom and +-- evaluate the body of the letrec. But that will result in our +-- deciding that y is absent, which is plain wrong! +-- It's much easier simply not to do this. + + improved_binders = zipWith4 addStrictnessInfoToId str_vals abs_vals binders rhss + whiter_than_white_binders = launder improved_binders + + new_pairs = whiter_than_white_binders `zip` new_rhss + in + returnSa (CoLet (CoRec new_pairs) new_body) + where + launder me = {-still-} me +\end{code} + +\begin{code} +saDefault str_env abs_env CoNoDefault = returnSa CoNoDefault + +saDefault str_env abs_env (CoBindDefault bdr rhs) + = saExpr str_env abs_env rhs `thenSa` \ new_rhs -> + let + new_bdr = addDemandInfoToId str_env abs_env rhs bdr + in + tickCases [new_bdr] `thenSa_` -- stats + returnSa (CoBindDefault new_bdr new_rhs) +\end{code} + + +%************************************************************************ +%* * +\subsection[computeInfos]{Add computed info to binders} +%* * +%************************************************************************ + +Important note (Sept 93). @addStrictnessInfoToId@ is used only for let(rec) +bound variables, and is use to attach the strictness (not demand) info +to the binder. We are careful to restrict this strictness info to the +lambda-bound arguments which are actually visible, at the top level, +lest we accidentally lose laziness by eagerly looking for an "extra" argument. +So we "dig for lambdas" in a rather syntactic way. + +A better idea might be to have some kind of arity analysis to +tell how many args could safely be grabbed. + +\begin{code} +addStrictnessInfoToId + :: AbsVal -- Abstract strictness value + -> AbsVal -- Ditto absence + -> Id -- The id + -> PlainCoreExpr -- Its RHS + -> Id -- Augmented with strictness + +addStrictnessInfoToId str_val abs_val binder body + = if isWrapperId binder then + binder -- Avoid clobbering existing strictness info + -- (and, more importantly, worker info). + -- Deeply suspicious (SLPJ) + else + if (isBot str_val) then + binder `addIdStrictness` mkBottomStrictnessInfo + else + case (digForLambdas body) of { (_, lambda_bounds, rhs) -> + let + tys = map getIdUniType lambda_bounds + strictness = findStrictness tys str_val abs_val + in + binder `addIdStrictness` mkStrictnessInfo strictness Nothing + } +\end{code} + +\begin{code} +addDemandInfoToId :: StrictEnv -> AbsenceEnv + -> PlainCoreExpr -- The scope of the id + -> Id + -> Id -- Id augmented with Demand info + +addDemandInfoToId str_env abs_env expr binder + = binder `addIdDemandInfo` (mkDemandInfo (findDemand str_env abs_env expr binder)) + +addDemandInfoToIds :: StrictEnv -> AbsenceEnv -> PlainCoreExpr -> [Id] -> [Id] + +addDemandInfoToIds str_env abs_env expr binders + = map (addDemandInfoToId str_env abs_env expr) binders +\end{code} + +%************************************************************************ +%* * +\subsection{Monad used herein for stats} +%* * +%************************************************************************ + +\begin{code} +data SaStats + = SaStats FAST_INT FAST_INT -- total/marked-demanded lambda-bound + FAST_INT FAST_INT -- total/marked-demanded case-bound + FAST_INT FAST_INT -- total/marked-demanded let-bound + -- (excl. top-level; excl. letrecs) + +nullSaStats = SaStats ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) ILIT(0) + +thenSa :: SaM a -> (a -> SaM b) -> SaM b +thenSa_ :: SaM a -> SaM b -> SaM b +returnSa :: a -> SaM a + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenSa #-} +{-# INLINE thenSa_ #-} +{-# INLINE returnSa #-} +#endif + +tickLambdas :: [Id] -> SaM () +tickCases :: [Id] -> SaM () +tickLet :: Id -> SaM () + +#ifndef OMIT_STRANAL_STATS +type SaM a = SaStats -> (a, SaStats) + +thenSa expr cont stats + = case (expr stats) of { (result, stats1) -> + cont result stats1 } + +thenSa_ expr cont stats + = case (expr stats) of { (_, stats1) -> + cont stats1 } + +returnSa x stats = (x, stats) + +tickLambdas vars (SaStats tlam dlam tc dc tlet dlet) + = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) -> + ((), SaStats (tlam _ADD_ tot) (dlam _ADD_ demanded) tc dc tlet dlet) } + +tickCases vars (SaStats tlam dlam tc dc tlet dlet) + = case (foldr tick_demanded (0,0) vars) of { (IBOX(tot), IBOX(demanded)) -> + ((), SaStats tlam dlam (tc _ADD_ tot) (dc _ADD_ demanded) tlet dlet) } + +tickLet var (SaStats tlam dlam tc dc tlet dlet) + = case (tick_demanded var (0,0)) of { (IBOX(tot),IBOX(demanded)) -> + ((), SaStats tlam dlam tc dc (tlet _ADD_ tot) (dlet _ADD_ demanded)) } + +tick_demanded var (tot, demanded) + = (tot + 1, + if (willBeDemanded (getIdDemandInfo var)) + then demanded + 1 + else demanded) + +#else {-OMIT_STRANAL_STATS-} +-- identity monad +type SaM a = a + +thenSa expr cont = cont expr + +thenSa_ expr cont = cont + +returnSa x = x + +tickLambdas vars = panic "OMIT_STRANAL_STATS: tickLambdas" +tickCases vars = panic "OMIT_STRANAL_STATS: tickCases" +tickLet var = panic "OMIT_STRANAL_STATS: tickLet" + +#endif {-OMIT_STRANAL_STATS-} + +mapSa :: (a -> SaM b) -> [a] -> SaM [b] + +mapSa f [] = returnSa [] +mapSa f (x:xs) + = f x `thenSa` \ r -> + mapSa f xs `thenSa` \ rs -> + returnSa (r:rs) +\end{code} diff --git a/ghc/compiler/stranal/WorkWrap.hi b/ghc/compiler/stranal/WorkWrap.hi new file mode 100644 index 0000000..645f9b4 --- /dev/null +++ b/ghc/compiler/stranal/WorkWrap.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface WorkWrap where +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreBinding) +import Id(Id) +import SplitUniq(SplitUniqSupply) +workersAndWrappers :: [CoreBinding Id Id] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id] + {-# GHC_PRAGMA _A_ 1 _U_ 112 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs new file mode 100644 index 0000000..a43cd72 --- /dev/null +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -0,0 +1,254 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser} + +\begin{code} +#include "HsVersions.h" + +module WorkWrap ( workersAndWrappers ) where + +IMPORT_Trace +import Outputable +import Pretty + +import Id ( getIdUniType, addIdStrictness, getIdStrictness, + getIdUnfolding, mkWorkerId, + replaceIdInfo, getIdInfo, idWantsToBeINLINEd + ) +import IdInfo -- bits and pieces +import Maybes ( maybeToBool, Maybe(..) ) +import PlainCore +import SaLib +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import Util +import WwLib +\end{code} + +We take Core bindings whose binders have their strictness attached (by +the front-end of the strictness analyser), and we return some +``plain'' bindings which have been worker/wrapper-ified, meaning: +\begin{enumerate} +\item +Functions have been split into workers and wrappers where appropriate; +\item +Binders' @IdInfos@ have been updated to reflect the existence +of these workers/wrappers (this is where we get STRICTNESS pragma +info for exported values). +\end{enumerate} + +\begin{code} +workersAndWrappers :: [PlainCoreBinding] -> WwM [PlainCoreBinding] + +workersAndWrappers top_binds + = mapWw (wwBind True{-top-level-}) top_binds `thenWw` \ top_binds2 -> + let + top_binds3 = map make_top_binding top_binds2 + in + returnWw (concat top_binds3) + where + make_top_binding :: WwBinding -> [PlainCoreBinding] + + make_top_binding (WwLet binds) = binds +\end{code} + +%************************************************************************ +%* * +\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@} +%* * +%************************************************************************ + +@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in +turn. Non-recursive case first, then recursive... + +\begin{code} +wwBind :: Bool -- True <=> top-level binding + -> PlainCoreBinding + -> WwM WwBinding -- returns a WwBinding intermediate form; + -- the caller will convert to Expr/Binding, + -- as appropriate. + +wwBind top_level (CoNonRec binder rhs) + = wwExpr rhs `thenWw` \ new_rhs -> + tryWW binder new_rhs `thenWw` \ new_pairs -> + returnWw (WwLet [CoNonRec b e | (b,e) <- new_pairs]) + -- Generated bindings must be non-recursive + -- because the original binding was. + +------------------------------ + +wwBind top_level (CoRec pairs) + = mapWw do_one pairs `thenWw` \ new_pairs -> + returnWw (WwLet [CoRec (concat new_pairs)]) + where + do_one (binder, rhs) = wwExpr rhs `thenWw` \ new_rhs -> + tryWW binder new_rhs +\end{code} + +@wwExpr@ basically just walks the tree, looking for appropriate +annotations that can be used. Remember it is @wwBind@ that does the +matching by looking for strict arguments of the correct type. +@wwExpr@ is a version that just returns the ``Plain'' Tree. +???????????????? ToDo + +\begin{code} +wwExpr :: PlainCoreExpr -> WwM PlainCoreExpr + +wwExpr e@(CoVar _) = returnWw e +wwExpr e@(CoLit _) = returnWw e +wwExpr e@(CoCon _ _ _) = returnWw e +wwExpr e@(CoPrim _ _ _) = returnWw e + +wwExpr (CoLam binders expr) + = wwExpr expr `thenWw` \ new_expr -> + returnWw (CoLam binders new_expr) + +wwExpr (CoTyLam ty expr) + = wwExpr expr `thenWw` \ new_expr -> + returnWw (CoTyLam ty new_expr) + +wwExpr (CoApp e1 e2) + = wwExpr e1 `thenWw` \ new_e1 -> + returnWw (CoApp new_e1 e2) + +wwExpr (CoTyApp expr ty) + = wwExpr expr `thenWw` \ new_expr -> + returnWw (CoTyApp new_expr ty) + +wwExpr (CoSCC cc expr) + = wwExpr expr `thenWw` \ new_expr -> + returnWw (CoSCC cc new_expr) + +wwExpr (CoLet bind expr) + = wwBind False{-not top-level-} bind `thenWw` \ intermediate_bind -> + wwExpr expr `thenWw` \ new_expr -> + returnWw (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 (CoCase expr alts) + = wwExpr expr `thenWw` \ new_expr -> + ww_alts alts `thenWw` \ new_alts -> + returnWw (CoCase new_expr new_alts) + where + ww_alts (CoAlgAlts alts deflt) + = mapWw ww_alg_alt alts `thenWw` \ new_alts -> + ww_deflt deflt `thenWw` \ new_deflt -> + returnWw (CoAlgAlts new_alts new_deflt) + + ww_alts (CoPrimAlts alts deflt) + = mapWw ww_prim_alt alts `thenWw` \ new_alts -> + ww_deflt deflt `thenWw` \ new_deflt -> + returnWw (CoPrimAlts new_alts new_deflt) + + ww_alg_alt (con, binders, rhs) + = wwExpr rhs `thenWw` \ new_rhs -> + returnWw (con, binders, new_rhs) + + ww_prim_alt (lit, rhs) + = wwExpr rhs `thenWw` \ new_rhs -> + returnWw (lit, new_rhs) + + ww_deflt CoNoDefault + = returnWw CoNoDefault + + ww_deflt (CoBindDefault binder rhs) + = wwExpr rhs `thenWw` \ new_rhs -> + returnWw (CoBindDefault binder new_rhs) +\end{code} + +%************************************************************************ +%* * +\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair} +%* * +%************************************************************************ + +@tryWW@ just accumulates arguments, converts strictness info from the +front-end into the proper form, then calls @mkWwBodies@ to do +the business. + +We have to BE CAREFUL that we don't worker-wrapperize an Id that has +already been w-w'd! (You can end up with several liked-named Ids +bouncing around at the same time---absolute mischief.) So the +criterion we use is: if an Id already has an unfolding (for whatever +reason), then we don't w-w it. + +The only reason this is monadised is for the unique supply. + +\begin{code} +tryWW :: Id -- the fn binder + -> PlainCoreExpr -- the bound rhs; its innards + -- are already ww'd + -> WwM [(Id, PlainCoreExpr)] -- either *one* or *two* pairs; + -- if one, then no worker (only + -- the orig "wrapper" lives on); + -- if two, then a worker and a + -- wrapper. +tryWW fn_id rhs + | idWantsToBeINLINEd fn_id + -- No point in worker/wrappering something that is going to be + -- INLINEd wholesale anyway. If the strictness analyser is run + -- twice, this test also prevents wrappers (which are INLINEd) + -- from being re-done. + = do_nothing + + | otherwise + = case (getIdStrictness fn_id) of + + NoStrictnessInfo -> do_nothing + BottomGuaranteed -> do_nothing + StrictnessInfo [] _ -> do_nothing -- V weird (but possible?) + + StrictnessInfo args_info _ -> + if not (indicatesWorker args_info) then + do_nothing + else + + -- OK, it looks as if a worker is worth a try + let + (tyvars, args, body) = digForLambdas rhs + body_ty = typeOfCoreExpr body + in + uniqSMtoWwM (mkWwBodies body_ty tyvars args args_info) `thenWw` \ result -> + case result of + + Nothing -> -- Very peculiar. This can only happen if we hit an + -- abstract type, which we shouldn't have since we've + -- constructed the args_info in this module! + + -- False. We might hit the all-args-absent-and-the- + -- body-is-unboxed case. A Nothing is legit. (WDP 94/10) + do_nothing + + Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) -> + + -- Terrific! It worked! + getUniqueWw `thenWw` \ worker_uniq -> + let + worker_ty = worker_ty_w_hole body_ty + + worker_id = mkWorkerId worker_uniq fn_id worker_ty + (noIdInfo `addInfo` worker_strictness) + + wrapper_rhs = wrapper_w_hole worker_id + worker_rhs = worker_w_hole body + + revised_strictness_info + = -- We know the basic strictness info already, but + -- we need to slam in the exact identity of the + -- worker Id: + mkStrictnessInfo args_info (Just worker_id) + + wrapper_id = fn_id `replaceIdInfo` + (getIdInfo fn_id `addInfo` + revised_strictness_info `addInfo_UF` + iWantToBeINLINEd UnfoldAlways) + -- 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 + (wrapper_id, wrapper_rhs) ] -- because wrapper mentions it + where + do_nothing = returnWw [ (fn_id, rhs) ] +\end{code} diff --git a/ghc/compiler/stranal/WwLib.hi b/ghc/compiler/stranal/WwLib.hi new file mode 100644 index 0000000..eeca5cb --- /dev/null +++ b/ghc/compiler/stranal/WwLib.hi @@ -0,0 +1,56 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface WwLib where +import BasicLit(BasicLit) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr) +import CostCentre(CostCentre) +import Id(Id, IdDetails) +import IdInfo(Demand, IdInfo, StrictnessInfo) +import Maybes(Labda, MaybeErr) +import NameTypes(ShortName) +import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..)) +import PrimOps(PrimOp) +import SplitUniq(SUniqSM(..), SplitUniqSupply, getSUnique, splitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique, mkUniqueGrimily) +infixr 9 `thenWw` +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +type PlainCoreBinding = CoreBinding Id Id +type PlainCoreExpr = CoreExpr Id Id +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data WwBinding = WwLet [CoreBinding Id Id] | WwCase (CoreExpr Id Id -> CoreExpr Id Id) +type WwM a = SplitUniqSupply -> (GlobalSwitch -> Bool) -> a +getSUnique :: SplitUniqSupply -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getUniqueWw :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> Unique + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "U(U(P)AA)A" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: SplitUniqSupply) (u1 :: GlobalSwitch -> Bool) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u2 :: Int) (u3 :: SplitUniqSupply) (u4 :: SplitUniqSupply) -> case u2 of { _ALG_ I# (u5 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u5]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +mAX_WORKER_ARGS :: Int + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [6#] _N_ #-} +mapWw :: (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> [a] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [b] + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +mkUniqueGrimily :: Int# -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-} +mkWwBodies :: UniType -> [TyVar] -> [Id] -> [Demand] -> SplitUniqSupply -> Labda (Id -> CoreExpr Id Id, CoreExpr Id Id -> CoreExpr Id Id, StrictnessInfo, UniType -> UniType) + {-# GHC_PRAGMA _A_ 4 _U_ 12222 _N_ _S_ "LLLS" _N_ _N_ #-} +returnWw :: a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a + {-# GHC_PRAGMA _A_ 3 _U_ 100 _N_ _S_ "SLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) (u3 :: GlobalSwitch -> Bool) -> u1 _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +thenWw :: (SplitUniqSupply -> (GlobalSwitch -> Bool) -> a) -> (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b + {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "LSSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> u0) (u3 :: u0 -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> u1) (u4 :: SplitUniqSupply) (u5 :: GlobalSwitch -> Bool) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> let {(u9 :: u0) = _APP_ u2 [ u7, u5 ]} in _APP_ u3 [ u9, u8, u5 ]; _NO_DEFLT_ } _N_ #-} +uniqSMtoWwM :: (SplitUniqSupply -> a) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a + {-# GHC_PRAGMA _A_ 3 _U_ 120 _N_ _S_ "SLA" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: SplitUniqSupply) -> _APP_ u1 [ u2 ] _N_} _F_ _IF_ARGS_ 1 3 XXX 2 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: SplitUniqSupply) (u3 :: GlobalSwitch -> Bool) -> _APP_ u1 [ u2 ] _N_ #-} + diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs new file mode 100644 index 0000000..5367ecf --- /dev/null +++ b/ghc/compiler/stranal/WwLib.lhs @@ -0,0 +1,470 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} + +\begin{code} +#include "HsVersions.h" + +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... + GlobalSwitch, CoreBinding, CoreExpr, PlainCoreBinding(..), + PlainCoreExpr(..), Id, Demand, MaybeErr, + TyVar, UniType, Unique, SplitUniqSupply, SUniqSM(..) + + IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique) + IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily) + ) where + +IMPORT_Trace +import Outputable -- ToDo: rm (debugging) +import Pretty + +import AbsPrel ( aBSENT_ERROR_ID, mkFunTy ) +import AbsUniType ( mkTyVarTy, isPrimType, getUniDataTyCon_maybe, + quantifyTy, TyVarTemplate + ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Id ( mkWorkerId, mkSysLocal, getIdUniType, + getInstantiatedDataConSig, getIdInfo, + replaceIdInfo, addIdStrictness, DataCon(..) + ) +import IdInfo -- lots of things +import Maybes ( maybeToBool, Maybe(..), MaybeErr ) +import PlainCore +import SaLib +import SrcLoc ( mkUnknownSrcLoc ) +import SplitUniq +import Unique +import Util + +infixr 9 `thenWw` +\end{code} + +%************************************************************************ +%* * +\subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing} +%* * +%************************************************************************ + +In the worker/wrapper stuff, we want to carry around @CoreBindings@ in +an ``intermediate form'' that can later be turned into a \tr{let} or +\tr{case} (depending on strictness info). + +\begin{code} +data WwBinding + = WwLet [PlainCoreBinding] + | WwCase (PlainCoreExpr -> PlainCoreExpr) + -- the "case" will be a "strict let" of the form: + -- + -- case rhs of + -- -> body + -- + -- (instead of "let = rhs in body") + -- + -- The expr you pass to the function is "body" (the + -- expression that goes "in the corner"). +\end{code} + +%************************************************************************ +%* * +\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} +%* * +%************************************************************************ + + ************ WARNING ****************** + these comments are rather out of date + ***************************************** + +@mkWrapperAndWorker@ is given: +\begin{enumerate} +\item +The {\em original function} \tr{f}, of the form: +\begin{verbatim} +f = /\ tyvars -> \ args -> body +\end{verbatim} +The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body} +are given separately. + +We use the Id \tr{f} mostly to get its type. + +\item +Strictness information about \tr{f}, in the form of a list of +@Demands@. + +\item +A @UniqueSupply@. +\end{enumerate} + +@mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...): +\begin{enumerate} +\item +Maybe @Nothing@: no worker/wrappering going on in this case. This can +happen (a)~if the strictness info says that there is nothing +interesting to do or (b)~if *any* of the argument types corresponding +to ``active'' arg postitions is abstract or will be to the outside +world (i.e., {\em this} module can see the constructors, but nobody +else will be able to). An ``active'' arg position is one which the +wrapper has to unpack. An importing module can't do this unpacking, +so it simply has to give up and call the wrapper only. + +\item +Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}. + +The @wrapper_Id@ is just the one that was passed in, with its +strictness IdInfo updated. +\end{enumerate} + +The \tr{body} of the original function may not be given (i.e., it's +BOTTOM), in which case you'd jolly well better not tug on the +worker-body output! + +Here's an example. The original function is: +\begin{verbatim} +g :: forall a . Int -> [a] -> a + +g = /\ a -> \ x ys -> + case x of + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +From this, we want to produce: +\begin{verbatim} +-- wrapper (an unfolding) +g :: forall a . Int -> [a] -> a + +g = /\ a -> \ x ys -> + case x of + I# x# -> g.wrk a x# ys + -- call the worker; don't forget the type args! + +-- worker +g.wrk :: forall a . Int# -> [a] -> a + +g.wrk = /\ a -> \ x# ys -> + let + x = I# x# + in + case x of -- note: body of g moved intact + 0 -> head ys + _ -> head (tail ys) +\end{verbatim} + +Something we have to be careful about: Here's an example: +\begin{verbatim} +-- "f" strictness: U(P)U(P) +f (I# a) (I# b) = a +# b + +g = f -- "g" strictness same as "f" +\end{verbatim} +\tr{f} will get a worker all nice and friendly-like; that's good. +{\em But we don't want a worker for \tr{g}}, even though it has the +same strictness as \tr{f}. Doing so could break laziness, at best. + +Consequently, we insist that the number of strictness-info items is +exactly the same as the number of lambda-bound arguments. (This is +probably slightly paranoid, but OK in practice.) If it isn't the +same, we ``revise'' the strictness info, so that we won't propagate +the unusable strictness-info into the interfaces. + +========================== + +Here's the real fun... The wrapper's ``deconstructing'' of arguments +and the worker's putting them back together again are ``duals'' in +some sense. + +What we do is walk along the @Demand@ list, producing two +expressions (one for wrapper, one for worker...), each with a ``hole'' +in it, where we will later plug in more information. For our previous +example, the expressions-with-HOLES are: +\begin{verbatim} +\ x ys -> -- wrapper + case x of + I# x# -> <> x# ys + +\ x# ys -> -- worker + let + x = I# x# + in + <> +\end{verbatim} +(Actually, we add the lambda-bound arguments at the end...) (The big +Lambdas are added on the front later.) + +\begin{code} +mkWwBodies + :: UniType -- Type of the *body* of the orig + -- function; i.e. /\ tyvars -> \ vars -> body + -> [TyVar] -- Type lambda vars of original function + -> [Id] -- Args of original function + -> [Demand] -- Strictness info for those args + + -> SUniqSM (Maybe -- Nothing iff (a) no interesting split possible + -- (b) any unpack on abstract type + (Id -> PlainCoreExpr, -- Wrapper expr w/ + -- hole for worker id + PlainCoreExpr -> PlainCoreExpr, -- Worker expr w/ hole + -- for original fn body + StrictnessInfo, -- Worker strictness info + UniType -> UniType) -- Worker type w/ hole + ) -- for type of original fn body + + +mkWwBodies body_ty tyvars args arg_infos + = ASSERT(length args == length arg_infos) + -- or you can get disastrous user/definer-module mismatches + if (all_absent_args_and_unboxed_value body_ty arg_infos) + then returnSUs Nothing + + else -- the rest... + mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos) + `thenUsMaybe` \ (wrap_frag, work_args_info, work_frag) -> + let + (work_args, wrkr_demands) = unzip work_args_info + + wrkr_strictness = mkStrictnessInfo wrkr_demands Nothing -- no worker-of-worker... + + wrapper_w_hole = \ worker_id -> + mkCoTyLam tyvars ( + mkCoLam args ( + wrap_frag ( + mkCoTyApps (CoVar worker_id) (map mkTyVarTy tyvars) + ))) + + worker_w_hole = \ orig_body -> + mkCoTyLam tyvars ( + mkCoLam work_args ( + work_frag orig_body + )) + + worker_ty_w_hole = \ body_ty -> + snd (quantifyTy tyvars ( + foldr mkFunTy body_ty (map getIdUniType work_args) + )) + in + returnSUs (Just (wrapper_w_hole, worker_w_hole, wrkr_strictness, worker_ty_w_hole)) + where + -- "all_absent_args_and_unboxed_value": + -- check for the obscure case of "\ x y z ... -> body" where + -- (a) *all* of the args x, y, z,... are absent, and + -- (b) the type of body is unboxed + -- If these conditions are true, we must *not* play worker/wrapper games! + + all_absent_args_and_unboxed_value body_ty arg_infos + = not (null arg_infos) + && all is_absent_arg arg_infos + && isPrimType body_ty + + is_absent_arg (WwLazy True) = True + is_absent_arg _ = False +\end{code} + +Important: mk_ww_arg_processing doesn't check +for an "interesting" split. It just races ahead and makes the +split, even if there's no unpacking at all. This is important for +when it calls itself recursively. + +It returns Nothing only if it encounters an abstract type in mid-flight. + +\begin{code} +mAX_WORKER_ARGS :: Int -- ToDo: set via flag +mAX_WORKER_ARGS = 6 -- Hmm... but this is an everything-must- + -- be-compiled-with-the-same-val thing... + +mk_ww_arg_processing + :: [Id] -- Args of original function + -> [Demand] -- Strictness info for those args + -- must be at least as long as args + + -> Int -- Number of extra args we are prepared to add. + -- This prevents over-eager unpacking, leading + -- to huge-arity functions. + + -> SUniqSM (Maybe -- Nothing iff any unpack on abstract type + (PlainCoreExpr -> PlainCoreExpr, -- Wrapper expr w/ + -- hole for worker id + -- applied to types + [(Id,Demand)], -- Worker's args + -- and their strictness info + PlainCoreExpr -> PlainCoreExpr) -- Worker body expr w/ hole + ) -- for original fn body + +mk_ww_arg_processing [] _ _ = returnSUs (Just (id, [], id)) + +mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args + = -- Absent argument + -- So, finish args to the right... + --pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) ( + let + arg_ty = getIdUniType arg + in + 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) -> + + -- wrapper doesn't pass this arg to worker: + returnSUs (Just ( + -- wrapper: + \ hole -> wrap_rest hole, + + -- worker: + work_args_info, -- NB: no argument added + \ hole -> mk_absent_let arg arg_ty (work_rest hole) + )) + --) + where + mk_absent_let arg arg_ty body + = if not (isPrimType arg_ty) then + CoLet (CoNonRec arg (mkCoTyApp (CoVar aBSENT_ERROR_ID) arg_ty)) + body + else -- quite horrible + panic "WwLib: haven't done mk_absent_let for primitives yet" + + +mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args + | new_max_extra_args > 0 -- Check that we are prepared to add arguments + = -- this is the complicated one. + --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) ( + case getUniDataTyCon_maybe arg_ty of + + Nothing -> -- Not a data type + panic "mk_ww_arg_processing: not datatype" + + Just (_, _, []) -> -- An abstract type + -- We have to give up on the whole idea + returnSUs Nothing + Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd + panic "mk_ww_arg_processing: multi-constr" + + Just (arg_tycon, tycon_arg_tys, [data_con]) -> + -- The main event: a single-constructor data type + + let + (_,inst_con_arg_tys,_) + = getInstantiatedDataConSig data_con tycon_arg_tys + in + getSUniques (length inst_con_arg_tys) `thenSUs` \ uniqs -> + + let unpk_args = zipWith (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc) + uniqs inst_con_arg_tys + in + -- In processing the rest, push the sub-component args + -- and infos on the front of the current bunch + mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args + `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> + + returnSUs (Just ( + -- wrapper: unpack the value + \ hole -> mk_unpk_case arg unpk_args + data_con arg_tycon + (wrap_rest hole), + + -- worker: expect the unpacked value; + -- reconstruct the orig value with a "let" + work_args_info, + \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole) + )) + --) + where + arg_ty = getIdUniType arg + + new_max_extra_args + = max_extra_args + + 1 -- We won't pass the original arg now + - nonAbsentArgs cmpnt_infos -- But we will pass an arg for each cmpt + + mk_unpk_case arg unpk_args boxing_con boxing_tycon body + = CoCase (CoVar arg) ( + CoAlgAlts [(boxing_con, unpk_args, body)] + CoNoDefault + ) + + mk_pk_let arg boxing_con con_tys unpk_args body + = CoLet (CoNonRec arg (CoCon boxing_con con_tys [CoVarAtom a | a <- unpk_args])) + body + +mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args + | otherwise + = -- For all others at the moment, we just + -- pass them to the worker unchanged. + --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) ( + + -- Finish args to the right... + mk_ww_arg_processing args infos max_extra_args + `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) -> + + returnSUs (Just ( + -- wrapper: + \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)), + + -- worker: + (arg, arg_demand) : work_args_info, + \ hole -> work_rest hole + )) + --) +\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 + = SplitUniqSupply + -> (GlobalSwitch -> Bool) + -> result + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenWw #-} +{-# INLINE returnWw #-} +#endif + +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 :: SUniqSM a -> WwM a + +getUniqueWw us sw_chk = getSUnique us + +uniqSMtoWwM u_obj us sw_chk = u_obj us + +thenUsMaybe :: SUniqSM (Maybe a) -> (a -> SUniqSM (Maybe b)) -> SUniqSM (Maybe b) +thenUsMaybe m k + = m `thenSUs` \ result -> + case result of + Nothing -> returnSUs Nothing + Just x -> k x +\end{code} diff --git a/ghc/compiler/tests/Jmakefile b/ghc/compiler/tests/Jmakefile new file mode 100644 index 0000000..716cc71 --- /dev/null +++ b/ghc/compiler/tests/Jmakefile @@ -0,0 +1,11 @@ +#define IHaveSubdirs + +SUBDIRS = reader \ + rename \ + simplCore \ + typecheck \ + deSugar \ + printing \ + ccall \ + deriving \ + bugs diff --git a/ghc/compiler/tests/README b/ghc/compiler/tests/README new file mode 100644 index 0000000..467ae42 --- /dev/null +++ b/ghc/compiler/tests/README @@ -0,0 +1,77 @@ +Installing a new compiler test +============================== + +[If the test if for the driver, the parser, the runtime system, the +std prelude, ... in short _not_ the compiler, it belongs elsewhere.] + +1. Copy your Haskell program into an appropriately named file in the + appropriate directory, e.g., "typecheck/tc093.hs" for the 93rd + typechecker test. + +2. Edit the Jmakefile in that dir to add your test: almost certainly + just a line of the form... + +RunStdTest(tc093,$(TESTGHC), "-ddump-tc tc093.hs", 0, /dev/null, tc093.stderr) + ^^^^^ +name of test|||| + ^^^^^^^^^^ +driver to use----|||||||||| + ^^^^^^^^^^^^^^^^^^^^ +driver command line----------|||||||||||||||||||| + ^^ +expected exit status (0=success, 1=failure)-------|| + ^^^^^^^^^ +file holding expected standard output----------------||||||||| + ^^^^^^^^^^^^^ +file holding expected output on standard error------------------||||||||||||| + + The example above is typical. The command-line stuff may vary, + but it's likely to be "dump pass output" (e.g., -ddump-tc) + and the input file name. Dump output is on stderr, hence the + expected-output files. + + The current best documentation of the flags to use is in + $(TOP)/driver/ghc (invoke w/ -help option). + +3. Create the expected-output files. I'm usually lazy and just + "touch" them (creating an empty file), then update them (section + below) after the test has "failed". + +4. "make Makefile", to make a Makefile from the Jmakefile. + +5. "make runtest_" (e.g., make runtest_tc093) to run the + one test. + + IF "make" FALLS OVER, THEN IMMEDIATEDLY "mv Makefile.bak Makefile"!! + You probably had a typo in the Jmakefile; fix it and resume from + step 4. + + +Running tests +============= + +* You may run all tests by typing "make runtests" (or, if you expect + or don't mind errors, "make -k runtests"). + +* You may run one test with "make runtest_". + +* You may run tests to with a simple script, + "dotests ". You may pass "make" arguments to it as well, + as in: + dotests -k tc019 tc028 + + +Updating the "expected output" files +==================================== + +Sometimes, it will happen that the differences between expected and +actual output of the tests will not mean failure but that the actual +output is "more correct". + +If you save the output of "make runtests" (mainly from "diff"), you +may automatically update the expected-output files by using + + patch -p0 < saved-output + +(You should probably ^C out of the "patch" if it doesn't do exactly +what you expect.) diff --git a/ghc/compiler/tests/TIMING/HelpMicroPrel.hi b/ghc/compiler/tests/TIMING/HelpMicroPrel.hi new file mode 100644 index 0000000..9c8423e --- /dev/null +++ b/ghc/compiler/tests/TIMING/HelpMicroPrel.hi @@ -0,0 +1,378 @@ +interface HelpMicroPrel where +alpha :: UniType +alpha_tyvar :: TyVar +alpha_tyvarU :: Int +alpha_tyvars :: [TyVar] +applySubstToId :: Subst -> Id -> Id +applySubstToTauTy :: Subst -> UniType -> UniType +applySubstToThetaTy :: Subst -> [(Class, UniType)] -> [(Class, UniType)] +applySubstToTy :: Subst -> UniType -> UniType +applyTy :: UniType -> UniType -> UniType +applyTyCon :: TyCon -> [UniType] -> UniType +applyTyConLazily :: TyCon -> TyCon -> [UniType] -> UniType +assocMaybe :: (Eq a) => a -> [(a, b)] -> Labda b +bOTTOM_ID :: Id +beta_tyvar :: TyVar +beta_tyvarU :: Int +binTyCon :: TyCon +binTyConU :: Int +catMaybes :: [Labda a] -> [a] +catQuickStrings :: [QuickString] -> QuickString +charPrimRelOpTy :: UniType +charPrimTy :: UniType +charPrimTyCon :: TyCon +charPrimTyConU :: Int +checkInstanceShape :: UniType -> Labda (TyCon, [TyVar]) +chrPrimId :: Id +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface deriving () +data Env a b +data GVE +data TCE +data PrettyRep +data PrimitiveOp +class AbsSynParam a where + hasType :: a -> Bool + getType :: a -> UniType + isConop :: a -> Bool + isAconid :: a -> Bool + isAconop :: a -> Bool + isAvarid :: a -> Bool + isAvarop :: a -> Bool +class Outputable a where + frc :: a -> Int + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep +data Annotations +data CLabelInfo +data Class +data ConFamilySize = SmallConFamily Int | LargeConFamily deriving () +data CoreExpr a b +data Id = Local Name Unique UniType | Imported Name UniType (Labda (CoreExpr Id Id)) | DataCon Name Int [TyVar] [(Class, UniType)] [UniType] TyCon deriving () +data Labda a = Just a | Nothing deriving () +data MaybeErr a b = Succeeded a | Failed b deriving () +data Name +data PrimitiveKind +data QuickString +data Subst +data TyCon = TyConSynonym Name Unique Int [TyVar] UniType | TyConData Name Unique Int [TyVar] ConFamilySize [Id] | TyConBuiltIn Name Unique Int deriving () +data TyVar +data TyVarOrTyCon = IsTyVar TyVar | IsTyCon TyCon [UniType] deriving () +data UniType = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniForall TyVar UniType deriving () +data TypecheckedPat +data Expr a b +data Matches a b +data MonoBinds a b +data Binds a b +data GRHSs a b +data UnifyErrContext = PredCtxt (Expr Id TypecheckedPat) | AppCtxt (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) | OpAppCtxt (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) | SectionLAppCtxt (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) | SectionRAppCtxt (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) | CaseCtxt (Expr Id TypecheckedPat) (Matches Id TypecheckedPat) | BranchCtxt (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) | ListCtxt [Expr Id TypecheckedPat] | ConPatCtxt QuickString [TypecheckedPat] | ConOpPatCtxt TypecheckedPat QuickString TypecheckedPat | ListPatCtxt [TypecheckedPat] | MatchPairCtxt (Matches Id TypecheckedPat) (Matches Id TypecheckedPat) | FilterCtxt (Expr Id TypecheckedPat) | GeneratorCtxt TypecheckedPat (Expr Id TypecheckedPat) | GRHSsBranchCtxt (GRHSs Id TypecheckedPat) (GRHSs Id TypecheckedPat) | GRHSsGuardCtxt (Expr Id TypecheckedPat) | RecCtxt [QuickString] (MonoBinds Id TypecheckedPat) | PatMonoBindsCtxt TypecheckedPat (GRHSs Id TypecheckedPat) (Binds Id TypecheckedPat) | MatchCtxt UniType UniType | ArithSeqCtxt [Expr Id TypecheckedPat] | CCallCtxt QuickString [Expr Id TypecheckedPat] deriving () +data UnifyErrInfo = DataConMisMatch UniType UniType | UniConMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType] deriving () +data Unique +data UniqueSupply +divideDoublePrimId :: Id +divideFloatPrimId :: Id +divideIntPrimId :: Id +divideIntegerPrimId :: Id +doublePrim2FloatPrimId :: Id +doublePrim2IntPrimId :: Id +doublePrimArithOpTy :: UniType +doublePrimRelOpTy :: UniType +doublePrimTy :: UniType +doublePrimTyCon :: TyCon +doublePrimTyConU :: Int +doublePrimUnaryOpTy :: UniType +duplicateLocal :: Id -> Unique -> Id +duplicateTyVar :: TyVar -> Unique -> TyVar +eRROR_ID :: Id +eqCharPrimId :: Id +eqDoublePrimId :: Id +eqFloatPrimId :: Id +eqIntPrimBoolId :: Id +eqIntPrimId :: Id +eqIntegerPrimId :: Id +errorTy :: UniType +expandTySyn :: UniType -> UniType +extractTyVarsFromTy :: UniType -> [TyVar] +extractTyVarsFromTys :: [UniType] -> [TyVar] +firstTupleUniqueInt :: Int +floatPrim2DoublePrimId :: Id +floatPrim2IntPrimId :: Id +floatPrimArithOpTy :: UniType +floatPrimRelOpTy :: UniType +floatPrimTy :: UniType +floatPrimTyCon :: TyCon +floatPrimTyConU :: Int +floatPrimUnaryOpTy :: UniType +frcId :: Bool -> Id -> Int +frcUniType :: UniType -> Int +funResultTy :: UniType -> UniType +geCharPrimId :: Id +geDoublePrimId :: Id +geFloatPrimId :: Id +geIntPrimId :: Id +geIntegerPrimId :: Id +genInstantiateTy :: UniqueSupply -> [(TyVar, UniType)] -> UniType -> (UniqueSupply, UniType) +genInstantiateTyUS :: (Env TyVar UniType) -> UniType -> UniqueSupply -> (UniqueSupply, UniType) +getClassName :: Class -> Name +getClassOps :: Class -> [(QuickString, UniType)] +getClassSig :: Class -> (TyVar, [(Class, UniType)], [(QuickString, UniType)]) +getClassThetaType :: Class -> [(Class, UniType)] +getConstructedTyTycon :: UniType -> TyCon +getDataConDeps :: Id -> [TyCon] +getDataConFamily :: Id -> [Id] +getDataConSig :: Id -> ([TyVar], [(Class, UniType)], [UniType], TyCon) +getDataConTag :: Id -> Int +getDataConTyCon :: Id -> TyCon +getDictClass :: Id -> Class +getDictClassType :: Id -> (Class, UniType) +getDictTyVar :: Id -> TyVar +getDictType :: Id -> UniType +getIdAnns :: Id -> Annotations +getIdBoundTyVars :: Id -> [TyVar] +getIdCLabelInfo :: Id -> CLabelInfo +getIdKind :: Id -> PrimitiveKind +getIdName :: Id -> Name +getIdQuickString :: Id -> QuickString +getIdSourceTypes :: Id -> [UniType] +getIdTargetType :: Id -> UniType +getIdTauType :: Id -> UniType +getIdUnfolding :: Id -> Labda (CoreExpr Id Id) +getIdUniType :: Id -> UniType +getLocalUnique :: Id -> Unique +getMentionedTyCons :: TyCon -> [TyCon] +getQuickStringStr :: QuickString -> [Char] +getReferredToTyCons :: UniType -> [TyCon] +getTauType :: UniType -> UniType +getTyConArity :: TyCon -> Int +getTyConDataCons :: TyCon -> [Id] +getTyConName :: TyCon -> Name +getTyConTyVars :: TyCon -> [TyVar] +getTyVar :: UniType -> TyVar +getTyVarMaybe :: UniType -> Labda TyVar +getUniDataTyCon :: UniType -> TyCon +getUnique :: UniqueSupply -> (UniqueSupply, Unique) +getUniques :: Int -> UniqueSupply -> (UniqueSupply, [Unique]) +glueTyArgs :: [UniType] -> UniType -> UniType +gtCharPrimId :: Id +gtDoublePrimId :: Id +gtFloatPrimId :: Id +gtIntPrimId :: Id +gtIntegerPrimId :: Id +iMPOSSIBLE_UNIQUE :: Unique +idxStringPrimId :: Id +initUS :: a -> (a -> (b, c)) -> (b, c) +instance AbsSynParam Id +instance AbsSynParam Name +instance AbsSynParam QuickString +instance Eq CLabelInfo +instance Eq Class +instance Eq Id +instance Eq Name +instance Eq PrimitiveKind +instance Eq QuickString +instance Eq TyCon +instance Eq TyVar +instance Eq UniType +instance Eq Unique +instance Ord Id +instance Ord Name +instance Ord QuickString +instance Ord TyCon +instance Ord TyVar +instance Ord Unique +instance Outputable Annotations +instance Outputable CLabelInfo +instance Outputable Class +instance Outputable ConFamilySize +instance Outputable Id +instance Outputable Name +instance Outputable PrimitiveKind +instance Outputable QuickString +instance Outputable TyCon +instance Outputable TyVar +instance Outputable UniType +instance Outputable Unique +instance Text Id +instance Text Unique +instantiateTauTy :: [(TyVar, UniType)] -> UniType -> UniType +instantiateThetaTy :: [(TyVar, UniType)] -> [(Class, UniType)] -> [(Class, UniType)] +instantiateTy :: [(TyVar, UniType)] -> UniType -> UniType +intPrim2DoublePrimId :: Id +intPrim2FloatPrimId :: Id +intPrim2IntegerPrimId :: Id +intPrimArithOpTy :: UniType +intPrimRelOpTy :: UniType +intPrimTy :: UniType +intPrimTyCon :: TyCon +intPrimTyConU :: Int +intPrimUnaryOpTy :: UniType +integerPrim2IntPrimId :: Id +integerPrimArithOpTy :: UniType +integerPrimRelOpTy :: UniType +integerPrimTy :: UniType +integerPrimTyCon :: TyCon +integerPrimTyConU :: Int +integerPrimUnaryOpTy :: UniType +ioPrimTy :: UniType +ioPrimTyCon :: TyCon +ioPrimTyConU :: Int +isAbstractTyConData :: TyCon -> Bool +isFunType :: UniType -> Bool +isGlobalId :: Id -> Bool +isTyConBuiltIn :: TyCon -> Bool +isTyConData :: TyCon -> Bool +isUnboxedType :: UniType -> Bool +kindFromType :: UniType -> PrimitiveKind +leCharPrimId :: Id +leDoublePrimId :: Id +leFloatPrimId :: Id +leIntPrimId :: Id +leIntegerPrimId :: Id +listMaybeErrs :: [MaybeErr a b] -> MaybeErr [a] [b] +ltCharPrimId :: Id +ltDoublePrimId :: Id +ltFloatPrimId :: Id +ltIntPrimId :: Id +ltIntegerPrimId :: Id +matchList :: Subst -> [UniType] -> [UniType] -> MaybeErr Subst UnifyErrInfo +matchTys :: Subst -> UniType -> UniType -> MaybeErr Subst UnifyErrInfo +minusDoublePrimId :: Id +minusFloatPrimId :: Id +minusIntPrimId :: Id +minusIntegerPrimId :: Id +mkClass :: Unique -> Name -> TyVar -> [(Class, UniType)] -> [(QuickString, UniType)] -> Class +mkClassBottom :: QuickString -> QuickString -> Annotations -> Class +mkDataCon :: Name -> UniType -> Id +mkDataTy :: TyCon -> [UniType] -> UniType +mkDataTyConBottom :: QuickString -> QuickString -> Annotations -> Int -> TyCon +mkDictFunId :: Class -> TyCon -> UniType -> Id +mkDictFunType :: [TyVar] -> [(Class, UniType)] -> Class -> UniType -> UniType +mkDictTy :: Class -> UniType -> UniType +mkForallTy :: [TyVar] -> UniType -> UniType +mkImported :: Name -> UniType -> (Labda (CoreExpr Id Id)) -> Id +mkInternalDataCon :: Name -> Int -> [TyVar] -> [(Class, UniType)] -> [UniType] -> TyCon -> Id +mkLocal :: Name -> Unique -> UniType -> Id +mkNamedLocal :: QuickString -> Unique -> UniType -> Annotations -> Id +mkQuickString :: [Char] -> QuickString +mkRenamedLocal :: Name -> Unique -> UniType -> Id +mkSigmaTy :: [TyVar] -> [(Class, UniType)] -> UniType -> UniType +mkSynTy :: TyCon -> [UniType] -> UniType -> UniType +mkSynTyConBottom :: QuickString -> QuickString -> Annotations -> Int -> TyCon +mkSysLocal :: [Char] -> Unique -> UniType -> Annotations -> Id +mkSysTyVar :: Unique -> TyVar +mkTUPLE_ID :: Int -> Id +mkTemplateLocals :: [UniType] -> [Id] +mkTupleTy :: [UniType] -> UniType +mkTupleTyCon :: Int -> TyCon +mkTupleTyConAndId :: Int -> (TyCon, Id) +mkTyConBuiltIn :: Name -> Unique -> Int -> TyCon +mkTyConData :: Name -> Unique -> Int -> [TyVar] -> Int -> [Id] -> TyCon +mkTyConSynonym :: Name -> Unique -> Int -> [TyVar] -> UniType -> TyCon +mkTyVarTy :: TyVar -> UniType +mkUnique :: Int -> Unique +mkUniqueSupply :: Int -> UniqueSupply +mkUserTyVar :: Unique -> QuickString -> TyVar +nanoCoreGVE :: GVE +nanoCoreTCE :: TCE +neCharPrimId :: Id +neDoublePrimId :: Id +neFloatPrimId :: Id +neIntPrimId :: Id +neIntegerPrimId :: Id +negateDoublePrimId :: Id +negateFloatPrimId :: Id +negateIntPrimId :: Id +negateIntegerPrimId :: Id +noFail :: (Labda a) -> [Char] -> a +ordPrimId :: Id +pRELUDE :: [Char] +pRELUDE_BUILTIN :: [Char] +pRELUDE_BUILTIN_Char :: ([Char], [Char]) +pRELUDE_BUILTIN_Double :: ([Char], [Char]) +pRELUDE_BUILTIN_Float :: ([Char], [Char]) +pRELUDE_BUILTIN_Int :: ([Char], [Char]) +pRELUDE_BUILTIN_Integer :: ([Char], [Char]) +pRELUDE_BUILTIN_List :: ([Char], [Char]) +pRELUDE_BUILTIN_Tuple0 :: ([Char], [Char]) +pRELUDE_BUILTIN_Tuple2 :: ([Char], [Char]) +pRELUDE_CORE :: [Char] +pRELUDE_CORE_Bool :: ([Char], [Char]) +pRELUDE_CORE_Enum :: ([Char], [Char]) +pRELUDE_CORE_Eq :: ([Char], [Char]) +pRELUDE_CORE_Fractional :: ([Char], [Char]) +pRELUDE_CORE_Integral :: ([Char], [Char]) +pRELUDE_CORE_Num :: ([Char], [Char]) +pRELUDE_CORE_Ord :: ([Char], [Char]) +pRELUDE_CORE_Real :: ([Char], [Char]) +pRELUDE_RATIO :: [Char] +pRELUDE_RATIO_Ratio :: ([Char], [Char]) +pRELUDE_TEXT :: [Char] +pRELUDE_TEXT_Text :: ([Char], [Char]) +packStringPrimId :: Id +pcAnns :: Annotations +pcBasicArithBinOp :: [Char] -> UniType -> Id -> Id -> Id +pcBasicArithUnaryOp :: [Char] -> UniType -> Id -> Id -> Id +pcBasicRelBinOp :: [Char] -> UniType -> Id -> Id -> Id +pcBasicRelBinOpInnerCase :: Id -> Id -> Id -> CoreExpr Id Id +pcBuiltinTyCon :: Int -> [Char] -> [Char] -> Int -> TyCon +pcDataCon :: [Char] -> [Char] -> UniType -> Id +pcDataTyCon :: Int -> [Char] -> [Char] -> Int -> [TyVar] -> [Id] -> TyCon +pcDictFunName :: ([Char], [Char]) -> ([Char], [Char]) -> Name +pcDictSelectorName :: [Char] -> [Char] -> Name +pcExternalName :: [Char] -> [Char] -> Name +pcGlobal :: [Char] -> [Char] -> UniType -> Id +pcInstance :: ([Char], [Char]) -> ([Char], [Char]) -> UniType -> Id +pcMethod :: Name -> [Char] -> UniType -> Id +pcPrim :: [Char] -> UniType -> PrimitiveOp -> Id +pcPrimPredicate :: [Char] -> UniType -> Id -> Id +plusDoublePrimId :: Id +plusFloatPrimId :: Id +plusIntPrimId :: Id +plusIntegerPrimId :: Id +pprParendUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep +pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep +remIntPrimId :: Id +remIntegerPrimId :: Id +removeTyConDataCons :: TyCon -> TyCon +returnUS :: a -> UniqueSupply -> (UniqueSupply, a) +sourceTypes :: UniType -> [UniType] +splitMultiType :: UniType -> ([[TyVar]], [[(Class, UniType)]], UniType) +splitThetaType :: UniType -> (Class, UniType) +splitTyArgs :: UniType -> ([UniType], UniType) +splitType :: UniType -> ([TyVar], [(Class, UniType)], UniType) +stringPrimTy :: UniType +stringPrimTyCon :: TyCon +stringPrimTyConU :: Int +targetType :: UniType -> UniType +thenUS :: (UniqueSupply -> (UniqueSupply, a)) -> (a -> UniqueSupply -> (UniqueSupply, b)) -> UniqueSupply -> (UniqueSupply, b) +thenUSs :: [UniqueSupply -> (UniqueSupply, a)] -> UniqueSupply -> (UniqueSupply, [a]) +timesDoublePrimId :: Id +timesFloatPrimId :: Id +timesIntPrimId :: Id +timesIntegerPrimId :: Id +tuple0TyCon :: TyCon +tuple2TyCon :: TyCon +tyVarOrTyCon :: UniType -> TyVarOrTyCon +type Arity = Int +type ClassName = QuickString +type ClassOp = (QuickString, UniType) +type ClassOps = [(QuickString, UniType)] +type ConName = QuickString +type ConTag = Int +type DictFun = Id +type DictVar = Id +type ModuleName = QuickString +type RhoType = UniType +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +type TyConName = QuickString +type TyVarName = QuickString +type USap a = UniqueSupply -> (UniqueSupply, a) +type VarName = QuickString +typeWithOneDataCon :: UniType -> Bool +uniformSCCs :: [[TyCon]] -> [Bool] +unifyList :: Subst -> [UniType] -> [UniType] -> MaybeErr Subst UnifyErrInfo +unifyTys :: Subst -> UniType -> UniType -> MaybeErr Subst UnifyErrInfo +verifyTauTy :: UniType -> UniType +zeroTy :: UniType +zeroTyCon :: TyCon +zeroTyConU :: Int diff --git a/ghc/compiler/tests/ccall/Jmakefile b/ghc/compiler/tests/ccall/Jmakefile new file mode 100644 index 0000000..1327782 --- /dev/null +++ b/ghc/compiler/tests/ccall/Jmakefile @@ -0,0 +1,21 @@ +runtests:: + @echo '###############################################################' + @echo '# Validation tests for the ccall desugaring, etc. #' + @echo '###############################################################' + +/* NB These tests are still in a state of flux... don't believe errors + they report. In fact, these aren't really very good tests at + all... */ + +/* Flags used when testing typechecker and desugaring */ +DS_FLAGS= -fglasgow-exts -noC -dcore-lint -ddump-tc -ddump-ds + +RunStdTest(cc001,$(GHC), $(DS_FLAGS) cc001.hs -o2 cc001.stderr) +RunStdTest(cc002,$(GHC), $(DS_FLAGS) cc002.hs -o2 cc002.stderr) +RunStdTest(cc003,$(GHC), $(DS_FLAGS) cc003.hs -x1 -o2 cc003.stderr) +RunStdTest(cc004,$(GHC), $(DS_FLAGS) cc004.hs -o2 cc004.stderr) + +/* Flags used when testing code generation */ +CG_FLAGS= -fglasgow-exts -via-C -dcore-lint -ddump-stg -ddump-flatC + + diff --git a/ghc/compiler/tests/ccall/cc001.hs b/ghc/compiler/tests/ccall/cc001.hs new file mode 100644 index 0000000..8c37355 --- /dev/null +++ b/ghc/compiler/tests/ccall/cc001.hs @@ -0,0 +1,25 @@ +--!!! cc001 -- ccall with standard boxed arguments and results + +module Test where + +import PreludeGlaIO + +-- simple functions + +a :: PrimIO Int +a = _ccall_ a + +b :: Int -> PrimIO Int +b x = _ccall_ b x + +c :: Int -> Char -> Float -> Double -> PrimIO Float +c x1 x2 x3 x4 = _ccall_ c x1 x2 x3 x4 + +-- simple monadic code + +d = a `thenPrimIO` \ x -> + b x `thenPrimIO` \ y -> + c y 'f' 1.0 2.0 + + + diff --git a/ghc/compiler/tests/ccall/cc001.stderr b/ghc/compiler/tests/ccall/cc001.stderr new file mode 100644 index 0000000..ab13745 --- /dev/null +++ b/ghc/compiler/tests/ccall/cc001.stderr @@ -0,0 +1,188 @@ +Typechecked: +lit.t444 = D# 2.0000000000000000## +lit.t443 = F# 1.0000000000000000# +AbsBinds [] [] [(a.t439, Test.a{-r79-})] + {- nonrec -} + a.t439 :: IoWorld -> (Int, IoWorld) + a.t439 + = ccall a [Int] +{- nonrec -} +{- nonrec -} +AbsBinds [] [] [(b.t440, Test.b{-r80-})] + {- nonrec -} + b.t440 :: Int -> IoWorld -> (Int, IoWorld) + b.t440 + x.r212 = ccall b [Int, Int] x.r212 +{- nonrec -} +{- nonrec -} +AbsBinds [] [] [(c.t441, Test.c{-r81-})] + {- nonrec -} + c.t441 :: Int -> Char -> Float -> Double -> IoWorld -> (Float, IoWorld) + c.t441 + x1.r213 x2.r214 x3.r215 x4.r216 + = ccall c [Float, Int, Char, Float, Double] + x1.r213 x2.r214 x3.r215 x4.r216 +{- nonrec -} +{- nonrec -} +AbsBinds [] [] [(d.t442, Test.d{-r82-})] + {- nonrec -} + d.t442 :: IoWorld -> (Float, IoWorld) + d.t442 + = (thenIO{-r102-} [Int, Float]) + Test.a{-r79-} + (\ x.r217 -> (thenIO{-r102-} [Int, Float]) + (Test.b{-r80-} x.r217) + (\ y.r218 -> Test.c{-r81-} + y.r218 'f' lit.t443 lit.t444)) +{- nonrec -} +{- nonrec -} +Desugared: +{- plain CoRec -} +lit.t444 :: Double +_NI_ +lit.t444 = (\ tpl.d0# -> D#! tpl.d0#) 2.0000000000000000## +lit.t443 :: Float +_NI_ +lit.t443 = (\ tpl.d1# -> F#! tpl.d1#) 1.0000000000000000# +Test.a{-r79-} :: IoWorld -> (Int, IoWorld) +_NI_ +Test.a{-r79-} = + \ ds.d2 -> + case + (case + (case ds.d2 of { + IoWorld ds.d3# -> ds.d3# + }) + of { + a.d8# -> ( _CCALL_ a [] Int# )! a.d8# + }) + of { + IntPrimAndIoWorld ds.d4# ds.d5# -> + let { + a.d6 :: Int + _NI_ + a.d6 = I#! ds.d4# } in + let { + a.d7 :: IoWorld + _NI_ + a.d7 = IoWorld! ds.d5# + } in Tup2! Int IoWorld a.d6 a.d7 + } +Test.b{-r80-} :: Int -> IoWorld -> (Int, IoWorld) +_NI_ +Test.b{-r80-} = + \ x.r212 ds.d9 -> + case + (case + (case ds.d9 of { + IoWorld ds.d10# -> ds.d10# + }) + of { + a.d16# -> + case + (case x.r212 of { + I# ds.d11# -> ds.d11# + }) + of { + a.d17# -> ( _CCALL_ b [Int#] Int# )! a.d16# a.d17# + } + }) + of { + IntPrimAndIoWorld ds.d12# ds.d13# -> + let { + a.d14 :: Int + _NI_ + a.d14 = I#! ds.d12# } in + let { + a.d15 :: IoWorld + _NI_ + a.d15 = IoWorld! ds.d13# + } in Tup2! Int IoWorld a.d14 a.d15 + } +Test.c{-r81-} :: Int -> Char -> Float -> Double -> IoWorld -> (Float, IoWorld) +_NI_ +Test.c{-r81-} = + \ x1.r213 x2.r214 x3.r215 x4.r216 ds.d18 -> + case + (case + (case ds.d18 of { + IoWorld ds.d19# -> ds.d19# + }) + of { + a.d28# -> + case + (case x1.r213 of { + I# ds.d20# -> ds.d20# + }) + of { + a.d29# -> + case + (case x2.r214 of { + C# ds.d21# -> ds.d21# + }) + of { + a.d30# -> + case + (case x3.r215 of { + F# ds.d22# -> ds.d22# + }) + of { + a.d31# -> + case + (case x4.r216 of { + D# ds.d23# -> ds.d23# + }) + of { + a.d32# -> + ( _CCALL_ c [Int#, + Char#, + Float#, + Double#] Float# )! + a.d28# + a.d29# + a.d30# + a.d31# + a.d32# + } + } + } + } + }) + of { + FloatPrimAndIoWorld ds.d24# ds.d25# -> + let { + a.d26 :: Float + _NI_ + a.d26 = F#! ds.d24# } in + let { + a.d27 :: IoWorld + _NI_ + a.d27 = IoWorld! ds.d25# + } in Tup2! Float IoWorld a.d26 a.d27 + } +Test.d{-r82-} :: IoWorld -> (Float, IoWorld) +_NI_ +Test.d{-r82-} = + let { + a.d36 :: Int -> IoWorld -> (Float, IoWorld) + _NI_ + a.d36 = + \ x.r217 -> + let { + a.d35 :: Int -> IoWorld -> (Float, IoWorld) + _NI_ + a.d35 = + \ y.r218 -> + (let { + a.d33 :: Char + _NI_ + a.d33 = C#! 'f'# + } in Test.c{-r81-} y.r218 a.d33) lit.t443 lit.t444 + } in + (let { + a.d34 :: IoWorld -> (Int, IoWorld) + _NI_ + a.d34 = Test.b{-r80-} x.r217 + } in ((thenIO{-r102-} Int) Float) a.d34) a.d35 + } in ((thenIO{-r102-} Int) Float) Test.a{-r79-} a.d36 +{- end plain CoRec -} diff --git a/ghc/compiler/tests/ccall/cc002.hs b/ghc/compiler/tests/ccall/cc002.hs new file mode 100644 index 0000000..3a4b66d --- /dev/null +++ b/ghc/compiler/tests/ccall/cc002.hs @@ -0,0 +1,21 @@ +--!!! cc002 -- ccall with non-standard boxed arguments and results + +module Test where + +import PreludeGlaIO + +-- Test returning results + +a :: PrimIO _MallocPtr +a = _ccall_ a + +b :: PrimIO _StablePtr +b = _ccall_ b + +-- Test taking arguments + +c :: _MallocPtr -> PrimIO Int +c x = _ccall_ c x + +d :: _StablePtr -> PrimIO Int +d x = _ccall_ d x diff --git a/ghc/compiler/tests/ccall/cc002.stderr b/ghc/compiler/tests/ccall/cc002.stderr new file mode 100644 index 0000000..2f097cf --- /dev/null +++ b/ghc/compiler/tests/ccall/cc002.stderr @@ -0,0 +1,140 @@ +Typechecked: +AbsBinds [] [] [(a.t439, Test.a{-r79-})] + {- nonrec -} + a.t439 :: IoWorld -> (CHeapPtr, IoWorld) + a.t439 + = ccall a [CHeapPtr] +{- nonrec -} +{- nonrec -} +AbsBinds [] [] [(b.t440, Test.b{-r80-})] + {- nonrec -} + b.t440 :: IoWorld -> (StablePtr, IoWorld) + b.t440 + = ccall b [StablePtr] +{- nonrec -} +{- nonrec -} +AbsBinds [] [] [(c.t441, Test.c{-r81-})] + {- nonrec -} + c.t441 :: CHeapPtr -> IoWorld -> (Int, IoWorld) + c.t441 + x.r211 = ccall c [Int, CHeapPtr] x.r211 +{- nonrec -} +{- nonrec -} +AbsBinds [] [] [(d.t442, Test.d{-r82-})] + {- nonrec -} + d.t442 :: StablePtr -> IoWorld -> (Int, IoWorld) + d.t442 + x.r212 = ccall d [Int, StablePtr] x.r212 +{- nonrec -} +{- nonrec -} +Desugared: +Test.a{-r79-} :: IoWorld -> (CHeapPtr, IoWorld) +_NI_ +Test.a{-r79-} = + \ ds.d0 -> + case + (case + (case ds.d0 of { + IoWorld ds.d1# -> ds.d1# + }) + of { + a.d6# -> ( _CCALL_ a [] CHeapPtr# )! a.d6# + }) + of { + CHPPrimAndIoWorld ds.d2# ds.d3# -> + let { + a.d4 :: CHeapPtr + _NI_ + a.d4 = CHP#! ds.d2# } in + let { + a.d5 :: IoWorld + _NI_ + a.d5 = IoWorld! ds.d3# + } in Tup2! CHeapPtr IoWorld a.d4 a.d5 + } +Test.b{-r80-} :: IoWorld -> (StablePtr, IoWorld) +_NI_ +Test.b{-r80-} = + \ ds.d7 -> + case + (case + (case ds.d7 of { + IoWorld ds.d8# -> ds.d8# + }) + of { + a.d13# -> ( _CCALL_ b [] StablePtr# )! a.d13# + }) + of { + SPPrimAndIoWorld ds.d9# ds.d10# -> + let { + a.d11 :: StablePtr + _NI_ + a.d11 = StablePtr#! ds.d9# } in + let { + a.d12 :: IoWorld + _NI_ + a.d12 = IoWorld! ds.d10# + } in Tup2! StablePtr IoWorld a.d11 a.d12 + } +Test.c{-r81-} :: CHeapPtr -> IoWorld -> (Int, IoWorld) +_NI_ +Test.c{-r81-} = + \ x.r211 ds.d14 -> + case + (case + (case ds.d14 of { + IoWorld ds.d15# -> ds.d15# + }) + of { + a.d21# -> + case + (case x.r211 of { + CHP# ds.d16# -> ds.d16# + }) + of { + a.d22# -> ( _CCALL_ c [CHeapPtr#] Int# )! a.d21# a.d22# + } + }) + of { + IntPrimAndIoWorld ds.d17# ds.d18# -> + let { + a.d19 :: Int + _NI_ + a.d19 = I#! ds.d17# } in + let { + a.d20 :: IoWorld + _NI_ + a.d20 = IoWorld! ds.d18# + } in Tup2! Int IoWorld a.d19 a.d20 + } +Test.d{-r82-} :: StablePtr -> IoWorld -> (Int, IoWorld) +_NI_ +Test.d{-r82-} = + \ x.r212 ds.d23 -> + case + (case + (case ds.d23 of { + IoWorld ds.d24# -> ds.d24# + }) + of { + a.d30# -> + case + (case x.r212 of { + StablePtr# ds.d25# -> ds.d25# + }) + of { + a.d31# -> ( _CCALL_ d [StablePtr#] Int# )! a.d30# a.d31# + } + }) + of { + IntPrimAndIoWorld ds.d26# ds.d27# -> + let { + a.d28 :: Int + _NI_ + a.d28 = I#! ds.d26# } in + let { + a.d29 :: IoWorld + _NI_ + a.d29 = IoWorld! ds.d27# + } in Tup2! Int IoWorld a.d28 a.d29 + } diff --git a/ghc/compiler/tests/ccall/cc003.hs b/ghc/compiler/tests/ccall/cc003.hs new file mode 100644 index 0000000..5b8bd82 --- /dev/null +++ b/ghc/compiler/tests/ccall/cc003.hs @@ -0,0 +1,8 @@ +--!!! cc003 -- ccall with unresolved polymorphism (should fail) +module Test where + +import PreludeGlaIO + +fubar :: PrimIO Int +fubar = ccall f `seqPrimIO` ccall b + --^ result type of f "lost" (never gets generalised) diff --git a/ghc/compiler/tests/ccall/cc003.stderr b/ghc/compiler/tests/ccall/cc003.stderr new file mode 100644 index 0000000..4b2772f --- /dev/null +++ b/ghc/compiler/tests/ccall/cc003.stderr @@ -0,0 +1,15 @@ +Typechecked: +AbsBinds [] [] [(fubar.t439, Main.fubar{-r79-})] + {- nonrec -} + fubar.t439 :: IoWorld -> (Int, IoWorld) + fubar.t439 + = (thenIO_{-r99-} [bpv83, Int]) (ccall f [bpv83] ) (ccall b [Int] ) +{- nonrec -} +{- nonrec -} +Desugared: + +Fail: panic! (the `impossible' happened): + getBoxedPrimTypeInfo: bpv83 + +Please report it as a compiler bug to glasgow-haskell-bugs@dcs.glasgow.ac.uk. + diff --git a/ghc/compiler/tests/ccall/cc004.hs b/ghc/compiler/tests/ccall/cc004.hs new file mode 100644 index 0000000..7ad0ced --- /dev/null +++ b/ghc/compiler/tests/ccall/cc004.hs @@ -0,0 +1,29 @@ +--!!! cc004 -- ccall with synonyms, polymorphic type variables and user type variables. +module Test where + +import PreludeGlaIO + +-- Since I messed up the handling of polymorphism originally, I'll +-- explicitly test code with UserSysTyVar (ie an explicit polymorphic +-- signature) + +foo = _ccall_ f `thenADR` \ a -> returnPrimIO (a + 1) + where + thenADR :: PrimIO a -> (a -> PrimIO b) -> PrimIO b + m `thenADR` k = \ s -> case m s of + (a,t) -> k a t + +-- and with a PolySysTyVar (ie no explicit signature) + +bar = _ccall_ f `thenADR` \ a -> returnPrimIO (a + 1) + where + -- thenADR :: PrimIO a -> (a -> PrimIO b) -> PrimIO b + m `thenADR` k = \ s -> case m s of + (a,t) -> k a t + +-- and with a type synonym + +type INT = Int +barfu :: PrimIO INT +barfu = _ccall_ b + diff --git a/ghc/compiler/tests/ccall/cc004.stderr b/ghc/compiler/tests/ccall/cc004.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deSugar/Jmakefile b/ghc/compiler/tests/deSugar/Jmakefile new file mode 100644 index 0000000..e513463 --- /dev/null +++ b/ghc/compiler/tests/deSugar/Jmakefile @@ -0,0 +1,54 @@ +#define IHaveSubdirs + +SUBDIRS = cvh-ds-unboxed + +runtests:: + @echo '###############################################################' + @echo '# Validation tests for the desugarer. #' + @echo '###############################################################' + +FLAGS=-noC -ddump-ds -dcore-lint + +RunStdTest(ds001,$(GHC), $(FLAGS) ds001.hs -o2 ds001.stderr) +RunStdTest(ds002,$(GHC), $(FLAGS) ds002.hs -o2 ds002.stderr) +RunStdTest(ds003,$(GHC), $(FLAGS) ds003.hs -o2 ds003.stderr) +RunStdTest(ds004,$(GHC), $(FLAGS) ds004.hs -o2 ds004.stderr) +RunStdTest(ds005,$(GHC), $(FLAGS) ds005.hs -o2 ds005.stderr) +RunStdTest(ds006,$(GHC), $(FLAGS) ds006.hs -o2 ds006.stderr) +RunStdTest(ds007,$(GHC), $(FLAGS) ds007.hs -o2 ds007.stderr) +RunStdTest(ds008,$(GHC), $(FLAGS) ds008.hs -o2 ds008.stderr) +RunStdTest(ds009,$(GHC), $(FLAGS) ds009.hs -o2 ds009.stderr) +RunStdTest(ds010,$(GHC), $(FLAGS) ds010.hs -o2 ds010.stderr) +RunStdTest(ds011,$(GHC), $(FLAGS) ds011.hs -o2 ds011.stderr) +RunStdTest(ds012,$(GHC), $(FLAGS) ds012.hs -o2 ds012.stderr) +RunStdTest(ds013,$(GHC), $(FLAGS) ds013.hs -o2 ds013.stderr) + +RunStdTest(ds014,$(GHC), $(FLAGS) ds014.hs -o2 ds014.stderr) +AsPartOfTest(ds014,@echo 'ds014a -- some things that should NOT go through -- not done yet') + +RunStdTest(ds015,$(GHC), $(FLAGS) ds015.hs -o2 ds015.stderr) +RunStdTest(ds016,$(GHC), $(FLAGS) ds016.hs -o2 ds016.stderr) +RunStdTest(ds017,$(GHC), $(FLAGS) ds017.hs -o2 ds017.stderr) +RunStdTest(ds018,$(GHC), $(FLAGS) ds018.hs -o2 ds018.stderr) +RunStdTest(ds019,$(GHC), $(FLAGS) ds019.hs -o2 ds019.stderr) +RunStdTest(ds020,$(GHC), $(FLAGS) ds020.hs -o2 ds020.stderr) +RunStdTest(ds021,$(GHC), $(FLAGS) ds021.hs -o2 ds021.stderr) +RunStdTest(ds022,$(GHC), $(FLAGS) ds022.hs -o2 ds022.stderr) +RunStdTest(ds023,$(GHC), $(FLAGS) ds023.hs -o2 ds023.stderr) +RunStdTest(ds024,$(GHC), $(FLAGS) ds024.hs -o2 ds024.stderr) +RunStdTest(ds025,$(GHC), $(FLAGS) ds025.hs -o2 ds025.stderr) +RunStdTest(ds026,$(GHC), $(FLAGS) ds026.hs -o2 ds026.stderr) +RunStdTest(ds027,$(GHC), $(FLAGS) ds027.hs -o2 ds027.stderr) +RunStdTest(ds028,$(GHC), $(FLAGS) ds028.hs -o2 ds028.stderr) +RunStdTest(ds029,$(GHC), $(FLAGS) ds029.hs -o2 ds029.stderr) +RunStdTest(ds030,$(GHC), $(FLAGS) ds030.hs -dppr-all -o2 ds030.stderr) +RunStdTest(ds031,$(GHC), $(FLAGS) ds031.hs -o2 ds031.stderr) +RunStdTest(ds032,$(GHC), $(FLAGS) ds032.hs -o2 ds032.stderr) +RunStdTest(ds033,$(GHC), $(FLAGS) ds033.hs -o2 ds033.stderr) +RunStdTest(ds034,$(GHC), $(FLAGS) ds034.hs -o2 ds034.stderr) +RunStdTest(ds035,$(GHC), -fglasgow-exts $(FLAGS) ds035.hs -o2 ds035.stderr) +RunStdTest(ds036,$(GHC), $(FLAGS) ds036.hs -o2 ds036.stderr) +RunStdTest(ds037,$(GHC), $(FLAGS) ds037.hs -o2 ds037.stderr) +RunStdTest(ds038,$(GHC), $(FLAGS) ds038.hs -o2 ds038.stderr) +RunStdTest(ds039,$(GHC), $(FLAGS) -dppr-all ds039.hs -o2 ds039.stderr) +RunStdTest(ds040,$(GHC), $(FLAGS) ds040.hs -o2 ds040.stderr) diff --git a/ghc/compiler/tests/deSugar/cvh-ds-unboxed/Jmakefile b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/Jmakefile new file mode 100644 index 0000000..a418eb6 --- /dev/null +++ b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/Jmakefile @@ -0,0 +1,3 @@ +FLAGS=-noC -ddump-ds -fglasgow-exts + +RunStdTest(cvh-unbox1,$(GHC),$(FLAGS) Life2.lhs -o2 cvh-unbox1.stderr) diff --git a/ghc/compiler/tests/deSugar/cvh-ds-unboxed/Life2.lhs b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/Life2.lhs new file mode 100644 index 0000000..30de1a3 --- /dev/null +++ b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/Life2.lhs @@ -0,0 +1,39 @@ +\section{Life2} + +\begin{code} +module Life2 (life2) where +import UTypes +import UCopy (copy_FI) + +life2 itLimit boardSize + = (fBStr firstBoard) ++ (fBStr secondBoard) + where {- ... -} + +\end{code} + +\begin{code} + fBStr :: FI -> String + fBStr FIN = [] + +{- OK + firstBoard :: FI + firstBoard = copy_FI boardSize (case 0 of + (MkInt x) -> x) +-} + +{- not happy about this -} + + firstBoard = copy_FI boardSize u0 + u0 = unBoxInt 0 + unBoxInt (MkInt x) = x +{- end of not happy -} + +{- not happy with this either! -} + + secondBoard = copy_FI boardSize u1 + + (MkInt u1) = 0 +{- end of second not happy -} +\end{code} + + diff --git a/ghc/compiler/tests/deSugar/cvh-ds-unboxed/UCopy.hi b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/UCopy.hi new file mode 100644 index 0000000..314de4e --- /dev/null +++ b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/UCopy.hi @@ -0,0 +1,9 @@ +interface UCopy where +import UTypes(F3I(..), FC(..), FI(..), LI(..), SC(..), SI(..)) +copy_FI :: Int -> IntPrim -> FI {-# ARITY _ = 2 #-} +data F3I = F3IN | F3I1 IntPrim IntPrim IntPrim | F3I2 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim | F3I3 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim | F3I4 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim | F3I5 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim F3I +data FC = FCN | FC1 Char# | FC2 Char# Char# | FC3 Char# Char# Char# | FC4 Char# Char# Char# Char# | FC5 Char# Char# Char# Char# Char# FC +data FI = FIN | FI1 IntPrim | FI2 IntPrim IntPrim | FI3 IntPrim IntPrim IntPrim | FI4 IntPrim IntPrim IntPrim IntPrim | FI5 IntPrim IntPrim IntPrim IntPrim IntPrim FI +data LI = LIN | LI1 IntPrim LI +data SC = SCN | SC1 Char# SC | SC2 Char# Char# SC | SC3 Char# Char# Char# SC | SC4 Char# Char# Char# Char# SC | SC5 Char# Char# Char# Char# Char# SC +data SI = SIN | SI1 IntPrim SI | SI2 IntPrim IntPrim SI | SI3 IntPrim IntPrim IntPrim SI | SI4 IntPrim IntPrim IntPrim IntPrim SI | SI5 IntPrim IntPrim IntPrim IntPrim IntPrim SI diff --git a/ghc/compiler/tests/deSugar/cvh-ds-unboxed/UTypes.hi b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/UTypes.hi new file mode 100644 index 0000000..896a29c --- /dev/null +++ b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/UTypes.hi @@ -0,0 +1,7 @@ +interface UTypes where +data F3I = F3IN | F3I1 IntPrim IntPrim IntPrim | F3I2 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim | F3I3 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim | F3I4 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim | F3I5 IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim IntPrim F3I +data FC = FCN | FC1 Char# | FC2 Char# Char# | FC3 Char# Char# Char# | FC4 Char# Char# Char# Char# | FC5 Char# Char# Char# Char# Char# FC +data FI = FIN | FI1 IntPrim | FI2 IntPrim IntPrim | FI3 IntPrim IntPrim IntPrim | FI4 IntPrim IntPrim IntPrim IntPrim | FI5 IntPrim IntPrim IntPrim IntPrim IntPrim FI +data LI = LIN | LI1 IntPrim LI +data SC = SCN | SC1 Char# SC | SC2 Char# Char# SC | SC3 Char# Char# Char# SC | SC4 Char# Char# Char# Char# SC | SC5 Char# Char# Char# Char# Char# SC +data SI = SIN | SI1 IntPrim SI | SI2 IntPrim IntPrim SI | SI3 IntPrim IntPrim IntPrim SI | SI4 IntPrim IntPrim IntPrim IntPrim SI | SI5 IntPrim IntPrim IntPrim IntPrim IntPrim SI diff --git a/ghc/compiler/tests/deSugar/cvh-ds-unboxed/cvh-unbox1.stderr b/ghc/compiler/tests/deSugar/cvh-ds-unboxed/cvh-unbox1.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deSugar/ds-wildcard.hs b/ghc/compiler/tests/deSugar/ds-wildcard.hs new file mode 100644 index 0000000..24c5b3b --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds-wildcard.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +x@_ = x diff --git a/ghc/compiler/tests/deSugar/ds001.hs b/ghc/compiler/tests/deSugar/ds001.hs new file mode 100644 index 0000000..0358f20 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds001.hs @@ -0,0 +1,25 @@ +--!!! ds001 -- simple function and pattern bindings +-- +-- this tests ultra-simple function and pattern bindings (no patterns) + +module Test where + +-- simple function bindings + +f x = x + +g x y z = f z + +j w x y z = g w x z + +h x y = f y + where + f a b = a + +-- simple pattern bindings + +a = b + +b = f + +c = c diff --git a/ghc/compiler/tests/deSugar/ds001.stderr b/ghc/compiler/tests/deSugar/ds001.stderr new file mode 100644 index 0000000..6282a3e --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds001.stderr @@ -0,0 +1,23 @@ +Desugared: +Test.f :: for all d. d -> d +Test.f = /\ o95 -> \ x.129 -> x.129 +Test.g :: for all d, e, f. d -> e -> f -> f +Test.g = /\ o98 o99 t101 -> \ x.130 y.131 z.132 -> (Test.f t101) z.132 +Test.j :: for all d, e, f, g. d -> e -> f -> g -> g +Test.j = + /\ t108 t109 o106 t110 -> \ w.133 x.134 y.135 z.136 -> + (((Test.g t108) t109) t110) w.133 x.134 z.136 +Test.h :: for all d, e, f. d -> f -> e -> f +Test.h = + /\ o113 t119 t120 -> \ x.139 y.140 -> + let f.145 = /\ o141 o142 -> \ a.143 b.144 -> a.143 + in ((f.145 t119) t120) y.140 +Test.b :: for all d. d -> d +Test.b = /\ t123 -> Test.f t123 +Test.a :: for all d. d -> d +Test.a = /\ t126 -> Test.b t126 +{- plain CoRec -} +Test.c :: for all d. d +Test.c = /\ t127 -> Test.c t127 +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds002.hs b/ghc/compiler/tests/deSugar/ds002.hs new file mode 100644 index 0000000..d754636 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds002.hs @@ -0,0 +1,16 @@ +--!!! ds002 -- overlapping equations and guards +-- +-- this tests "overlapping" variables and guards + +module Test where + +f x = x +f y = y +f z = z + +g x y z | True = f z + | True = f z + | True = f z +g x y z | True = f z + | True = f z + | True = f z diff --git a/ghc/compiler/tests/deSugar/ds002.stderr b/ghc/compiler/tests/deSugar/ds002.stderr new file mode 100644 index 0000000..4cd3d62 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds002.stderr @@ -0,0 +1,12 @@ +Desugared: +Test.f :: for all d. d -> d +Test.f = /\ o88 -> \ x.104 -> x.104 +Test.g :: for all d, e, f. d -> e -> f -> f +Test.g = + /\ o97 o98 t102 -> \ x.106 y.107 z.108 -> + let + fail.109 = + (error t102) + "\"ds002.hs\", line 16: pattern-matching failure [function binding]\n"S + in (Test.f t102) z.108 + diff --git a/ghc/compiler/tests/deSugar/ds003.hs b/ghc/compiler/tests/deSugar/ds003.hs new file mode 100644 index 0000000..f68346d --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds003.hs @@ -0,0 +1,8 @@ +--!!! ds003 -- list, tuple, lazy, as patterns +-- +module Test where + +f [] y True = [] +f x a@(y,ys) ~z = [] +f (x:x1:x2:x3) ~(y,ys) z = [] +f x y True = [] diff --git a/ghc/compiler/tests/deSugar/ds003.stderr b/ghc/compiler/tests/deSugar/ds003.stderr new file mode 100644 index 0000000..da843e7 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds003.stderr @@ -0,0 +1,61 @@ +Desugared: +Test.f :: for all d, e, f, g. [d] -> (e, f) -> Bool -> [g] +Test.f = + /\ t106 o107 o108 t113 -> \ ds.122 y.123 ds.124 -> + let + fail.125 = + (error [t113]) + "\"ds003.hs\", line 8: pattern-matching failure [function binding]\n"S in + let + fail.149 = + let + fail.142 = + let + fail.128 = + case ds.124 of { + True -> + let y.126 = y.123 in + let x.127 = ds.122 in Nil! t113 + _ -> fail.125 + } + in + case ds.122 of { + (:) x.129 ds.130 -> + case ds.130 of { + (:) x1.131 ds.132 -> + case ds.132 of { + (:) x2.133 x3.134 -> + let z.135 = ds.124 in + let + y.138 = + case y.123 of { + MkTuple2 y.136 ys.137 -> y.136 + } in + let + ys.141 = + case y.123 of { + MkTuple2 y.139 ys.140 -> ys.140 + } + in Nil! t113 + _ -> fail.128 + } + _ -> fail.128 + } + _ -> fail.128 + } + in + case y.123 of { + MkTuple2 y.143 ys.144 -> + let z.146 = let z.145 = ds.124 in z.145 in + let a.147 = y.123 in let x.148 = ds.122 in Nil! t113 + } + in + case ds.122 of { + Nil -> + case ds.124 of { + True -> Nil! t113 + _ -> fail.149 + } + _ -> fail.149 + } + diff --git a/ghc/compiler/tests/deSugar/ds004.hs b/ghc/compiler/tests/deSugar/ds004.hs new file mode 100644 index 0000000..ef9d0b4 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds004.hs @@ -0,0 +1,9 @@ +--!!! ds004 -- nodups from SLPJ p 79 +-- +module Test where + +-- SLPJ, p 79 +nodups [] = [] +nodups [x] = [x] +nodups (y:x:xs) | y == x = nodups (x:xs) + | True = y : nodups (x:xs) diff --git a/ghc/compiler/tests/deSugar/ds004.stderr b/ghc/compiler/tests/deSugar/ds004.stderr new file mode 100644 index 0000000..5890e92 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds004.stderr @@ -0,0 +1,31 @@ +Desugared: +{- plain CoRec -} +Test.nodups :: for all d. -> [d] -> [d] +Test.nodups = + /\ t95 -> \ dict.90 ds.103 -> + let + fail.104 = + (error [t95]) + "\"ds004.hs\", line 9: pattern-matching failure [function binding]\n"S + in + case ds.103 of { + Nil -> Nil! t95 + (:) x.105 ds.106 -> + case ds.106 of { + Nil -> :! t95 x.105 (Nil! t95) + (:) x.107 xs.108 -> + let y.109 = x.105 + in + case ((== t95) dict.90 y.109 x.107) of { + True -> + (Test.nodups t95) dict.90 ((: t95) x.107 xs.108) + False -> + (: t95) + y.109 + ((Test.nodups t95) + dict.90 ((: t95) x.107 xs.108)) + } + } + } +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds005.hs b/ghc/compiler/tests/deSugar/ds005.hs new file mode 100644 index 0000000..505d500 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds005.hs @@ -0,0 +1,15 @@ +--!!! ds005 -- mappairs from SLPJ Ch 5' +-- +-- this simply tests a "typical" example + +module MapPairs where + +-- from SLPJ, p 78 +mappairs f [] ys = [] +mappairs f (x:xs) [] = [] +mappairs f (x:xs) (y:ys) = f x y : mappairs f xs ys + +-- from p 80 +mappairs' f [] ys = [] +mappairs' f x [] = [] +mappairs' f (x:xs) (y:ys) = f x y : mappairs' f xs ys diff --git a/ghc/compiler/tests/deSugar/ds005.stderr b/ghc/compiler/tests/deSugar/ds005.stderr new file mode 100644 index 0000000..84c0664 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds005.stderr @@ -0,0 +1,65 @@ +Desugared: +{- plain CoRec -} +MapPairs.mappairs :: for all d, e, f. (d -> e -> f) -> [d] -> [e] -> [f] +MapPairs.mappairs = + /\ t109 t112 t105 -> \ f.146 ds.147 ys.148 -> + let + fail.149 = + (error [t105]) + "\"ds005.hs\", line 10: pattern-matching failure [function binding]\n"S + in + case ds.147 of { + Nil -> Nil! t105 + (:) x.150 xs.151 -> + case ys.148 of { + Nil -> let f.152 = f.146 in Nil! t105 + (:) y.153 ys.154 -> + let xs.155 = xs.151 in + let x.156 = x.150 in + let f.157 = f.146 + in + (: t105) + (f.157 x.156 y.153) + ((((MapPairs.mappairs t109) t112) t105) + f.157 xs.155 ys.154) + } + } +{- end plain CoRec -} +{- plain CoRec -} +MapPairs.mappairs' :: for all d, e, f. (d -> e -> f) -> [d] -> [e] -> [f] +MapPairs.mappairs' = + /\ t133 t136 t129 -> \ f.162 ds.163 ys.164 -> + let + fail.165 = + (error [t129]) + "\"ds005.hs\", line 15: pattern-matching failure [function binding]\n"S in + let + fail.174 = + let + fail.171 = + case ds.163 of { + (:) x.166 xs.167 -> + case ys.164 of { + (:) y.168 ys.169 -> + let f.170 = f.162 + in + (: t129) + (f.170 x.166 y.168) + ((((MapPairs.mappairs' t133) t136) t129) + f.170 xs.167 ys.169) + _ -> fail.165 + } + _ -> fail.165 + } + in + case ys.164 of { + Nil -> let x.172 = ds.163 in let f.173 = f.162 in Nil! t129 + _ -> fail.171 + } + in + case ds.163 of { + Nil -> Nil! t129 + _ -> fail.174 + } +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds006.hs b/ghc/compiler/tests/deSugar/ds006.hs new file mode 100644 index 0000000..6df589e --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds006.hs @@ -0,0 +1,6 @@ +--!!! ds006 -- v | True = v+1 | False = v (dead code elim) +-- +module Test where + +v | True = v + 1 + | False = v diff --git a/ghc/compiler/tests/deSugar/ds006.stderr b/ghc/compiler/tests/deSugar/ds006.stderr new file mode 100644 index 0000000..0db25c8 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds006.stderr @@ -0,0 +1,19 @@ +Desugared: +Test.v :: for all d. -> d +Test.v = + /\ t78 -> \ dict.79 -> + let dict.77 = dict.79 + in + let + {- CoRec -} + v.75 = + let + fail.81 = + (error t78) + "\"ds006.hs\", line 6: pattern-matching failure [function binding]\n"S + in + (+ t78) + dict.77 v.75 ((fromInteger t78) dict.79 (MkInteger! 1##)) + {- end CoRec -} + in v.75 + diff --git a/ghc/compiler/tests/deSugar/ds007.hs b/ghc/compiler/tests/deSugar/ds007.hs new file mode 100644 index 0000000..5b2b752 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds007.hs @@ -0,0 +1,6 @@ +--!!! ds007 -- simple local bindings + +module ShouldSucceed where + +w = a where a = y + y = [] diff --git a/ghc/compiler/tests/deSugar/ds007.stderr b/ghc/compiler/tests/deSugar/ds007.stderr new file mode 100644 index 0000000..fad21b7 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds007.stderr @@ -0,0 +1,7 @@ +Desugared: +ShouldSucceed.w :: for all d. [d] +ShouldSucceed.w = + /\ t84 -> + let y.86 = /\ t85 -> Nil! t85 in + let a.88 = /\ t87 -> y.86 t87 in a.88 t84 + diff --git a/ghc/compiler/tests/deSugar/ds008.hs b/ghc/compiler/tests/deSugar/ds008.hs new file mode 100644 index 0000000..1264d13 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds008.hs @@ -0,0 +1,11 @@ +--!!! ds008 -- free tyvars on RHSs +-- +-- these tests involve way-cool TyApps + +module Test where + +f x = [] + +g x = (f [],[],[],[]) + +h x = g (1::Int) diff --git a/ghc/compiler/tests/deSugar/ds008.stderr b/ghc/compiler/tests/deSugar/ds008.stderr new file mode 100644 index 0000000..240c477 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds008.stderr @@ -0,0 +1,21 @@ +Desugared: +Test.f :: for all d, e. d -> [e] +Test.f = /\ o81 t82 -> \ x.102 -> Nil! t82 +Test.g :: for all d, e, f, g, h. d -> ([e], [f], [g], [h]) +Test.g = + /\ o85 t87 t89 t90 t91 -> \ x.103 -> + MkTuple4! + [t87] + [t89] + [t90] + [t91] + (((Test.f [t88]) t87) (Nil! t88)) + (Nil! t89) + (Nil! t90) + (Nil! t91) +Test.h :: for all d, e, f, g, h. d -> ([e], [f], [g], [h]) +Test.h = + /\ o94 t96 t97 t98 t99 -> \ x.104 -> + (((((Test.g Int) t96) t97) t98) t99) + (let dict.105 = dfun.Num.Int in MkInt! 1#) + diff --git a/ghc/compiler/tests/deSugar/ds009.hs b/ghc/compiler/tests/deSugar/ds009.hs new file mode 100644 index 0000000..370b629 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds009.hs @@ -0,0 +1,13 @@ +--!!! ds009 -- simple list comprehensions + +module SimpleListComp where + +f xs = [ x | x <- xs ] + +g xs ys zs = [ (x,y,z) | x <- xs, y <- ys, z <- zs, True ] + +h xs ys = [ [x,y] | x <- xs, y <- ys, False ] + +i xs = [ x | all@(x,y) <- xs, all == ([],[]) ] + +j xs = [ (a,b) | (a,b,c,d) <- xs ] diff --git a/ghc/compiler/tests/deSugar/ds009.stderr b/ghc/compiler/tests/deSugar/ds009.stderr new file mode 100644 index 0000000..a60a3de --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds009.stderr @@ -0,0 +1,150 @@ +Desugared: +SimpleListComp.f :: for all d. [d] -> [d] +SimpleListComp.f = + /\ t104 -> \ xs.145 -> + let + {- CoRec -} + ds.146 = + \ ds.147 -> + case ds.147 of { + Nil -> Nil t104 + (:) ds.148 ds.149 -> + let x.150 = ds.148 in (: t104) x.150 (ds.146 ds.149) + } + {- end CoRec -} + in ds.146 xs.145 +SimpleListComp.g :: for all d, e, f. [d] -> [e] -> [f] -> [(d, e, f)] +SimpleListComp.g = + /\ t110 t111 t112 -> \ xs.163 ys.164 zs.165 -> + let + {- CoRec -} + ds.166 = + \ ds.167 -> + case ds.167 of { + Nil -> Nil (t110, t111, t112) + (:) ds.168 ds.169 -> + let x.170 = ds.168 + in + let + {- CoRec -} + ds.171 = + \ ds.172 -> + case ds.172 of { + Nil -> ds.166 ds.169 + (:) ds.173 ds.174 -> + let y.175 = ds.173 + in + let + {- CoRec -} + ds.176 = + \ ds.177 -> + case ds.177 of { + Nil -> ds.171 ds.174 + (:) ds.178 ds.179 -> + let z.180 = ds.178 + in + (: (t110, + t111, + t112)) + (MkTuple3! + t110 + t111 + t112 + x.170 + y.175 + z.180) + (ds.176 ds.179) + } + {- end CoRec -} + in ds.176 zs.165 + } + {- end CoRec -} + in ds.171 ys.164 + } + {- end CoRec -} + in ds.166 xs.163 +SimpleListComp.h :: for all d. [d] -> [d] -> [[d]] +SimpleListComp.h = + /\ t118 -> \ xs.189 ys.190 -> + let + {- CoRec -} + ds.191 = + \ ds.192 -> + case ds.192 of { + Nil -> Nil [t118] + (:) ds.193 ds.194 -> + let x.195 = ds.193 + in + let + {- CoRec -} + ds.196 = + \ ds.197 -> + case ds.197 of { + Nil -> ds.191 ds.194 + (:) ds.198 ds.199 -> + let y.200 = ds.198 in ds.196 ds.199 + } + {- end CoRec -} + in ds.196 ys.190 + } + {- end CoRec -} + in ds.191 xs.189 +SimpleListComp.i :: for all d, e. -> -> [([e], [d])] -> [[e]] +SimpleListComp.i = + /\ t128 t127 -> \ dict.133 dict.132 -> + let dict.130 = (dfun.Eq.List t127) dict.132 in + let dict.131 = (dfun.Eq.List t128) dict.133 in + let dict.126 = ((dfun.Eq.Tuple2 [t127]) [t128]) dict.130 dict.131 in + let + i.120 = + \ xs.78 -> + let + {- CoRec -} + ds.201 = + \ ds.202 -> + case ds.202 of { + Nil -> Nil [t127] + (:) ds.203 ds.204 -> + case ds.203 of { + MkTuple2 x.80 y.81 -> + let all.79 = ds.203 + in + case + ((== ([t127], [t128])) + dict.126 + all.79 + (MkTuple2! + [t127] + [t128] + (Nil! t127) + (Nil! t128))) + of { + True -> + (: [t127]) x.80 (ds.201 ds.204) + False -> ds.201 ds.204 + } + } + } + {- end CoRec -} + in ds.201 xs.78 + in i.120 +SimpleListComp.j :: for all d, e, f, g. [(f, g, d, e)] -> [(f, g)] +SimpleListComp.j = + /\ t139 t140 t137 t138 -> \ xs.210 -> + let + {- CoRec -} + ds.211 = + \ ds.212 -> + case ds.212 of { + Nil -> Nil (t137, t138) + (:) ds.213 ds.214 -> + case ds.213 of { + MkTuple4 a.215 b.216 c.217 d.218 -> + (: (t137, t138)) + (MkTuple2! t137 t138 a.215 b.216) + (ds.211 ds.214) + } + } + {- end CoRec -} + in ds.211 xs.210 + diff --git a/ghc/compiler/tests/deSugar/ds010.hs b/ghc/compiler/tests/deSugar/ds010.hs new file mode 100644 index 0000000..a49c09c --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds010.hs @@ -0,0 +1,15 @@ +--!!! ds010 -- deeply-nested list comprehensions + +module Test where + +z = [ (a,b,c,d,e,f,g,h,i,j) | a <- "12", + b <- "12", + c <- "12", + d <- "12", + e <- "12", + f <- "12", + g <- "12", + h <- "12", + i <- "12", + j <- "12" + ] diff --git a/ghc/compiler/tests/deSugar/ds010.stderr b/ghc/compiler/tests/deSugar/ds010.stderr new file mode 100644 index 0000000..cfc1cae --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds010.stderr @@ -0,0 +1,228 @@ +Desugared: +Test.z :: [(Char, Char, Char, Char, Char, Char, Char, Char, Char, Char)] +Test.z = + let + {- CoRec -} + ds.136 = + \ ds.137 -> + case ds.137 of { + Nil -> + Nil (Char, + Char, + Char, + Char, + Char, + Char, + Char, + Char, + Char, + Char) + (:) ds.138 ds.139 -> + let a.140 = ds.138 + in + let + {- CoRec -} + ds.141 = + \ ds.142 -> + case ds.142 of { + Nil -> ds.136 ds.139 + (:) ds.143 ds.144 -> + let b.145 = ds.143 + in + let + {- CoRec -} + ds.146 = + \ ds.147 -> + case ds.147 of { + Nil -> ds.141 ds.144 + (:) ds.148 ds.149 -> + let c.150 = ds.148 + in + let + {- CoRec -} + ds.151 = + \ ds.152 -> + case + ds.152 + of { + Nil -> + ds.146 + ds.149 + (:) ds.153 + ds.154 -> + let + d.155 = + ds.153 + in + let + {- CoRec -} + ds.156 = + \ ds.157 -> + case + ds.157 + of { + Nil -> + ds.151 + ds.154 + (:) ds.158 + ds.159 -> + let + e.160 = + ds.158 + in + let + {- CoRec -} + ds.161 = + \ ds.162 -> + case + ds.162 + of { + Nil -> + ds.156 + ds.159 + (:) ds.163 + ds.164 -> + let + f.165 = + ds.163 + in + let + {- CoRec -} + ds.166 = + \ ds.167 -> + case + ds.167 + of { + Nil -> + ds.161 + ds.164 + (:) ds.168 + ds.169 -> + let + g.170 = + ds.168 + in + let + {- CoRec -} + ds.171 = + \ ds.172 -> + case + ds.172 + of { + Nil -> + ds.166 + ds.169 + (:) ds.173 + ds.174 -> + let + h.175 = + ds.173 + in + let + {- CoRec -} + ds.176 = + \ ds.177 -> + case + ds.177 + of { + Nil -> + ds.171 + ds.174 + (:) ds.178 + ds.179 -> + let + i.180 = + ds.178 + in + let + {- CoRec -} + ds.181 = + \ ds.182 -> + case + ds.182 + of { + Nil -> + ds.176 + ds.179 + (:) ds.183 + ds.184 -> + let + j.185 = + ds.183 + in + (: (Char, + Char, + Char, + Char, + Char, + Char, + Char, + Char, + Char, + Char)) + (MkTuple10! + Char + Char + Char + Char + Char + Char + Char + Char + Char + Char + a.140 + b.145 + c.150 + d.155 + e.160 + f.165 + g.170 + h.175 + i.180 + j.185) + (ds.181 + ds.184) + } + {- end CoRec -} + in + ds.181 + "12"S + } + {- end CoRec -} + in + ds.176 + "12"S + } + {- end CoRec -} + in + ds.171 + "12"S + } + {- end CoRec -} + in + ds.166 + "12"S + } + {- end CoRec -} + in + ds.161 + "12"S + } + {- end CoRec -} + in + ds.156 + "12"S + } + {- end CoRec -} + in ds.151 "12"S + } + {- end CoRec -} + in ds.146 "12"S + } + {- end CoRec -} + in ds.141 "12"S + } + {- end CoRec -} + in ds.136 "12"S + diff --git a/ghc/compiler/tests/deSugar/ds011.hs b/ghc/compiler/tests/deSugar/ds011.hs new file mode 100644 index 0000000..8b12d93 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds011.hs @@ -0,0 +1,11 @@ +--!!! ds011 -- uses of "error" + +module Tests where + +f = error [] + +g = error "" + +h = error "\"" + +i = error "foo" diff --git a/ghc/compiler/tests/deSugar/ds011.stderr b/ghc/compiler/tests/deSugar/ds011.stderr new file mode 100644 index 0000000..2535d80 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds011.stderr @@ -0,0 +1,10 @@ +Desugared: +Tests.f :: for all d. d +Tests.f = /\ t79 -> (error t79) (Nil! Char) +Tests.g :: for all d. d +Tests.g = /\ t83 -> (error t83) (Nil! Char) +Tests.h :: for all d. d +Tests.h = /\ t86 -> (error t86) "\""S +Tests.i :: for all d. d +Tests.i = /\ t89 -> (error t89) "foo"S + diff --git a/ghc/compiler/tests/deSugar/ds012.hs b/ghc/compiler/tests/deSugar/ds012.hs new file mode 100644 index 0000000..390db58 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds012.hs @@ -0,0 +1,10 @@ +--!!! ds012 -- simple Integer arithmetic +-- +module Tests where + +f x = 1 + 2 - 3 + 4 * 5 + +g x = x + (f x) + +h x = 111111111111111111111111111111111111111111111111111111111111 + + 222222222222222222222222222222222222222222222222222222222222 diff --git a/ghc/compiler/tests/deSugar/ds012.stderr b/ghc/compiler/tests/deSugar/ds012.stderr new file mode 100644 index 0000000..93c198c --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds012.stderr @@ -0,0 +1,58 @@ +Desugared: +Tests.f :: for all d, e. -> d -> e +Tests.f = + /\ o81 t82 -> \ dict.101 -> + let dict.99 = dict.101 in + let dict.97 = dict.99 in + let dict.94 = dict.97 in + let dict.91 = dict.94 in + let dict.89 = dict.91 in + let dict.87 = dict.89 in + let dict.85 = dict.87 in + let dict.83 = dict.85 in + let + f.80 = + \ x.63 -> + (+ t82) + dict.83 + ((- t82) + dict.85 + ((+ t82) + dict.87 + ((fromInteger t82) dict.89 (MkInteger! 1##)) + ((fromInteger t82) dict.91 (MkInteger! 2##))) + ((fromInteger t82) dict.94 (MkInteger! 3##))) + ((* t82) + dict.97 + ((fromInteger t82) dict.99 (MkInteger! 4##)) + ((fromInteger t82) dict.101 (MkInteger! 5##))) + in f.80 +Tests.g :: for all d. -> d -> d +Tests.g = + /\ t110 -> \ dict.111 -> + let dict.108 = dict.111 in + let + g.105 = + \ x.64 -> + (+ t110) dict.108 x.64 (((Tests.f t110) t110) dict.111 x.64) + in g.105 +Tests.h :: for all d, e. -> d -> e +Tests.h = + /\ o115 t120 -> \ dict.121 -> + let dict.119 = dict.121 in + let dict.117 = dict.119 in + let + h.114 = + \ x.65 -> + (+ t120) + dict.117 + ((fromInteger t120) + dict.119 + (MkInteger! + 111111111111111111111111111111111111111111111111111111111111##)) + ((fromInteger t120) + dict.121 + (MkInteger! + 222222222222222222222222222222222222222222222222222222222222##)) + in h.114 + diff --git a/ghc/compiler/tests/deSugar/ds013.hs b/ghc/compiler/tests/deSugar/ds013.hs new file mode 100644 index 0000000..9b5b4b3 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds013.hs @@ -0,0 +1,23 @@ +--!!! ds013 -- simple Rational arithmetic + +module Tests where + +f = 1.5 + 2.0 - 3.14159265 + 4.2 * 5.111111111111111111111111111 + +g :: Float +g = 1.5 + 2.0 - 3.14159265 + 4.2 * 5.111111111111111111111111111 + +h :: Double +h = 1.5 + 2.0 - 3.14159265 + 4.2 * 5.111111111111111111111111111 + +{- later +g x = x + (f x) + +h x = 1.0e1000000000 + 1.0e1000000000 + +i x = 1.0e-1000000000 + 1.0e-1000000000 + +j x = 1111111111.222222222222222e333333333333333 + * 4444444444.555555555555555e-66666666666666 +-} + diff --git a/ghc/compiler/tests/deSugar/ds013.stderr b/ghc/compiler/tests/deSugar/ds013.stderr new file mode 100644 index 0000000..3cca8d3 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds013.stderr @@ -0,0 +1,89 @@ +Desugared: +Tests.f :: for all d. -> d +Tests.f = + /\ t78 -> \ dict.97 -> + let dict.95 = dict.97 in + let dict.90 = dict.95 in + let dict.87 = dict.90 in + let dict.85 = dict.87 in + let dict.93 = (sdsel.Fractional.Num t78) dict.85 in + let dict.83 = dict.93 in + let dict.81 = dict.83 in + let dict.79 = dict.81 in + let + f.77 = + (+ t78) + dict.79 + ((- t78) + dict.81 + ((+ t78) + dict.83 + ((fromRational t78) + dict.85 (MkDouble! 1.5000000000000000##)) + ((fromRational t78) + dict.87 (MkDouble! 2.0000000000000000##))) + ((fromRational t78) + dict.90 (MkDouble! 3.1415926500000002##))) + ((* t78) + dict.93 + ((fromRational t78) + dict.95 (MkDouble! 4.2000000000000002##)) + ((fromRational t78) + dict.97 (MkDouble! 5.1111111111111107##))) + in f.77 +dict.103 :: +dict.103 = dfun.Num.Float +dict.105 :: +dict.105 = dfun.Num.Float +dict.107 :: +dict.107 = dfun.Num.Float +dict.109 :: +dict.109 = dfun.Fractional.Float +dict.111 :: +dict.111 = dfun.Fractional.Float +dict.114 :: +dict.114 = dfun.Fractional.Float +dict.117 :: +dict.117 = dfun.Num.Float +dict.119 :: +dict.119 = dfun.Fractional.Float +dict.121 :: +dict.121 = dfun.Fractional.Float +Tests.g :: Float +Tests.g = + plusFloat + (minusFloat + (plusFloat + (MkFloat! 1.5000000000000000#) (MkFloat! 2.0000000000000000#)) + (MkFloat! 3.1415926500000002#)) + (timesFloat + (MkFloat! 4.2000000000000002#) (MkFloat! 5.1111111111111107#)) +dict.127 :: +dict.127 = dfun.Num.Double +dict.129 :: +dict.129 = dfun.Num.Double +dict.131 :: +dict.131 = dfun.Num.Double +dict.133 :: +dict.133 = dfun.Fractional.Double +dict.135 :: +dict.135 = dfun.Fractional.Double +dict.138 :: +dict.138 = dfun.Fractional.Double +dict.141 :: +dict.141 = dfun.Num.Double +dict.143 :: +dict.143 = dfun.Fractional.Double +dict.145 :: +dict.145 = dfun.Fractional.Double +Tests.h :: Double +Tests.h = + plusDouble + (minusDouble + (plusDouble + (MkDouble! 1.5000000000000000##) + (MkDouble! 2.0000000000000000##)) + (MkDouble! 3.1415926500000002##)) + (timesDouble + (MkDouble! 4.2000000000000002##) (MkDouble! 5.1111111111111107##)) + diff --git a/ghc/compiler/tests/deSugar/ds014.hs b/ghc/compiler/tests/deSugar/ds014.hs new file mode 100644 index 0000000..cf1ccb1 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds014.hs @@ -0,0 +1,76 @@ +--!!! ds014 -- character and string literals +--!!! really should add ALL weird forms... + +module Tests where + +a = 'a' +b = "b" +c = a:b +d = b ++ b + +b1 = "" -- examples from the Haskell report +b2 = "\&" -- the same thing +b3 = "\SO\&H" ++ "\137\&9" + +a000 = '\NUL' +a001 = '\SOH' +a002 = '\STX' +a003 = '\ETX' +a004 = '\EOT' +a005 = '\ENQ' +a006 = '\ACK' +a007 = '\BEL' +a010 = '\BS' +a011 = '\HT' +a012 = '\LF' +a013 = '\VT' +a014 = '\FF' +a015 = '\CR' +a016 = '\SO' +a017 = '\SI' +a020 = '\DLE' +a021 = '\DC1' +a022 = '\DC2' +a023 = '\DC3' +a024 = '\DC4' +a025 = '\NAK' +a026 = '\SYN' +a027 = '\ETB' +a030 = '\CAN' +a031 = '\EM' +a032 = '\SUB' +a033 = '\ESC' +a034 = '\FS' +a035 = '\GS' +a036 = '\RS' +a037 = '\US' +a040 = '\SP' +a042 = '"' +a047 = '\'' +a134 = '\\' +a177 = '\DEL' + +ascii = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\ + \\BS\HT\LF\VT\FF\CR\SO\SI\ + \\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\ + \\CAN\EM\SUB\ESC\FS\GS\RS\US\ + \\SP!\"#$%&'\ + \()*+,-./\ + \01234567\ + \89:;<=>?\ + \@ABCDEFG\ + \HIJKLMNO\ + \PQRSTUVW\ + \XYZ[\\]^_\ + \`abcdefg\ + \hijklmno\ + \pqrstuvw\ + \xyz{|}~\DEL" + +na200 = '\o200' +na250 = '\o250' +na300 = '\o300' +na350 = '\o350' +na377 = '\o377' + +eightbit = "\o200\o250\o300\o350\o377" diff --git a/ghc/compiler/tests/deSugar/ds014.stderr b/ghc/compiler/tests/deSugar/ds014.stderr new file mode 100644 index 0000000..e151c0a --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds014.stderr @@ -0,0 +1,105 @@ +Desugared: +Tests.a :: Char +Tests.a = MkChar! 'a'# +Tests.b :: [Char] +Tests.b = "b"S +Tests.c :: [Char] +Tests.c = (: Char) Tests.a Tests.b +Tests.d :: [Char] +Tests.d = (++ Char) Tests.b Tests.b +Tests.b1 :: [Char] +Tests.b1 = Nil! Char +Tests.b2 :: [Char] +Tests.b2 = Nil! Char +Tests.b3 :: [Char] +Tests.b3 = (++ Char) "\SO\&H"S "\137\&9"S +Tests.a000 :: Char +Tests.a000 = MkChar! '\NUL'# +Tests.a001 :: Char +Tests.a001 = MkChar! '\SOH'# +Tests.a002 :: Char +Tests.a002 = MkChar! '\STX'# +Tests.a003 :: Char +Tests.a003 = MkChar! '\ETX'# +Tests.a004 :: Char +Tests.a004 = MkChar! '\EOT'# +Tests.a005 :: Char +Tests.a005 = MkChar! '\ENQ'# +Tests.a006 :: Char +Tests.a006 = MkChar! '\ACK'# +Tests.a007 :: Char +Tests.a007 = MkChar! '\a'# +Tests.a010 :: Char +Tests.a010 = MkChar! '\b'# +Tests.a011 :: Char +Tests.a011 = MkChar! '\t'# +Tests.a012 :: Char +Tests.a012 = MkChar! '\n'# +Tests.a013 :: Char +Tests.a013 = MkChar! '\v'# +Tests.a014 :: Char +Tests.a014 = MkChar! '\f'# +Tests.a015 :: Char +Tests.a015 = MkChar! '\r'# +Tests.a016 :: Char +Tests.a016 = MkChar! '\SO'# +Tests.a017 :: Char +Tests.a017 = MkChar! '\SI'# +Tests.a020 :: Char +Tests.a020 = MkChar! '\DLE'# +Tests.a021 :: Char +Tests.a021 = MkChar! '\DC1'# +Tests.a022 :: Char +Tests.a022 = MkChar! '\DC2'# +Tests.a023 :: Char +Tests.a023 = MkChar! '\DC3'# +Tests.a024 :: Char +Tests.a024 = MkChar! '\DC4'# +Tests.a025 :: Char +Tests.a025 = MkChar! '\NAK'# +Tests.a026 :: Char +Tests.a026 = MkChar! '\SYN'# +Tests.a027 :: Char +Tests.a027 = MkChar! '\ETB'# +Tests.a030 :: Char +Tests.a030 = MkChar! '\CAN'# +Tests.a031 :: Char +Tests.a031 = MkChar! '\EM'# +Tests.a032 :: Char +Tests.a032 = MkChar! '\SUB'# +Tests.a033 :: Char +Tests.a033 = MkChar! '\ESC'# +Tests.a034 :: Char +Tests.a034 = MkChar! '\FS'# +Tests.a035 :: Char +Tests.a035 = MkChar! '\GS'# +Tests.a036 :: Char +Tests.a036 = MkChar! '\RS'# +Tests.a037 :: Char +Tests.a037 = MkChar! '\US'# +Tests.a040 :: Char +Tests.a040 = MkChar! ' '# +Tests.a042 :: Char +Tests.a042 = MkChar! '"'# +Tests.a047 :: Char +Tests.a047 = MkChar! '\''# +Tests.a134 :: Char +Tests.a134 = MkChar! '\\'# +Tests.a177 :: Char +Tests.a177 = MkChar! '\DEL'# +Tests.ascii :: [Char] +Tests.ascii = + "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\b\t\n\v\f\r\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\DEL"S +Tests.na200 :: Char +Tests.na200 = MkChar! '\128'# +Tests.na250 :: Char +Tests.na250 = MkChar! '¨'# +Tests.na300 :: Char +Tests.na300 = MkChar! 'À'# +Tests.na350 :: Char +Tests.na350 = MkChar! 'è'# +Tests.na377 :: Char +Tests.na377 = MkChar! 'ÿ'# +Tests.eightbit :: [Char] +Tests.eightbit = "\128¨Àèÿ"S + diff --git a/ghc/compiler/tests/deSugar/ds014a.hs b/ghc/compiler/tests/deSugar/ds014a.hs new file mode 100644 index 0000000..8ed88c0 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds014a.hs @@ -0,0 +1,4 @@ +module Tests where + +-- this char is forbidden +c = '\&' diff --git a/ghc/compiler/tests/deSugar/ds015.hs b/ghc/compiler/tests/deSugar/ds015.hs new file mode 100644 index 0000000..5c2164e --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds015.hs @@ -0,0 +1,9 @@ +--!!! ds015 -- lambdas +-- +module Tests where + +f x = ( \ x -> x ) x + +g x y = ( \ x y -> y x ) ( \ x -> x ) x + +h x y = ( \ (x:xs) -> x ) x diff --git a/ghc/compiler/tests/deSugar/ds015.stderr b/ghc/compiler/tests/deSugar/ds015.stderr new file mode 100644 index 0000000..a9ede58 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds015.stderr @@ -0,0 +1,21 @@ +Desugared: +Tests.f :: for all d. d -> d +Tests.f = /\ o89 -> \ x.106 -> (\ x.107 -> x.107) x.106 +Tests.g :: for all d, e, f. ((d -> d) -> f) -> e -> f +Tests.g = + /\ o98 o94 o97 -> \ x.108 y.109 -> + (\ x.110 y.111 -> y.111 x.110) (\ x.112 -> x.112) x.108 +Tests.h :: for all d, e. [e] -> d -> e +Tests.h = + /\ o102 t105 -> \ x.115 y.116 -> + (\ ds.117 -> + let + fail.118 = + (error t105) + "\"ds015.hs\", line 9: pattern-matching failed in lambda\n"S + in + case ds.117 of { + (:) x.119 xs.120 -> x.119 + _ -> fail.118 + }) x.115 + diff --git a/ghc/compiler/tests/deSugar/ds016.hs b/ghc/compiler/tests/deSugar/ds016.hs new file mode 100644 index 0000000..57e0053 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds016.hs @@ -0,0 +1,15 @@ +--!!! ds016 -- case expressions +-- +module Tests where + +f x y z = + case ( x ++ x ++ x ++ x ++ x ) of + [] -> [] + [a] -> error "2" + [a,b,c] -> + case ( (y,z,y,z) ) of +-- (True, _, False, _) | True == False -> z +-- (True, _, False, _) | True == False -> z + _ -> z + + (a:bs) -> error "4" diff --git a/ghc/compiler/tests/deSugar/ds016.stderr b/ghc/compiler/tests/deSugar/ds016.stderr new file mode 100644 index 0000000..31f7e7d --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds016.stderr @@ -0,0 +1,47 @@ +Desugared: +Tests.f :: for all a, d, e. [a] -> d -> [e] -> [e] +Tests.f = + /\ a o86 t97 -> \ x.119 y.120 z.121 -> + let + ds.122 = + (++ a) x.119 ((++ a) x.119 ((++ a) x.119 ((++ a) x.119 x.119))) in + let + fail.123 = + (error [t97]) + "\"ds016.hs\", line 17: pattern-matching failed in case\n"S + in + case ds.122 of { + Nil -> Nil! t97 + (:) a.124 ds.125 -> + let + fail.128 = + let bs.126 = ds.125 in + let a.127 = a.124 in (error [t97]) "4"S + in + case ds.125 of { + Nil -> (error [t97]) "2"S + (:) b.129 ds.130 -> + case ds.130 of { + (:) c.131 ds.132 -> + case ds.132 of { + Nil -> + let a.133 = a.124 in + let + ds.134 = + MkTuple4! + o86 + [t97] + o86 + [t97] + y.120 + z.121 + y.120 + z.121 + in z.121 + _ -> fail.128 + } + _ -> fail.128 + } + } + } + diff --git a/ghc/compiler/tests/deSugar/ds017.hs b/ghc/compiler/tests/deSugar/ds017.hs new file mode 100644 index 0000000..00f9884 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds017.hs @@ -0,0 +1,12 @@ +--!!! ds017 -- let expressions +-- +module Tests where + +f x y z + = let + a = x : [] + b = x : a + c = y (let d = (z, z) in d) + result = (c, b) + in + result diff --git a/ghc/compiler/tests/deSugar/ds017.stderr b/ghc/compiler/tests/deSugar/ds017.stderr new file mode 100644 index 0000000..5b5a8fc --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds017.stderr @@ -0,0 +1,10 @@ +Desugared: +Tests.f :: for all d, e, f. f -> ((d, d) -> e) -> d -> (e, [f]) +Tests.f = + /\ o86 o96 t94 -> \ x.104 y.105 z.106 -> + let a.107 = (: t94) x.104 (Nil! t94) in + let b.108 = (: t94) x.104 a.107 in + let + c.110 = y.105 (let d.109 = MkTuple2! o86 o86 z.106 z.106 in d.109) in + let result.111 = MkTuple2! o96 [t94] c.110 b.108 in result.111 + diff --git a/ghc/compiler/tests/deSugar/ds018.hs b/ghc/compiler/tests/deSugar/ds018.hs new file mode 100644 index 0000000..b5c4280 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds018.hs @@ -0,0 +1,50 @@ +--!!! ds018 -- explicit lists and tuples +-- +module Tests where + +-- exprs + +f x y z = [x,y,z,x,y,z] +f2 x y = [] + +g1 x y = () +g x y z = (x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z, + x,y,z,x,y,z) -- hey, we love big tuples + +-- pats + +fa [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] = x + +fb [] = [] + +ga (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z, + aa,ab,ac,ad,ae,af,ag,ah,ai,aj,ak,al,am, + an,ao,ap,aq,ar,as,at,au,av,aw,ax,ay,az) = x + +gb () x = x +gb2 () = () + +-- need to think of some better ones... diff --git a/ghc/compiler/tests/deSugar/ds018.stderr b/ghc/compiler/tests/deSugar/ds018.stderr new file mode 100644 index 0000000..8f8863b --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds018.stderr @@ -0,0 +1,911 @@ +Desugared: +Tests.f :: for all d. d -> d -> d -> [d] +Tests.f = + /\ o175 -> \ x.282 y.283 z.284 -> + :! o175 + x.282 + (:! o175 + y.283 + (:! o175 + z.284 + (:! o175 x.282 (:! o175 y.283 (:! o175 z.284 (Nil! o175)))))) +Tests.f2 :: for all d, e, f. d -> e -> [f] +Tests.f2 = /\ o178 o179 t180 -> \ x.285 y.286 -> Nil! t180 +Tests.g1 :: for all d, e. d -> e -> () +Tests.g1 = /\ o183 o184 -> \ x.287 y.288 -> MkTuple0 +Tests.g :: + for all d, e, f. + d + -> e + -> f + -> (d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f, + d, + e, + f) +Tests.g = + /\ o187 o188 o189 -> \ x.289 y.290 z.291 -> + MkTuple150! + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + o187 + o188 + o189 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 + x.289 + y.290 + z.291 +Tests.fa :: for all d. [d] -> d +Tests.fa = + /\ t218 -> \ ds.320 -> + let + fail.321 = + (error t218) + "\"ds018.hs\", line 39: pattern-matching failure [function binding]\n"S + in + case ds.320 of { + (:) a.322 ds.323 -> + case ds.323 of { + (:) b.324 ds.325 -> + case ds.325 of { + (:) c.326 ds.327 -> + case ds.327 of { + (:) d.328 ds.329 -> + case ds.329 of { + (:) e.330 ds.331 -> + case ds.331 of { + (:) f.332 ds.333 -> + case ds.333 of { + (:) g.334 ds.335 -> + case ds.335 of { + (:) h.336 ds.337 -> + case ds.337 of { + (:) i.338 ds.339 -> + case ds.339 of { + (:) j.340 + ds.341 -> + case + ds.341 + of { + (:) k.342 + ds.343 -> + case + ds.343 + of { + (:) l.344 + ds.345 -> + case + ds.345 + of { + (:) m.346 + ds.347 -> + case + ds.347 + of { + (:) n.348 + ds.349 -> + case + ds.349 + of { + (:) o.350 + ds.351 -> + case + ds.351 + of { + (:) p.352 + ds.353 -> + case + ds.353 + of { + (:) q.354 + ds.355 -> + case + ds.355 + of { + (:) r.356 + ds.357 -> + case + ds.357 + of { + (:) s.358 + ds.359 -> + case + ds.359 + of { + (:) t.360 + ds.361 -> + case + ds.361 + of { + (:) u.362 + ds.363 -> + case + ds.363 + of { + (:) v.364 + ds.365 -> + case + ds.365 + of { + (:) w.366 + ds.367 -> + case + ds.367 + of { + (:) x.368 + ds.369 -> + case + ds.369 + of { + (:) y.370 + ds.371 -> + case + ds.371 + of { + (:) z.372 + ds.373 -> + case + ds.373 + of { + Nil -> + x.368 + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> + fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } + _ -> fail.321 + } +Tests.fb :: for all d, e. [d] -> [e] +Tests.fb = + /\ t221 t222 -> \ ds.376 -> + let + fail.377 = + (error [t222]) + "\"ds018.hs\", line 41: pattern-matching failure [function binding]\n"S + in + case ds.376 of { + Nil -> Nil! t222 + _ -> fail.377 + } +Tests.ga :: + for all d, + e, + f, + g, + h, + i, + j, + k, + l, + m, + n, + o, + p, + q, + r, + s, + t, + u, + v, + w, + x, + y, + z0, + z1, + z2, + z3, + z4, + z5, + z6, + z7, + z8, + z9, + z10, + z11, + z12, + z13, + z14, + z15, + z16, + z17, + z18, + z19, + z20, + z21, + z22, + z23, + z24, + z25, + z26, + z27, + z28, + z29. + (d, + e, + f, + g, + h, + i, + j, + k, + l, + m, + n, + o, + p, + q, + r, + s, + t, + u, + v, + w, + x, + y, + z0, + z29, + z1, + z2, + z3, + z4, + z5, + z6, + z7, + z8, + z9, + z10, + z11, + z12, + z13, + z14, + z15, + z16, + z17, + z18, + z19, + z20, + z21, + z22, + z23, + z24, + z25, + z26, + z27, + z28) + -> z29 +Tests.ga = + /\ o225 + o226 + o227 + o228 + o229 + o230 + o231 + o232 + o233 + o234 + o235 + o236 + o237 + o238 + o239 + o240 + o241 + o242 + o243 + o244 + o245 + o246 + o247 + o249 + o250 + o251 + o252 + o253 + o254 + o255 + o256 + o257 + o258 + o259 + o260 + o261 + o262 + o263 + o264 + o265 + o266 + o267 + o268 + o269 + o270 + o271 + o272 + o273 + o274 + o275 + o276 + o248 -> \ ds.380 -> + let + fail.381 = + (error o248) + "\"ds018.hs\", line 45: pattern-matching failure [function binding]\n"S + in + case ds.380 of { + MkTuple52 a.382 + b.383 + c.384 + d.385 + e.386 + f.387 + g.388 + h.389 + i.390 + j.391 + k.392 + l.393 + m.394 + n.395 + o.396 + p.397 + q.398 + r.399 + s.400 + t.401 + u.402 + v.403 + w.404 + x.405 + y.406 + z.407 + aa.408 + ab.409 + ac.410 + ad.411 + ae.412 + af.413 + ag.414 + ah.415 + ai.416 + aj.417 + ak.418 + al.419 + am.420 + an.421 + ao.422 + ap.423 + aq.424 + ar.425 + as.426 + at.427 + au.428 + av.429 + aw.430 + ax.431 + ay.432 + az.433 -> x.405 + } +Tests.gb :: for all d. () -> d -> d +Tests.gb = + /\ o279 -> \ ds.436 x.437 -> + let + fail.438 = + (error o279) + "\"ds018.hs\", line 47: pattern-matching failure [function binding]\n"S + in + case ds.436 of { + MkTuple0 -> x.437 + } +Tests.gb2 :: () -> () +Tests.gb2 = + \ ds.441 -> + let + fail.442 = + (error ()) + "\"ds018.hs\", line 48: pattern-matching failure [function binding]\n"S + in + case ds.441 of { + MkTuple0 -> MkTuple0 + } + diff --git a/ghc/compiler/tests/deSugar/ds019.hs b/ghc/compiler/tests/deSugar/ds019.hs new file mode 100644 index 0000000..32400dd --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds019.hs @@ -0,0 +1,8 @@ +--!!! ds019 -- mixed var and uni-constructor pats + +module Test where + +f (a,b,c) i o = [] +f d (j,k) p = [] +f (e,f,g) l q = [] +f h (m,n) r = [] diff --git a/ghc/compiler/tests/deSugar/ds019.stderr b/ghc/compiler/tests/deSugar/ds019.stderr new file mode 100644 index 0000000..f0300f3 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds019.stderr @@ -0,0 +1,34 @@ +Desugared: +Test.f :: for all d, e, f, g, h, i, j. (d, e, f) -> (g, h) -> i -> [j] +Test.f = + /\ o105 o106 o107 o112 o113 o114 t115 -> \ ds.121 i.122 o.123 -> + let + fail.124 = + (error [t115]) + "\"ds019.hs\", line 8: pattern-matching failure [function binding]\n"S in + let + fail.140 = + let + fail.135 = + let + fail.129 = + case i.122 of { + MkTuple2 m.125 n.126 -> + let r.127 = o.123 in + let h.128 = ds.121 in Nil! t115 + } + in + case ds.121 of { + MkTuple3 e.130 f.131 g.132 -> + let q.133 = o.123 in let l.134 = i.122 in Nil! t115 + } + in + case i.122 of { + MkTuple2 j.136 k.137 -> + let p.138 = o.123 in let d.139 = ds.121 in Nil! t115 + } + in + case ds.121 of { + MkTuple3 a.141 b.142 c.143 -> Nil! t115 + } + diff --git a/ghc/compiler/tests/deSugar/ds020.hs b/ghc/compiler/tests/deSugar/ds020.hs new file mode 100644 index 0000000..ac6ea8d --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds020.hs @@ -0,0 +1,52 @@ +--!!! ds020 -- lazy patterns (in detail) +-- +module Test where + +a ~([],[],[]) = [] +a ~(~[],~[],~[]) = [] + +b ~(x:xs:ys) = [] +b ~(~x: ~xs: ~ys) = [] + +c ~x ~ _ ~11111 ~3.14159265 = x + +d 11 = 4 +d 12 = 3 +d ~(n+4) = 2 +d ~(n+43) = 1 +d ~(n+999) = 0 + +f ~(x@[]) = [] +f x@(~[]) = [] + +g ~(~(~(~([])))) = [] + +-- pattern bindings (implicitly lazy) + +([],[],[]) = ([],[],[]) +(~[],~[],~[]) = ([],[],[]) + +(x1: xs1: ys1) = [] +(~x: ~xs: ~ys) = [] + +(x2 : xs2: ys2) | eq2 = [] + | eq3 = [x2] + | eq4 = [x2] + | True = [] + where + eq2 = (2::Int) == (4::Int) + eq3 = (3::Int) == (3::Int) + eq4 = (4::Int) == (2::Int) + +(x3,y3) | x3 > 3 = (4, 5) + | x3 <= 3 = (2, 3) +-- above: x & y should both be \bottom. + +(x4,(y4,(z4,a4))) | eq2 = ('a',('a',('a','a'))) + | eq3 = ('b',('b',('b','b'))) + | eq4 = ('c',('c',('c','c'))) + | True = ('d',('d',('d','d'))) + where + eq2 = (2::Int) == (4::Int) + eq3 = (3::Int) == (3::Int) + eq4 = (4::Int) == (2::Int) diff --git a/ghc/compiler/tests/deSugar/ds020.stderr b/ghc/compiler/tests/deSugar/ds020.stderr new file mode 100644 index 0000000..5c0371c --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds020.stderr @@ -0,0 +1,464 @@ +Desugared: +Test.a :: for all d, e, f, g. ([d], [e], [f]) -> [g] +Test.a = /\ t118 t119 t120 t121 -> \ ds.314 -> Nil! t121 +Test.b :: for all d, e. [d] -> [e] +Test.b = + /\ t134 t135 -> \ ds.323 -> + let + x.328 = + case ds.323 of { + (:) x.324 ds.325 -> + case ds.325 of { + (:) xs.326 ys.327 -> x.324 + _ -> + (error Char) + "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } in + let + xs.333 = + case ds.323 of { + (:) x.329 ds.330 -> + case ds.330 of { + (:) xs.331 ys.332 -> xs.331 + _ -> + (error Char) + "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } in + let + ys.338 = + case ds.323 of { + (:) x.334 ds.335 -> + case ds.335 of { + (:) xs.336 ys.337 -> ys.337 + _ -> + (error Char) + "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + in Nil! t135 +Test.c :: for all d, e, f, g. -> -> g -> d -> e -> f -> g +Test.c = + /\ o139 t140 t143 o138 -> \ dict.144 dict.141 -> + let + dict.145 = (sdsel.Num.Eq t143) ((sdsel.Fractional.Num t143) dict.144) in + let dict.142 = (sdsel.Num.Eq t140) dict.141 in + let c.137 = \ x.87 ds.339 ds.340 ds.341 -> let x.87 = x.87 in x.87 + in c.137 +Test.d :: for all d, e. -> -> -> d -> e +Test.d = + /\ t171 t174 -> \ dict.175 dict.173 dict.172 -> + let dict.169 = dict.175 in + let dict.163 = dict.169 in + let dict.157 = dict.163 in + let dict.152 = dict.157 in + let dict.166 = dict.172 in + let dict.160 = dict.166 in + let dict.154 = dict.160 in + let dict.149 = dict.154 in + let dict.167 = dict.173 in + let dict.161 = dict.167 in + let dict.155 = (sdsel.Ord.Eq t171) dict.161 in + let dict.150 = dict.155 in + let + d.147 = + \ ds.344 -> + let + fail.345 = + (error t174) + "\"ds020.hs\", line 17: pattern-matching failure [function binding]\n"S in + let + fail.349 = + let + n.88 = + let + n.346 = + (fromInteger t171) dict.160 (MkInteger! 4##) + in + case + ((>= t171) + dict.161 + ds.344 + ((fromInteger t171) + dict.160 (MkInteger! 4##))) + of { + True -> + let + n.88 = + (- t171) + dict.160 + ds.344 + ((fromInteger t171) + dict.160 (MkInteger! 4##)) + in n.88 + False -> + (error Char) + "``impossible'' pattern-matching error!\n"S + } + in (fromInteger t174) dict.163 (MkInteger! 2##) + in + case + ((== t171) + dict.150 + ((fromInteger t171) dict.149 (MkInteger! 11##)) + ds.344) + of { + True -> (fromInteger t174) dict.152 (MkInteger! 4##) + False -> + case + ((== t171) + dict.155 + ((fromInteger t171) + dict.154 (MkInteger! 12##)) + ds.344) + of { + True -> (fromInteger t174) dict.157 (MkInteger! 3##) + False -> fail.349 + } + } + in d.147 +Test.f :: for all d, e. [d] -> [e] +Test.f = + /\ t182 t183 -> \ x.352 -> + let + x.353 = + case x.352 of { + Nil -> x.352 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + in Nil! t183 +Test.g :: for all d, e. [d] -> [e] +Test.g = /\ t186 t187 -> \ ds.356 -> Nil! t187 +ds.357 :: ([t191], [t192], [t193]) +ds.357 = MkTuple3! [t191] [t192] [t193] (Nil! t191) (Nil! t192) (Nil! t193) +ds.358 :: ([t197], [t198], [t199]) +ds.358 = MkTuple3! [t197] [t198] [t199] (Nil! t197) (Nil! t198) (Nil! t199) +ds.359 :: [t208] +ds.359 = /\ t208 -> Nil! t208 +Test.x1 :: for all d. d +Test.x1 = + /\ t208 -> + case ds.359 of { + (:) x1.363 ds.364 -> + case ds.364 of { + (:) xs1.365 ys1.366 -> x1.363 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +Test.xs1 :: for all d. d +Test.xs1 = + /\ t208 -> + case ds.359 of { + (:) x1.367 ds.368 -> + case ds.368 of { + (:) xs1.369 ys1.370 -> xs1.369 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +Test.ys1 :: for all d. [d] +Test.ys1 = + /\ t208 -> + case ds.359 of { + (:) x1.371 ds.372 -> + case ds.372 of { + (:) xs1.373 ys1.374 -> ys1.374 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +ds.375 :: [t217] +ds.375 = /\ t217 -> Nil! t217 +Test.x :: for all d. d +Test.x = + /\ t217 -> + case ds.375 of { + (:) x.379 ds.380 -> + case ds.380 of { + (:) xs.381 ys.382 -> + let ys.383 = ys.382 in + let xs.384 = xs.381 in let x.385 = x.379 in x.385 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +Test.xs :: for all d. d +Test.xs = + /\ t217 -> + case ds.375 of { + (:) x.386 ds.387 -> + case ds.387 of { + (:) xs.388 ys.389 -> + let ys.390 = ys.389 in + let xs.391 = xs.388 in let x.392 = x.386 in xs.391 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +Test.ys :: for all d. [d] +Test.ys = + /\ t217 -> + case ds.375 of { + (:) x.393 ds.394 -> + case ds.394 of { + (:) xs.395 ys.396 -> + let ys.397 = ys.396 in + let xs.398 = xs.395 in let x.399 = x.393 in ys.397 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +{- plain CoRec -} +ds.406 :: [t254] +ds.406 = + /\ t254 -> + let dict.410 = dfun.Eq.Int in + let + eq2.413 = + eqInt + (let dict.411 = dfun.Num.Int in MkInt! 2#) + (let dict.412 = dfun.Num.Int in MkInt! 4#) in + let dict.414 = dfun.Eq.Int in + let + eq3.417 = + eqInt + (let dict.415 = dfun.Num.Int in MkInt! 3#) + (let dict.416 = dfun.Num.Int in MkInt! 3#) in + let dict.418 = dfun.Eq.Int in + let + eq4.421 = + eqInt + (let dict.419 = dfun.Num.Int in MkInt! 4#) + (let dict.420 = dfun.Num.Int in MkInt! 2#) + in + case eq2.413 of { + True -> Nil! t254 + False -> + case eq3.417 of { + True -> :! t254 (Test.x2 t254) (Nil! t254) + False -> + case eq4.421 of { + True -> :! t254 (Test.x2 t254) (Nil! t254) + False -> Nil! t254 + } + } + } +Test.x2 :: for all d. d +Test.x2 = + /\ t254 -> + case ds.406 of { + (:) x2.422 ds.423 -> + case ds.423 of { + (:) xs2.424 ys2.425 -> x2.422 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +Test.xs2 :: for all d. d +Test.xs2 = + /\ t254 -> + case ds.406 of { + (:) x2.426 ds.427 -> + case ds.427 of { + (:) xs2.428 ys2.429 -> xs2.428 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +Test.ys2 :: for all d. [d] +Test.ys2 = + /\ t254 -> + case ds.406 of { + (:) x2.430 ds.431 -> + case ds.431 of { + (:) xs2.432 ys2.433 -> ys2.433 + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } + _ -> (error Char) "``impossible'' pattern-matching error!\n"S + } +{- end plain CoRec -} +ds.435 :: for all d, e. -> -> -> (d, e) +ds.435 = + /\ t273 t275 -> \ dict.276 dict.269 dict.274 -> + let dict.267 = dict.276 in + let dict.271 = dict.274 in + let dict.265 = dict.271 in + let dict.262 = dict.265 in + let dict.260 = dict.269 + in + let + {- CoRec -} + ds.434 = + case + ((> t273) + dict.260 + x3.257 + ((fromInteger t273) dict.262 (MkInteger! 3##))) + of { + True -> + MkTuple2! + t273 + t275 + ((fromInteger t273) dict.265 (MkInteger! 4##)) + ((fromInteger t275) dict.267 (MkInteger! 5##)) + False -> + case + ((<= t273) + dict.269 + x3.257 + ((fromInteger t273) dict.271 (MkInteger! 3##))) + of { + True -> + MkTuple2! + t273 + t275 + ((fromInteger t273) dict.274 (MkInteger! 2##)) + ((fromInteger t275) dict.276 (MkInteger! 3##)) + False -> + (error (t273, t275)) + "\"ds020.hs\", line 42: pattern-matching failure [pat binding]\n"S + } + } + x3.257 = + case ds.434 of { + MkTuple2 x3.257 y3.258 -> x3.257 + } + y3.258 = + case ds.434 of { + MkTuple2 x3.257 y3.258 -> y3.258 + } + {- end CoRec -} + in MkTuple2! t273 t275 x3.257 y3.258 +Test.x3 :: for all d, e. -> -> -> d +Test.x3 = + /\ t273 t275 -> \ dict.276 dict.269 dict.274 -> + case (((ds.435 t273) t275) dict.276 dict.269 dict.274) of { + MkTuple2 x3.257 y3.258 -> x3.257 + } +Test.y3 :: for all d, e. -> -> -> e +Test.y3 = + /\ t273 t275 -> \ dict.276 dict.269 dict.274 -> + case (((ds.435 t273) t275) dict.276 dict.269 dict.274) of { + MkTuple2 x3.257 y3.258 -> y3.258 + } +ds.442 :: (Char, (Char, (Char, Char))) +ds.442 = + let dict.451 = dfun.Eq.Int in + let + eq2.454 = + eqInt + (let dict.452 = dfun.Num.Int in MkInt! 2#) + (let dict.453 = dfun.Num.Int in MkInt! 4#) in + let dict.455 = dfun.Eq.Int in + let + eq3.458 = + eqInt + (let dict.456 = dfun.Num.Int in MkInt! 3#) + (let dict.457 = dfun.Num.Int in MkInt! 3#) in + let dict.459 = dfun.Eq.Int in + let + eq4.462 = + eqInt + (let dict.460 = dfun.Num.Int in MkInt! 4#) + (let dict.461 = dfun.Num.Int in MkInt! 2#) + in + case eq2.454 of { + True -> + MkTuple2! + Char + (Char, (Char, Char)) + (MkChar! 'a'#) + (MkTuple2! + Char + (Char, Char) + (MkChar! 'a'#) + (MkTuple2! Char Char (MkChar! 'a'#) (MkChar! 'a'#))) + False -> + case eq3.458 of { + True -> + MkTuple2! + Char + (Char, (Char, Char)) + (MkChar! 'b'#) + (MkTuple2! + Char + (Char, Char) + (MkChar! 'b'#) + (MkTuple2! Char Char (MkChar! 'b'#) (MkChar! 'b'#))) + False -> + case eq4.462 of { + True -> + MkTuple2! + Char + (Char, (Char, Char)) + (MkChar! 'c'#) + (MkTuple2! + Char + (Char, Char) + (MkChar! 'c'#) + (MkTuple2! + Char Char (MkChar! 'c'#) (MkChar! 'c'#))) + False -> + MkTuple2! + Char + (Char, (Char, Char)) + (MkChar! 'd'#) + (MkTuple2! + Char + (Char, Char) + (MkChar! 'd'#) + (MkTuple2! + Char Char (MkChar! 'd'#) (MkChar! 'd'#))) + } + } + } +Test.x4 :: Char +Test.x4 = + case ds.442 of { + MkTuple2 x4.463 ds.464 -> + case ds.464 of { + MkTuple2 y4.465 ds.466 -> + case ds.466 of { + MkTuple2 z4.467 a4.468 -> x4.463 + } + } + } +Test.y4 :: Char +Test.y4 = + case ds.442 of { + MkTuple2 x4.469 ds.470 -> + case ds.470 of { + MkTuple2 y4.471 ds.472 -> + case ds.472 of { + MkTuple2 z4.473 a4.474 -> y4.471 + } + } + } +Test.z4 :: Char +Test.z4 = + case ds.442 of { + MkTuple2 x4.475 ds.476 -> + case ds.476 of { + MkTuple2 y4.477 ds.478 -> + case ds.478 of { + MkTuple2 z4.479 a4.480 -> z4.479 + } + } + } +Test.a4 :: Char +Test.a4 = + case ds.442 of { + MkTuple2 x4.481 ds.482 -> + case ds.482 of { + MkTuple2 y4.483 ds.484 -> + case ds.484 of { + MkTuple2 z4.485 a4.486 -> a4.486 + } + } + } + diff --git a/ghc/compiler/tests/deSugar/ds021.hs b/ghc/compiler/tests/deSugar/ds021.hs new file mode 100644 index 0000000..f7e9392 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds021.hs @@ -0,0 +1,8 @@ +--!!! ds021 -- hairier uses of guards + +module Test where + +f x y z | x == y = [] + | x /= z = [] + | True = [] + | False = [] diff --git a/ghc/compiler/tests/deSugar/ds021.stderr b/ghc/compiler/tests/deSugar/ds021.stderr new file mode 100644 index 0000000..364d61b --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds021.stderr @@ -0,0 +1,23 @@ +Desugared: +Test.f :: for all d, e. -> d -> d -> d -> [e] +Test.f = + /\ t86 t91 -> \ dict.87 -> + let dict.83 = dict.87 in + let + f.78 = + \ x.61 y.62 z.63 -> + let + fail.92 = + (error [t91]) + "\"ds021.hs\", line 8: pattern-matching failure [function binding]\n"S + in + case ((== t86) dict.83 x.61 y.62) of { + True -> Nil! t91 + False -> + case ((/= t86) dict.87 x.61 z.63) of { + True -> Nil! t91 + False -> Nil! t91 + } + } + in f.78 + diff --git a/ghc/compiler/tests/deSugar/ds022.hs b/ghc/compiler/tests/deSugar/ds022.hs new file mode 100644 index 0000000..ce07e19 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds022.hs @@ -0,0 +1,32 @@ +--!!! ds022 -- literal patterns (wimp version) +-- +module Tests where + +f 1 1.1 = [] +f 2 2.2 = [] +f 3 3.3 = [] +f 4 4.4 = [] + +g 11111111111111111111111 1.11111111111111111 = [] +g 22222222222222222222222 2.22222222222222222 = [] +g 33333333333333333333333 3.33333333333333333 = [] +g 44444444444444444444444 4.44444444444444444 = [] + +h 'a' "" = [] +h '\'' "foo" = [] +h '"' ('b':'a':'r':[]) = [] +h '\o250' blob = [] + +i 1 1.1 = [] +i 2 2.2 = [] +i 1 0.011e2 = [] +i 2 2.20000 = [] + +{- +j one@1 oneone@1.1 + | ((fromFloat oneone) - (fromIntegral (fromInt one))) + /= (fromIntegral (fromInt 0)) = [] +j two@2 twotwo@2.2 + | ((fromFloat twotwo) * (fromIntegral (fromInt 2))) + == (fromIntegral (fromInt 4.4)) = [] +-} diff --git a/ghc/compiler/tests/deSugar/ds022.stderr b/ghc/compiler/tests/deSugar/ds022.stderr new file mode 100644 index 0000000..cb1e587 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds022.stderr @@ -0,0 +1,368 @@ +Desugared: +Tests.f :: for all d, e, f. -> -> d -> e -> [f] +Tests.f = + /\ t101 t104 t107 -> \ dict.105 dict.102 -> + let dict.98 = dict.105 in + let dict.91 = dict.98 in + let dict.84 = dict.91 in + let + dict.106 = (sdsel.Num.Eq t104) ((sdsel.Fractional.Num t104) dict.84) in + let dict.99 = dict.106 in + let dict.92 = dict.99 in + let dict.85 = dict.92 in + let dict.95 = dict.102 in + let dict.88 = dict.95 in + let dict.81 = dict.88 in + let dict.103 = (sdsel.Num.Eq t101) dict.81 in + let dict.96 = dict.103 in + let dict.89 = dict.96 in + let dict.82 = dict.89 in + let + f.79 = + \ ds.179 ds.180 -> + let + fail.181 = + (error [t107]) + "\"ds022.hs\", line 10: pattern-matching failure [function binding]\n"S + in + case + ((== t101) + dict.82 + ((fromInteger t101) dict.81 (MkInteger! 1##)) + ds.179) + of { + True -> + case + ((== t104) + dict.85 + ((fromRational t104) + dict.84 (MkDouble! 1.1000000000000001##)) + ds.180) + of { + True -> Nil! t107 + False -> fail.181 + } + False -> + case + ((== t101) + dict.89 + ((fromInteger t101) dict.88 (MkInteger! 2##)) + ds.179) + of { + True -> + case + ((== t104) + dict.92 + ((fromRational t104) + dict.91 + (MkDouble! 2.2000000000000002##)) + ds.180) + of { + True -> Nil! t107 + False -> fail.181 + } + False -> + case + ((== t101) + dict.96 + ((fromInteger t101) + dict.95 (MkInteger! 3##)) + ds.179) + of { + True -> + case + ((== t104) + dict.99 + ((fromRational t104) + dict.98 + (MkDouble! + 3.2999999999999998##)) + ds.180) + of { + True -> Nil! t107 + False -> fail.181 + } + False -> + case + ((== t101) + dict.103 + ((fromInteger t101) + dict.102 (MkInteger! 4##)) + ds.179) + of { + True -> + case + ((== t104) + dict.106 + ((fromRational t104) + dict.105 + (MkDouble! + 4.4000000000000004##)) + ds.180) + of { + True -> Nil! t107 + False -> fail.181 + } + False -> fail.181 + } + } + } + } + in f.79 +Tests.g :: for all d, e, f. -> -> d -> e -> [f] +Tests.g = + /\ t131 t134 t137 -> \ dict.135 dict.132 -> + let dict.128 = dict.135 in + let dict.121 = dict.128 in + let dict.114 = dict.121 in + let + dict.136 = (sdsel.Num.Eq t134) ((sdsel.Fractional.Num t134) dict.114) in + let dict.129 = dict.136 in + let dict.122 = dict.129 in + let dict.115 = dict.122 in + let dict.125 = dict.132 in + let dict.118 = dict.125 in + let dict.111 = dict.118 in + let dict.133 = (sdsel.Num.Eq t131) dict.111 in + let dict.126 = dict.133 in + let dict.119 = dict.126 in + let dict.112 = dict.119 in + let + g.109 = + \ ds.183 ds.184 -> + let + fail.185 = + (error [t137]) + "\"ds022.hs\", line 15: pattern-matching failure [function binding]\n"S + in + case + ((== t131) + dict.112 + ((fromInteger t131) + dict.111 + (MkInteger! 11111111111111111111111##)) + ds.183) + of { + True -> + case + ((== t134) + dict.115 + ((fromRational t134) + dict.114 + (MkDouble! 1.1111111111111112##)) + ds.184) + of { + True -> Nil! t137 + False -> fail.185 + } + False -> + case + ((== t131) + dict.119 + ((fromInteger t131) + dict.118 + (MkInteger! 22222222222222222222222##)) + ds.183) + of { + True -> + case + ((== t134) + dict.122 + ((fromRational t134) + dict.121 + (MkDouble! 2.2222222222222223##)) + ds.184) + of { + True -> Nil! t137 + False -> fail.185 + } + False -> + case + ((== t131) + dict.126 + ((fromInteger t131) + dict.125 + (MkInteger! + 33333333333333333333333##)) + ds.183) + of { + True -> + case + ((== t134) + dict.129 + ((fromRational t134) + dict.128 + (MkDouble! + 3.3333333333333335##)) + ds.184) + of { + True -> Nil! t137 + False -> fail.185 + } + False -> + case + ((== t131) + dict.133 + ((fromInteger t131) + dict.132 + (MkInteger! + 44444444444444444444444##)) + ds.183) + of { + True -> + case + ((== t134) + dict.136 + ((fromRational t134) + dict.135 + (MkDouble! + 4.4444444444444446##)) + ds.184) + of { + True -> Nil! t137 + False -> fail.185 + } + False -> fail.185 + } + } + } + } + in g.109 +Tests.h :: for all d. Char -> [Char] -> [d] +Tests.h = + /\ t148 -> \ ds.200 ds.201 -> + let + fail.202 = + (error [t148]) + "\"ds022.hs\", line 20: pattern-matching failure [function binding]\n"S + in + case ds.200 of { + MkChar ds.203 -> + case ds.203 of { + 'a'# -> + case (eqString (Nil! Char) ds.201) of { + True -> Nil! t148 + False -> fail.202 + } + '\''# -> + case (eqString "foo"S ds.201) of { + True -> Nil! t148 + False -> fail.202 + } + '"'# -> + case ds.201 of { + (:) ds.204 ds.205 -> + case ds.204 of { + MkChar ds.206 -> + case ds.206 of { + 'b'# -> + case ds.205 of { + (:) ds.207 ds.208 -> + case ds.207 of { + MkChar ds.209 -> + case ds.209 of { + 'a'# -> + case ds.208 of { + (:) ds.210 ds.211 -> + case ds.210 of { + MkChar ds.212 -> + case + ds.212 + of { + 'r'# -> + case + ds.211 + of { + Nil -> + Nil! t148 + _ -> + fail.202 + } + _ -> + fail.202 + } + } + _ -> fail.202 + } + _ -> fail.202 + } + } + _ -> fail.202 + } + _ -> fail.202 + } + } + _ -> fail.202 + } + '¨'# -> let blob.213 = ds.201 in Nil! t148 + _ -> fail.202 + } + } +Tests.i :: for all d, e, f. -> -> d -> e -> [f] +Tests.i = + /\ t172 t175 t178 -> \ dict.176 dict.173 -> + let dict.169 = dict.176 in + let dict.162 = dict.169 in + let dict.155 = dict.162 in + let + dict.177 = (sdsel.Num.Eq t175) ((sdsel.Fractional.Num t175) dict.155) in + let dict.170 = dict.177 in + let dict.163 = dict.170 in + let dict.156 = dict.163 in + let dict.166 = dict.173 in + let dict.159 = dict.166 in + let dict.152 = dict.159 in + let dict.174 = (sdsel.Num.Eq t172) dict.152 in + let dict.167 = dict.174 in + let dict.160 = dict.167 in + let dict.153 = dict.160 in + let + i.150 = + \ ds.214 ds.215 -> + let + fail.216 = + (error [t178]) + "\"ds022.hs\", line 25: pattern-matching failure [function binding]\n"S + in + case + ((== t172) + dict.153 + ((fromInteger t172) dict.152 (MkInteger! 1##)) + ds.214) + of { + True -> + case + ((== t175) + dict.156 + ((fromRational t175) + dict.155 + (MkDouble! 1.1000000000000001##)) + ds.215) + of { + True -> Nil! t178 + False -> fail.216 + } + False -> + case + ((== t172) + dict.160 + ((fromInteger t172) dict.159 (MkInteger! 2##)) + ds.214) + of { + True -> + case + ((== t175) + dict.163 + ((fromRational t175) + dict.162 + (MkDouble! 2.2000000000000002##)) + ds.215) + of { + True -> Nil! t178 + False -> fail.216 + } + False -> fail.216 + } + } + in i.150 + diff --git a/ghc/compiler/tests/deSugar/ds023.hs b/ghc/compiler/tests/deSugar/ds023.hs new file mode 100644 index 0000000..ecd6e13 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds023.hs @@ -0,0 +1,7 @@ +--!!! ds023 -- overloading eg from section 9.2 +-- +module Tests where + +f x = g (x == x) x +g b x = abs (f x) +--g b x = (f x) + (f x) diff --git a/ghc/compiler/tests/deSugar/ds023.stderr b/ghc/compiler/tests/deSugar/ds023.stderr new file mode 100644 index 0000000..fd3aaec --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds023.stderr @@ -0,0 +1,12 @@ +Desugared: +{- plain CoRec -} +Tests.f :: for all d, e. -> -> d -> e +Tests.f = + /\ t83 t90 -> \ dict.91 dict.84 x.93 -> + ((Tests.g t83) t90) dict.91 dict.84 ((== t83) dict.84 x.93 x.93) x.93 +Tests.g :: for all d, e. -> -> Bool -> d -> e +Tests.g = + /\ t83 t90 -> \ dict.91 dict.84 b.94 x.95 -> + (abs t90) dict.91 (((Tests.f t83) t90) dict.91 dict.84 x.95) +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds024.hs b/ghc/compiler/tests/deSugar/ds024.hs new file mode 100644 index 0000000..1e5f7eb --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds024.hs @@ -0,0 +1,8 @@ +--!!! ds024 -- correct types on ConPatOuts + +-- do all the right types get stuck on all the +-- Nils and Conses? + +f x = [[], []] + +g x = ([], [], []) diff --git a/ghc/compiler/tests/deSugar/ds024.stderr b/ghc/compiler/tests/deSugar/ds024.stderr new file mode 100644 index 0000000..cb012f9 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds024.stderr @@ -0,0 +1,10 @@ +Desugared: +Main.f :: for all d, e. d -> [[e]] +Main.f = + /\ o79 t81 -> \ x.88 -> + :! [t81] (Nil! t81) (:! [t81] (Nil! t81) (Nil! [t81])) +Main.g :: for all d, e, f, g. d -> ([e], [f], [g]) +Main.g = + /\ o84 t85 t86 t87 -> \ x.89 -> + MkTuple3! [t85] [t86] [t87] (Nil! t85) (Nil! t86) (Nil! t87) + diff --git a/ghc/compiler/tests/deSugar/ds025.hs b/ghc/compiler/tests/deSugar/ds025.hs new file mode 100644 index 0000000..c28b16d --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds025.hs @@ -0,0 +1,18 @@ +--!!! ds025 -- overloaded assoc -- AbsBinds + +module Util where + +ehead xs loc | null xs = error ("4"++loc) + | True = head xs + +assoc key lst loc + = if (null res) then error ("1"++loc++"2"++(show key)) + else (ehead res "3") + where res = [ val | (key',val) <- lst, key==key'] + +assocMaybe :: (Eq a) => a -> [(a,b)] -> Maybe b +assocMaybe key lst + = if (null res) then Nothing else (Just (head res)) + where res = [ val | (key',val) <- lst, key==key'] + +data Maybe a = Just a | Nothing deriving () diff --git a/ghc/compiler/tests/deSugar/ds025.stderr b/ghc/compiler/tests/deSugar/ds025.stderr new file mode 100644 index 0000000..72e8c67 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds025.stderr @@ -0,0 +1,84 @@ +Desugared: +Util.ehead :: for all a. [a] -> [Char] -> a +Util.ehead = + /\ a -> \ xs.152 loc.153 -> + let + fail.154 = + (error a) + "\"ds025.hs\", line 8: pattern-matching failure [function binding]\n"S + in + case ((null a) xs.152) of { + True -> (error a) ((++ Char) "4"S loc.153) + False -> (head a) xs.152 + } +Util.assoc :: for all a, a. -> -> a -> [(a, a)] -> [Char] -> a +Util.assoc = + /\ a a -> \ dict.120 dict.128 key.165 lst.166 loc.167 -> + let + res.174 = + let + {- CoRec -} + ds.168 = + \ ds.169 -> + case ds.169 of { + Nil -> Nil a + (:) ds.170 ds.171 -> + case ds.170 of { + MkTuple2 key'.172 val.173 -> + case ((== a) dict.120 key.165 key'.172) of { + True -> (: a) val.173 (ds.168 ds.171) + False -> ds.168 ds.171 + } + } + } + {- end CoRec -} + in ds.168 lst.166 + in + case ((null a) res.174) of { + True -> + (error a) + ((++ Char) + "1"S + ((++ Char) + loc.167 + ((++ Char) "2"S ((show a) dict.128 key.165)))) + False -> (Util.ehead a) res.174 "3"S + } +Util.assocMaybe :: for all a, b. -> a -> [(a, b)] -> Util.Maybe b +Util.assocMaybe = + /\ a b -> \ dict.150 -> + let dict.142 = dict.150 in + let + assocMaybe.134 = + \ key.80 lst.81 -> + let + res.82 = + let + {- CoRec -} + ds.179 = + \ ds.180 -> + case ds.180 of { + Nil -> Nil b + (:) ds.181 ds.182 -> + case ds.181 of { + MkTuple2 key'.183 val.184 -> + case + ((== a) + dict.142 key.80 key'.183) + of { + True -> + (: b) + val.184 (ds.179 ds.182) + False -> ds.179 ds.182 + } + } + } + {- end CoRec -} + in ds.179 lst.81 + in + case ((null b) res.82) of { + True -> Util.Nothing b + False -> (Util.Just b) ((head b) res.82) + } + in assocMaybe.134 + diff --git a/ghc/compiler/tests/deSugar/ds026.hs b/ghc/compiler/tests/deSugar/ds026.hs new file mode 100644 index 0000000..2f9faa7 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds026.hs @@ -0,0 +1,12 @@ +--!!! ds026 -- classes -- incl. polymorphic method + +class Foo a where + op :: a -> a + +class Foo a => Boo a where + op1 :: a -> a + +class Boo a => Noo a where + op2 :: (Eq b) => a -> b -> a + +f x y = op (op2 x y) diff --git a/ghc/compiler/tests/deSugar/ds026.stderr b/ghc/compiler/tests/deSugar/ds026.stderr new file mode 100644 index 0000000..bb52796 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds026.stderr @@ -0,0 +1,49 @@ +Desugared: +defm.Main.Boo.op1 :: for all a. -> a -> a +defm.Main.Boo.op1 = /\ a -> (error (a -> a)) "No default method for \"op1\"\n"S +Main.Boo.op1 :: for all a. -> a -> a +Main.Boo.op1 = + /\ a -> \ ds.113 -> + case ds.113 of { + MkTuple2 dict.84 op1.83 -> op1.83 + } +sdsel.Main.Boo.Main.Foo :: for all a. -> +sdsel.Main.Boo.Main.Foo = + /\ a -> \ ds.114 -> + case ds.114 of { + MkTuple2 dict.87 op1.86 -> dict.87 + } +defm.Main.Foo.op :: for all a. -> a -> a +defm.Main.Foo.op = /\ a -> (error (a -> a)) "No default method for \"op\"\n"S +Main.Foo.op :: for all a. -> a -> a +Main.Foo.op = /\ a -> \ op.90 -> op.90 +defm.Main.Noo.op2 :: for all a, b. -> -> a -> b -> a +defm.Main.Noo.op2 = + /\ a b -> \ dict.102 -> + (error (a -> b -> a)) "No default method for \"op2\"\n"S +Main.Noo.op2 :: for all a, b. -> -> a -> b -> a +Main.Noo.op2 = + /\ a b -> \ ds.115 -> + case ds.115 of { + MkTuple2 dict.94 op2.93 -> op2.93 b + } +sdsel.Main.Noo.Main.Boo :: for all a. -> +sdsel.Main.Noo.Main.Boo = + /\ a -> \ ds.116 -> + case ds.116 of { + MkTuple2 dict.98 op2.97 -> dict.98 + } +Main.f :: for all b, a. -> -> a -> b -> a +Main.f = + /\ b a -> \ dict.112 dict.111 -> + let + dict.108 = + (sdsel.Main.Boo.Main.Foo a) ((sdsel.Main.Noo.Main.Boo a) dict.111) in + let + f.104 = + \ x.68 y.69 -> + (Main.Foo.op a) + dict.108 + (((Main.Noo.op2 a) b) dict.111 dict.112 x.68 y.69) + in f.104 + diff --git a/ghc/compiler/tests/deSugar/ds027.hs b/ghc/compiler/tests/deSugar/ds027.hs new file mode 100644 index 0000000..99a4d93 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds027.hs @@ -0,0 +1,9 @@ +--!!! ds027 -- simple instances +-- +module Test where + +data Foo = Bar | Baz + +instance Eq Foo where + Bar == Baz = True + Bar /= Baz = False diff --git a/ghc/compiler/tests/deSugar/ds027.stderr b/ghc/compiler/tests/deSugar/ds027.stderr new file mode 100644 index 0000000..0b5be11 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds027.stderr @@ -0,0 +1,44 @@ +Desugared: +{- plain CoRec -} +dfun.Eq.Test.Foo :: +dfun.Eq.Test.Foo = + let + ==.76 = + \ ds.83 ds.84 -> + let + fail.85 = + (error Bool) + "\"ds027.hs\", line 8: pattern-matching failure [function binding]\n"S + in + case ds.83 of { + Test.Bar -> + case ds.84 of { + Test.Baz -> True + _ -> fail.85 + } + _ -> fail.85 + } in + let + /=.77 = + \ ds.89 ds.90 -> + let + fail.91 = + (error Bool) + "\"ds027.hs\", line 9: pattern-matching failure [function binding]\n"S + in + case ds.89 of { + Test.Bar -> + case ds.90 of { + Test.Baz -> False + _ -> fail.91 + } + _ -> fail.91 + } + in + MkTuple2! + (Test.Foo -> Test.Foo -> Bool) + (Test.Foo -> Test.Foo -> Bool) + ==.76 + /=.77 +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds028.hs b/ghc/compiler/tests/deSugar/ds028.hs new file mode 100644 index 0000000..728a0c8 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds028.hs @@ -0,0 +1,10 @@ +--!!! ds028: failable pats in top row + +-- when the first row of pats doesn't have convenient +-- variables to grab... + +mAp f [] = [] +mAp f (x:xs) = f x : mAp f xs + +True |||| _ = True +False |||| x = x diff --git a/ghc/compiler/tests/deSugar/ds028.stderr b/ghc/compiler/tests/deSugar/ds028.stderr new file mode 100644 index 0000000..450f82f --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds028.stderr @@ -0,0 +1,30 @@ +Desugared: +{- plain CoRec -} +Main.map :: for all d, e. (d -> e) -> [d] -> [e] +Main.map = + /\ t88 t84 -> \ f.100 ds.101 -> + let + fail.102 = + (error [t84]) + "\"ds028.hs\", line 7: pattern-matching failure [function binding]\n"S + in + case ds.101 of { + Nil -> Nil! t84 + (:) x.103 xs.104 -> + let f.105 = f.100 + in (: t84) (f.105 x.103) (((Main.map t88) t84) f.105 xs.104) + } +{- end plain CoRec -} +Main.|| :: Bool -> Bool -> Bool +Main.|| = + \ ds.109 ds.110 -> + let + fail.111 = + (error Bool) + "\"ds028.hs\", line 10: pattern-matching failure [function binding]\n"S + in + case ds.109 of { + True -> True + False -> let x.112 = ds.110 in x.112 + } + diff --git a/ghc/compiler/tests/deSugar/ds029.hs b/ghc/compiler/tests/deSugar/ds029.hs new file mode 100644 index 0000000..fd9f583 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds029.hs @@ -0,0 +1,9 @@ +--!!! ds029: pattern binding with guards (dubious but valid) +-- + +module Test where + +f x = y + where (y,z) | y < z = (0,1) + | y > z = (1,2) + | True = (2,3) diff --git a/ghc/compiler/tests/deSugar/ds029.stderr b/ghc/compiler/tests/deSugar/ds029.stderr new file mode 100644 index 0000000..4f1da2b --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds029.stderr @@ -0,0 +1,70 @@ +Desugared: +Test.f :: for all d, e. -> -> d -> e +Test.f = + /\ o79 t102 -> \ dict.103 dict.104 x.107 -> + let + ds.124 = + /\ t108 -> \ dict.109 dict.110 -> + let dict.111 = dict.110 in + let dict.112 = dict.111 in + let dict.113 = dict.112 in + let dict.114 = dict.113 in + let dict.115 = dict.114 in + let dict.116 = dict.109 + in + let + {- CoRec -} + ds.117 = + case ((< t108) dict.116 y.118 z.119) of { + True -> + MkTuple2! + t108 + t108 + ((fromInteger t108) + dict.115 (MkInteger! 0##)) + ((fromInteger t108) + dict.114 (MkInteger! 1##)) + False -> + case ((> t108) dict.109 y.118 z.119) of { + True -> + MkTuple2! + t108 + t108 + ((fromInteger t108) + dict.113 (MkInteger! 1##)) + ((fromInteger t108) + dict.112 (MkInteger! 2##)) + False -> + MkTuple2! + t108 + t108 + ((fromInteger t108) + dict.111 (MkInteger! 2##)) + ((fromInteger t108) + dict.110 (MkInteger! 3##)) + } + } + y.118 = + case ds.117 of { + MkTuple2 y.120 z.121 -> y.120 + } + z.119 = + case ds.117 of { + MkTuple2 y.122 z.123 -> z.123 + } + {- end CoRec -} + in MkTuple2! t108 t108 y.118 z.119 in + let + y.130 = + /\ t125 -> \ dict.126 dict.127 -> + case ((ds.124 t125) dict.126 dict.127) of { + MkTuple2 y.128 z.129 -> y.128 + } in + let + z.136 = + /\ t131 -> \ dict.132 dict.133 -> + case ((ds.124 t131) dict.132 dict.133) of { + MkTuple2 y.134 z.135 -> z.135 + } + in (y.130 t102) dict.103 dict.104 + diff --git a/ghc/compiler/tests/deSugar/ds030.hs b/ghc/compiler/tests/deSugar/ds030.hs new file mode 100644 index 0000000..7abc4d8 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds030.hs @@ -0,0 +1,5 @@ +--!!! ds030: checks that types substituted into binders +-- +module Test where + +f x = case x of [] -> (3::Int) ; _ -> (4::Int) diff --git a/ghc/compiler/tests/deSugar/ds030.stderr b/ghc/compiler/tests/deSugar/ds030.stderr new file mode 100644 index 0000000..7125ae6 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds030.stderr @@ -0,0 +1,31 @@ +Desugared: +Test.f :: for all d. [d] -> Int {- 0 MkInt deriving ( )-} = + /\ t78 -> \ x.88 :: [t78] -> + let ds.89 :: [t78] = x.88 :: [t78] in + let + fail.90 :: Int {- 0 MkInt deriving ( )-} = + ({-CoTyApp-} error :: for all a. + [Char {- 0 MkChar deriving ( )-}] -> a + Int {- 0 MkInt deriving ( )-}) + "\"ds030.hs\", line 5: pattern-matching failed in case\n"S in + let + fail.92 :: Int {- 0 MkInt deriving ( )-} = + let + dict.91 :: > = + dfun.Num.Int :: + in + MkInt :: IntPrim{- StgInt -} -> Int {- 0 MkInt deriving ( )-}! + 4# + in + case ds.89 :: [t78] of { + [a] {- 1 a Nil, : deriving ( )-} + Nil :: for all a. [a] -> + let + dict.93 :: > = + dfun.Num.Int :: + in + MkInt :: IntPrim{- StgInt -} -> Int {- 0 MkInt deriving ( )-}! + 3# + _ -> fail.92 :: Int {- 0 MkInt deriving ( )-} + } + diff --git a/ghc/compiler/tests/deSugar/ds031.hs b/ghc/compiler/tests/deSugar/ds031.hs new file mode 100644 index 0000000..6454e08 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds031.hs @@ -0,0 +1,5 @@ +foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) +foldPair fg ab [] = ab +foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) + where (u,v) = foldPair fg ab abs + diff --git a/ghc/compiler/tests/deSugar/ds031.stderr b/ghc/compiler/tests/deSugar/ds031.stderr new file mode 100644 index 0000000..c282d34 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds031.stderr @@ -0,0 +1,51 @@ +Desugared: +{- plain CoRec -} +Main.foldPair :: + for all a, b. (a -> a -> a, b -> b -> b) -> (a, b) -> [(a, b)] -> (a, b) +Main.foldPair = + /\ a b -> \ fg.122 ab.123 ds.124 -> + let + fail.125 = + (error (a, b)) + "\"ds031.hs\", line 4: pattern-matching failure [function binding]\n"S in + let + fail.141 = + case fg.122 of { + MkTuple2 f.126 g.127 -> + case ds.124 of { + (:) ds.128 abs.129 -> + case ds.128 of { + MkTuple2 a.130 b.131 -> + let ab.132 = ab.123 in + let fg.133 = fg.122 in + let + ds.134 = + ((Main.foldPair a) b) + fg.133 ab.132 abs.129 in + let + u.137 = + case ds.134 of { + MkTuple2 u.135 v.136 -> u.135 + } in + let + v.140 = + case ds.134 of { + MkTuple2 u.138 v.139 -> v.139 + } + in + MkTuple2! + a + b + (f.126 a.130 u.137) + (g.127 b.131 v.140) + } + _ -> fail.125 + } + } + in + case ds.124 of { + Nil -> ab.123 + _ -> fail.141 + } +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds032.hs b/ghc/compiler/tests/deSugar/ds032.hs new file mode 100644 index 0000000..a1cda84 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds032.hs @@ -0,0 +1,14 @@ +--!!! recursive funs tangled in an AbsBind + +flatten :: Int -- Indentation + -> Bool -- True => just had a newline + -> Float -- Current seq to flatten + -> [(Int,Float)]-- Work list with indentation + -> String + +flatten n nlp 0.0 seqs = flattenS nlp seqs +flatten n nlp 1.0 seqs = flatten n nlp 1.1 ((n,1.2) : seqs) + +flattenS :: Bool -> [(Int, Float)] -> String +flattenS nlp [] = "" +flattenS nlp ((col,seq):seqs) = flatten col nlp seq seqs diff --git a/ghc/compiler/tests/deSugar/ds032.stderr b/ghc/compiler/tests/deSugar/ds032.stderr new file mode 100644 index 0000000..e5faf99 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds032.stderr @@ -0,0 +1,64 @@ +Desugared: +dict.93 :: +dict.93 = dfun.Fractional.Float +dict.94 :: +dict.94 = dfun.Eq.Float +dict.101 :: +dict.101 = dfun.Fractional.Float +dict.102 :: +dict.102 = dfun.Eq.Float +dict.107 :: +dict.107 = dfun.Fractional.Float +dict.111 :: +dict.111 = dfun.Fractional.Float +{- plain CoRec -} +Main.flatten :: Int -> Bool -> Float -> [(Int, Float)] -> [Char] +Main.flatten = + \ n.130 nlp.131 ds.132 seqs.133 -> + let + fail.134 = + (error [Char]) + "\"ds032.hs\", line 10: pattern-matching failure [function binding]\n"S + in + case (eqFloat (MkFloat! 0.0000000000000000#) ds.132) of { + True -> Main.flattenS nlp.131 seqs.133 + False -> + case (eqFloat (MkFloat! 1.0000000000000000#) ds.132) of { + True -> + let seqs.135 = seqs.133 in + let nlp.136 = nlp.131 in + let n.137 = n.130 + in + Main.flatten + n.137 + nlp.136 + (MkFloat! 1.1000000000000001#) + ((: (Int, Float)) + (MkTuple2! + Int + Float + n.137 + (MkFloat! 1.2000000000000000#)) + seqs.135) + False -> fail.134 + } + } +Main.flattenS :: Bool -> [(Int, Float)] -> [Char] +Main.flattenS = + \ nlp.138 ds.139 -> + let + fail.140 = + (error [Char]) + "\"ds032.hs\", line 14: pattern-matching failure [function binding]\n"S + in + case ds.139 of { + Nil -> Nil! Char + (:) ds.141 seqs.142 -> + case ds.141 of { + MkTuple2 col.143 seq.144 -> + let nlp.145 = nlp.138 + in Main.flatten col.143 nlp.145 seq.144 seqs.142 + } + } +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds033.hs b/ghc/compiler/tests/deSugar/ds033.hs new file mode 100644 index 0000000..bdadb58 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds033.hs @@ -0,0 +1,15 @@ +--!!! getting top-level dependencies right +-- +module Test where + +f1 x = g1 x +g1 y = y + +g2 y = y +f2 x = g2 x + +f3 x = g3 x +g3 y = f3 y + +g4 y = f4 y +f4 x = g4 x diff --git a/ghc/compiler/tests/deSugar/ds033.stderr b/ghc/compiler/tests/deSugar/ds033.stderr new file mode 100644 index 0000000..9fe0d0c --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds033.stderr @@ -0,0 +1,22 @@ +Desugared: +Test.g1 :: for all d. d -> d +Test.g1 = /\ o91 -> \ y.119 -> y.119 +Test.f1 :: for all d. d -> d +Test.f1 = /\ t95 -> \ x.120 -> (Test.g1 t95) x.120 +Test.g2 :: for all d. d -> d +Test.g2 = /\ o98 -> \ y.121 -> y.121 +Test.f2 :: for all d. d -> d +Test.f2 = /\ t102 -> \ x.122 -> (Test.g2 t102) x.122 +{- plain CoRec -} +Test.f3 :: for all d, e. d -> e +Test.f3 = /\ o109 o110 -> \ x.123 -> ((Test.g3 o109) o110) x.123 +Test.g3 :: for all d, e. d -> e +Test.g3 = /\ o109 o110 -> \ y.124 -> ((Test.f3 o109) o110) y.124 +{- end plain CoRec -} +{- plain CoRec -} +Test.g4 :: for all d, e. d -> e +Test.g4 = /\ o117 o118 -> \ y.125 -> ((Test.f4 o117) o118) y.125 +Test.f4 :: for all d, e. d -> e +Test.f4 = /\ o117 o118 -> \ x.126 -> ((Test.g4 o117) o118) x.126 +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds034.hs b/ghc/compiler/tests/deSugar/ds034.hs new file mode 100644 index 0000000..d1f2786 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds034.hs @@ -0,0 +1,11 @@ +--!!! mutually-recursive methods in an instance declaration +-- +module Test where + +class Foo a where + op1 :: a -> a + op2 :: a -> a + +instance Foo Int where + op1 x = op2 x + op2 y = op1 y diff --git a/ghc/compiler/tests/deSugar/ds034.stderr b/ghc/compiler/tests/deSugar/ds034.stderr new file mode 100644 index 0000000..6ca09a5 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds034.stderr @@ -0,0 +1,27 @@ +Desugared: +{- plain CoRec -} +defm.Test.Foo.op1 :: for all a. -> a -> a +defm.Test.Foo.op1 = /\ a -> (error (a -> a)) "No default method for \"op1\"\n"S +defm.Test.Foo.op2 :: for all a. -> a -> a +defm.Test.Foo.op2 = /\ a -> (error (a -> a)) "No default method for \"op2\"\n"S +Test.Foo.op1 :: for all a. -> a -> a +Test.Foo.op1 = + /\ a -> \ ds.95 -> + case ds.95 of { + MkTuple2 op1.77 op2.78 -> op1.77 + } +Test.Foo.op2 :: for all a. -> a -> a +Test.Foo.op2 = + /\ a -> \ ds.96 -> + case ds.96 of { + MkTuple2 op1.80 op2.81 -> op2.81 + } +dfun.Test.Foo.Int :: +dfun.Test.Foo.Int = + let dict.89 = dfun.Test.Foo.Int in + let op1.85 = \ x.97 -> (Test.Foo.op2 Int) dict.89 x.97 in + let dict.93 = dfun.Test.Foo.Int in + let op2.86 = \ y.98 -> (Test.Foo.op1 Int) dict.93 y.98 + in MkTuple2! (Int -> Int) (Int -> Int) op1.85 op2.86 +{- end plain CoRec -} + diff --git a/ghc/compiler/tests/deSugar/ds035.hs b/ghc/compiler/tests/deSugar/ds035.hs new file mode 100644 index 0000000..5a29a0e --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds035.hs @@ -0,0 +1,18 @@ +data CList = CNil | CCons Int# CList + +mk :: Int# -> CList +mk n = case (n ==# 0#) of + 0# -> CNil + _ -> CCons 1# (mk (n `minusInt#` 1#)) + +clen :: CList -> Int# +clen CNil = 0# +clen (CCons _ cl) = 1# +# (clen cl) + +main = case len4_twice of + 8# -> "bingo\n" + _ -> "oops\n" + where + list4 = mk 4# + len4 = clen list4 + len4_twice = len4 +# len4 diff --git a/ghc/compiler/tests/deSugar/ds035.stderr b/ghc/compiler/tests/deSugar/ds035.stderr new file mode 100644 index 0000000..bf6c983 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds035.stderr @@ -0,0 +1,5 @@ + +"ds035.hs", line 4: undefined value: minusIntPrim +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/deSugar/ds036.hs b/ghc/compiler/tests/deSugar/ds036.hs new file mode 100644 index 0000000..fc30c07 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds036.hs @@ -0,0 +1,45 @@ +{- +From dmc@minster.york.ac.uk Tue Mar 10 17:15:20 1992 +Via: uk.ac.york.minster; Tue, 10 Mar 92 17:15:14 GMT +Message-Id: +From: dmc@minster.york.ac.uk +To: partain +Date: 10 Mar 1992 17:17:21 GMT + +Will, + +I have just started using Haskell at York and have found a compilation +error in the code below which disappears when the last line is +commented out +-} + +module Test2 where + +--brack :: (Eq a) => a -> a -> [a] -> ([a],[a]) +--brack open close = brack' open close (1 :: Int) + +brack' :: (Eq a) => a -> a -> Int -> [a] -> ([a],[a]) +brack' open close 0 xs = ([],xs) +brack' open close (n+1) [] = ([],[]) +brack' open close (n+1) (h:t) | h == open = ([],[]) + +{- +Is this something I have done wrong or a fault with the compiler? + +Cheers +Dave + + +----------------------------------------------------------------------- +David Cattrall Telephone +44 904 432777 +Department of Computer Science +University of York JANET: dmc@uk.ac.york.minster +YORK Y01 5DD +United Kingdom UUNET: uucp!ukc!minster!dmc +----------------------------------------------------------------------- +-} + +-- and this was Kevin's idea, subsequently... + +kh (n+2) x | x > n = x * 2 +kh (x+1) (m+1) = m diff --git a/ghc/compiler/tests/deSugar/ds036.stderr b/ghc/compiler/tests/deSugar/ds036.stderr new file mode 100644 index 0000000..3fa73ea --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds036.stderr @@ -0,0 +1,145 @@ +Desugared: +Test2.brack' :: for all a. -> a -> a -> Int -> [a] -> ([a], [a]) +Test2.brack' = + /\ a -> \ dict.124 -> + let dict.119 = dict.124 in + let dict.96 = dfun.Num.Int in + let dict.97 = dfun.Eq.Int in + let dict.104 = dfun.Num.Int in + let dict.105 = dfun.Ord.Int in + let dict.113 = dfun.Num.Int in + let dict.114 = dfun.Ord.Int in + let + brack'.92 = + \ open.64 close.63 ds.148 xs.65 -> + let + fail.149 = + (error ([a], [a])) + "\"ds036.hs\", line 24: pattern-matching failure [function binding]\n"S in + let + fail.151 = + let n.150 = MkInt! 1# + in + case (geInt ds.148 (MkInt! 1#)) of { + True -> + let n.67 = minusInt ds.148 (MkInt! 1#) + in + case xs.65 of { + Nil -> + let close.66 = close.63 in + let open.68 = open.64 + in MkTuple2! [a] [a] (Nil! a) (Nil! a) + (:) h.70 t.73 -> + let close.69 = close.63 in + let open.72 = open.64 + in + case + ((== a) dict.119 h.70 open.72) + of { + True -> + MkTuple2! + [a] [a] (Nil! a) (Nil! a) + False -> fail.149 + } + } + False -> fail.149 + } + in + case ds.148 of { + MkInt ds.152 -> + case ds.152 of { + 0# -> MkTuple2! [a] [a] (Nil! a) xs.65 + _ -> fail.151 + } + } + in brack'.92 +Test2.kh :: + for all d, e. -> -> -> -> d -> e -> e +Test2.kh = + /\ t141 t145 -> \ dict.147 dict.146 dict.143 dict.142 -> + let dict.138 = dict.146 in + let dict.136 = dict.138 in + let dict.133 = dict.147 in + let dict.129 = dict.142 in + let dict.130 = dict.143 in + let + kh.126 = + \ n.74 x.75 -> + let + fail.154 = + (error t145) + "\"ds036.hs\", line 45: pattern-matching failure [function binding]\n"S in + let n.157 = (fromInteger t141) dict.129 (MkInteger! 2##) + in + case + ((>= t141) + dict.130 + n.74 + ((fromInteger t141) dict.129 (MkInteger! 2##))) + of { + True -> + let + n.74 = + (- t141) + dict.129 + n.74 + ((fromInteger t141) + dict.129 (MkInteger! 2##)) + in + case ((> t145) dict.133 x.75 n.74) of { + True -> + (* t145) + dict.136 + x.75 + ((fromInteger t145) + dict.138 (MkInteger! 2##)) + False -> fail.154 + } + False -> + let + x.156 = (fromInteger t141) dict.142 (MkInteger! 1##) + in + case + ((>= t141) + dict.143 + n.74 + ((fromInteger t141) + dict.142 (MkInteger! 1##))) + of { + True -> + let + x.77 = + (- t141) + dict.142 + n.74 + ((fromInteger t141) + dict.142 (MkInteger! 1##)) in + let + m.155 = + (fromInteger t145) + dict.146 (MkInteger! 1##) + in + case + ((>= t145) + dict.147 + x.75 + ((fromInteger t145) + dict.146 (MkInteger! 1##))) + of { + True -> + let + m.76 = + (- t145) + dict.146 + x.75 + ((fromInteger t145) + dict.146 + (MkInteger! 1##)) + in m.76 + False -> fail.154 + } + False -> fail.154 + } + } + in kh.126 + diff --git a/ghc/compiler/tests/deSugar/ds037.hs b/ghc/compiler/tests/deSugar/ds037.hs new file mode 100644 index 0000000..924df50 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds037.hs @@ -0,0 +1,4 @@ +--!!! AbsBinds with tyvars, no dictvars, but some dict binds +-- +f x y = (fst (g y x), x+(1::Int)) +g x y = (fst (f x y), y+(1::Int)) diff --git a/ghc/compiler/tests/deSugar/ds037.stderr b/ghc/compiler/tests/deSugar/ds037.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deSugar/ds038.hs b/ghc/compiler/tests/deSugar/ds038.hs new file mode 100644 index 0000000..ceffab1 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds038.hs @@ -0,0 +1,7 @@ +--!!! Jon Hill reported a bug in desugaring this in 0.09 +--!!! (recursive with n+k patts) +-- +takeList :: Int -> [a] -> [a] +takeList 0 _ = [] +takeList (n+1) [] = [] +takeList (n+1) (x:xs) = x : takeList n xs diff --git a/ghc/compiler/tests/deSugar/ds038.stderr b/ghc/compiler/tests/deSugar/ds038.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deSugar/ds039.hs b/ghc/compiler/tests/deSugar/ds039.hs new file mode 100644 index 0000000..ad6c1be --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds039.hs @@ -0,0 +1,4 @@ +--!!! make sure correct type applications get put in +--!!! when (:) is saturated. + +f = (:) diff --git a/ghc/compiler/tests/deSugar/ds039.stderr b/ghc/compiler/tests/deSugar/ds039.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deSugar/ds040.hs b/ghc/compiler/tests/deSugar/ds040.hs new file mode 100644 index 0000000..d7fb621 --- /dev/null +++ b/ghc/compiler/tests/deSugar/ds040.hs @@ -0,0 +1,13 @@ +--!!! Another bug in overloaded n+k patts +-- + +main _ = [AppendChan stdout (shows ((4::Int) ^^^^ (6::Int)) "\n")] + +(^^^^) :: (Num a, Integral b) => a -> b -> a +x ^^^^ 0 = 1 +x ^^^^ (n+1) = f x n x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n `quot` 2) + | otherwise = f x (n-1) (x*y) +_ ^^^^ _ = error "(^^^^){Prelude}: negative exponent" diff --git a/ghc/compiler/tests/deSugar/ds040.stderr b/ghc/compiler/tests/deSugar/ds040.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/Jmakefile b/ghc/compiler/tests/deriving/Jmakefile new file mode 100644 index 0000000..e676c5c --- /dev/null +++ b/ghc/compiler/tests/deriving/Jmakefile @@ -0,0 +1,9 @@ +TEST_FLAGS=-noC -ddump-tc -dcore-lint -hi + +RunStdTest(drv001,$(GHC),$(TEST_FLAGS) drv001.hs -o2 drv001.stderr) +RunStdTest(drv002,$(GHC),$(TEST_FLAGS) drv002.hs -o2 drv002.stderr) +RunStdTest(drv003,$(GHC),$(TEST_FLAGS) drv003.hs -o2 drv003.stderr) +RunStdTest(drv004,$(GHC),$(TEST_FLAGS) drv004.hs -o2 drv004.stderr) +RunStdTest(drv005,$(GHC),$(TEST_FLAGS) drv005.hs -o2 drv005.stderr) +RunStdTest(drv006,$(GHC),$(TEST_FLAGS) drv006.hs -o2 drv006.stderr) +RunStdTest(drv007,$(GHC),$(TEST_FLAGS) drv007.hs -o2 drv007.stderr) diff --git a/ghc/compiler/tests/deriving/drv001.hs b/ghc/compiler/tests/deriving/drv001.hs new file mode 100644 index 0000000..707a05d --- /dev/null +++ b/ghc/compiler/tests/deriving/drv001.hs @@ -0,0 +1,19 @@ +--!!! canonical weird example for "deriving" + +data X a b + = C1 (T a) + | C2 (Y b) + | C3 (X b a) + deriving Text + +data Y b + = D1 + | D2 (X Int b) + deriving Text + +data T a + = E1 + +instance Eq a => Text (T a) where + showsPrec = error "show" + readsPrec = error "read" diff --git a/ghc/compiler/tests/deriving/drv001.stderr b/ghc/compiler/tests/deriving/drv001.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/drv002.hs b/ghc/compiler/tests/deriving/drv002.hs new file mode 100644 index 0000000..e8855f2 --- /dev/null +++ b/ghc/compiler/tests/deriving/drv002.hs @@ -0,0 +1,11 @@ +data Z a b + = C1 (T a) + | C2 (Z [a] [b]) + deriving Text + +data T a + = E1 + +instance Eq a => Text (T a) where + showsPrec = error "show" + readsPrec = error "read" diff --git a/ghc/compiler/tests/deriving/drv002.stderr b/ghc/compiler/tests/deriving/drv002.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/drv003.hs b/ghc/compiler/tests/deriving/drv003.hs new file mode 100644 index 0000000..3da22bd --- /dev/null +++ b/ghc/compiler/tests/deriving/drv003.hs @@ -0,0 +1,15 @@ +--!!! This is the example given in TcDeriv +-- +data T a b + = C1 (Foo a) (Bar b) + | C2 Int (T b a) + | C3 (T a a) + deriving Eq + +data Foo a = MkFoo Double a deriving () +instance (Eq a) => Eq (Foo a) + +data Bar a = MkBar Int Int deriving () +instance (Ping b) => Eq (Bar b) + +class Ping a diff --git a/ghc/compiler/tests/deriving/drv003.stderr b/ghc/compiler/tests/deriving/drv003.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/drv004.hs b/ghc/compiler/tests/deriving/drv004.hs new file mode 100644 index 0000000..9863e3a --- /dev/null +++ b/ghc/compiler/tests/deriving/drv004.hs @@ -0,0 +1,6 @@ +--!!! simple example of deriving Ord (and, implicitly, Eq) +-- +data Foo a b + = C1 a Int + | C2 b Double + deriving Ord diff --git a/ghc/compiler/tests/deriving/drv004.stderr b/ghc/compiler/tests/deriving/drv004.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/drv005.hs b/ghc/compiler/tests/deriving/drv005.hs new file mode 100644 index 0000000..cef5fe6 --- /dev/null +++ b/ghc/compiler/tests/deriving/drv005.hs @@ -0,0 +1,4 @@ +--!!! simple example of deriving Enum +-- +data Foo = Foo1 | Foo2 | Foo3 | Foo4 | Foo5 | Foo6 | Foo7 | Foo8 + deriving Enum diff --git a/ghc/compiler/tests/deriving/drv005.stderr b/ghc/compiler/tests/deriving/drv005.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/drv006.hs b/ghc/compiler/tests/deriving/drv006.hs new file mode 100644 index 0000000..a6d6d1c --- /dev/null +++ b/ghc/compiler/tests/deriving/drv006.hs @@ -0,0 +1,6 @@ +--!!! simple examples of deriving Ix +-- +data Foo = Foo1 | Foo2 | Foo3 | Foo4 | Foo5 | Foo6 | Foo7 | Foo8 + deriving Ix + +data Bar a b = MkBar a Int b Integer a diff --git a/ghc/compiler/tests/deriving/drv006.stderr b/ghc/compiler/tests/deriving/drv006.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/deriving/drv007.hs b/ghc/compiler/tests/deriving/drv007.hs new file mode 100644 index 0000000..c1bbab1 --- /dev/null +++ b/ghc/compiler/tests/deriving/drv007.hs @@ -0,0 +1,3 @@ +--!!! buggy deriving with function type, reported by Sigbjorn Finne + +data Foo = Foo (Int -> Int) deriving Eq diff --git a/ghc/compiler/tests/deriving/drv007.stderr b/ghc/compiler/tests/deriving/drv007.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/printing/Jmakefile b/ghc/compiler/tests/printing/Jmakefile new file mode 100644 index 0000000..86b4238 --- /dev/null +++ b/ghc/compiler/tests/printing/Jmakefile @@ -0,0 +1,9 @@ +runtests:: + @echo '###############################################################' + @echo '# Tests of printing facilities in the compiler. #' + @echo '###############################################################' + +RunStdTest(print001,$(GHC), -noC -hi Print001.hs -o2 Print001.stderr) +RunStdTest(print002,$(GHC), -noC -fno-implicit-prelude -dppr-user -ddump-rif2hs -ddump-tc -hi Print002.hs -o2 Print002.stderr) +RunStdTest(print003,$(GHC), -noC -hi Print003.hs -o2 Print003.stderr) +RunStdTest(print004,$(GHC), -noC -hi Print004.hs -o2 Print004.stderr) diff --git a/ghc/compiler/tests/printing/Print001.hs b/ghc/compiler/tests/printing/Print001.hs new file mode 100644 index 0000000..efe63d4 --- /dev/null +++ b/ghc/compiler/tests/printing/Print001.hs @@ -0,0 +1,18 @@ +--!!! Print001.hs: printing of types (esp for interfaces) + +module Print001 where + +data Foo d e f = MkFoo [((d->Int)->d)->e] (d->e, e->e) () +data Bar a = BarNil + | BarCon (Foo a a a) (Bar a) + +mkFoo = MkFoo + +f :: Eq a => (a -> b -> c) -> (a -> b -> c) +f x = x + +f2 :: (Eq a, Ord a, Ix c) => (a -> b -> c) -> (a -> b -> c) +f2 x = x + +g :: Foo Int (a -> b) (a -> [(a, Double, Int)]) -> Float +g x = 2.0 diff --git a/ghc/compiler/tests/printing/Print001.stderr b/ghc/compiler/tests/printing/Print001.stderr new file mode 100644 index 0000000..2cf5b13 --- /dev/null +++ b/ghc/compiler/tests/printing/Print001.stderr @@ -0,0 +1,10 @@ +=-=-=-=-=INTERFACE STARTS HERE=-=-=-=-= Print001 +interface Print001 where +f :: Eq a => (a -> b -> c) -> a -> b -> c {-# ARITY _ = 2 #-} +f2 :: (Eq a, Ord a, Ix c) => (a -> b -> c) -> a -> b -> c {-# ARITY _ = 4 #-} +g :: Foo Int (b -> a) (b -> [(b, Double, Int)]) -> Float {-# ARITY _ = 1 #-} +mkFoo :: [((a -> Int) -> a) -> b] -> (a -> b, b -> b) -> () -> Foo a b c {-# ARITY _ = 3 #-} +data Bar a = BarNil | BarCon (Foo a a a) (Bar a) +data Foo a b c = MkFoo [((a -> Int) -> a) -> b] (a -> b, b -> b) () +=-=-=-=-=INTERFACE STOPS HERE=-=-=-=-= + diff --git a/ghc/compiler/tests/printing/Print002.hs b/ghc/compiler/tests/printing/Print002.hs new file mode 100644 index 0000000..458170a --- /dev/null +++ b/ghc/compiler/tests/printing/Print002.hs @@ -0,0 +1,40 @@ +--!!! Print002.hs: printing various entities in prefix/infix forms +--!!! (both in various syntaxes & in interfaces) + +module Print002 where + +-- type & data constructors + +data Foo a b c + = MkFoo1 a a + | (:##) b c + | b `MkFoo3` b + | c :*** c + deriving (Eq, Ord) + +-- classes and methods + +class Bar a where + meth1, (/////) :: a -> a -> Bool + meth2 :: a -> b -> Bool + +class (Bar a) => Bar2 a -- no methods + +-- regular values (and uses of the above) + +f1 x y = x `MkFoo1` y +x `f1a` y = MkFoo1 x y + +x `f2` y = (:##) x y +f2a x y = x :## y + +(....) x y = MkFoo3 x y +x ..... y = x `MkFoo3` y + +x <<<< y = x :*** y +(<<<<) x y = (:***) x y + +f3a x y = meth1 x y +f3b x y = x `meth1` y +f3c x y = (/////) x y +f3d x y = x ///// y diff --git a/ghc/compiler/tests/printing/Print002.stderr b/ghc/compiler/tests/printing/Print002.stderr new file mode 100644 index 0000000..fac05ef --- /dev/null +++ b/ghc/compiler/tests/printing/Print002.stderr @@ -0,0 +1,272 @@ +Parsed, Haskellised: +module Print002 where +infixr 9 . +infixr 8 ^ +infixr 8 ^^ +infixr 3 && +infixr 2 || +infixr 0 $ +infixl 9 ! +infixl 9 // +infix 1 := +infix 6 :+ +infixr 8 ** +infixl 7 * +infixl 7 / +infixl 7 `quot` +infixl 7 `rem` +infixl 7 `div` +infixl 7 `mod` +infixl 6 + +infixl 6 - +infix 4 == +infix 4 /= +infix 4 < +infix 4 <= +infix 4 >= +infix 4 > +infixl 9 !! +infix 5 \\ +infix 4 `elem` +infix 4 `notElem` +infixl 7 % +data Foo a b c + = MkFoo1 a a + | (:##) b c + | MkFoo3 b b + | (:***) c c + deriving (Eq, Ord) +class Bar a where + meth1 :: a -> a -> Bool + ///// :: a -> a -> Bool + meth2 :: a -> b -> Bool +class Bar a => Bar2 a where +f1 x y = x `MkFoo1` y +f1a x y = MkFoo1 x y +f2 x y = (:##) x y +f2a x y = x :## y +(....) + x y = MkFoo3 x y +(.....) + x y = x `MkFoo3` y +(<<<<) + x y = x :*** y +(<<<<) + x y = (:***) x y +f3a x y = meth1 x y +f3b x y = x `meth1` y +f3c x y = (/////) x y +f3d x y = x ///// y + +Typechecked: +meth1 = meth1 +(/////) = (/////) +meth2 = meth2 +defm.Print002.Bar.meth1 = + (error) "No default method for \"Print002.Bar.defm.Print002.Bar.meth1\"\n" +defm.Print002.Bar.///// = + (error) "No default method for \"Print002.Bar.defm.Print002.Bar./////\"\n" +defm.Print002.Bar.meth2 = + (error) "No default method for \"Print002.Bar.defm.Print002.Bar.meth2\"\n" +sdsel.Print002.Bar2.Print002.Bar = d.Print002.Bar.t443 +AbsBinds +[a, b, c] +[d.Eq.t192, d.Eq.t193, d.Eq.t194] +[(d.Eq.t195, dfun.Eq.Print002.Foo)] + (d.Eq.t268, d.Eq.t192) + (==.t212, (==)) + (==.t209, (==.t212)) + (d.Eq.t269, d.Eq.t194) + (==.t229, (==)) + (d.Eq.t270, d.Eq.t193) + (==.t226, (==)) + (==.t246, (==.t226)) + (==.t243, (==.t226)) + (==.t263, (==.t229)) + (==.t260, (==.t229)) + d.Eq.t195 = ({-dict-} [] [==, /=]) + (==) :: Foo a b c -> Foo a b c -> Bool + (==) (MkFoo1 a1 a2) (MkFoo1 b1 b2) + = (a1 ==.t209 b1) && (a2 ==.t212 b2) + (==) (:## a1 a2) (:## b1 b2) + = (a1 ==.t226 b1) && (a2 ==.t229 b2) + (==) (MkFoo3 a1 a2) (MkFoo3 b1 b2) + = (a1 ==.t243 b1) && (a2 ==.t246 b2) + (==) (:*** a1 a2) (:*** b1 b2) + = (a1 ==.t260 b1) && (a2 ==.t263 b2) + (==) a b = False + (/=) = defm./= +AbsBinds +[a, b, c] +[d.Ord.t275, d.Ord.t276, d.Ord.t277, d.Eq.t274] +[(d.Ord.t278, dfun.Ord.Print002.Foo)] + (d.Ord.t425, d.Ord.t278) + (cmp3.t290, cmp3) + (cmp3.t295, cmp3.t290) + (cmp3.t300, cmp3.t290) + (cmp3.t305, cmp3.t290) + (d.Ord.t426, d.Ord.t425) + (cmp3.t310, cmp3) + (cmp3.t315, cmp3.t310) + (d.Ord.t422, d.Ord.t275) + (d.Ord.t423, d.Ord.t276) + (d.Ord.t424, d.Ord.t277) + d.Ord.t278 = ({-dict-} [d.Eq.t274] [<, <=, >=, >, max, min, cmp3]) + (<) :: Foo a b c -> Foo a b c -> Bool + (<) a b = cmp3.t290 True False False a b + (<=) :: Foo a b c -> Foo a b c -> Bool + (<=) a b = cmp3.t295 True True False a b + (>=) :: Foo a b c -> Foo a b c -> Bool + (>=) a b = cmp3.t300 False True True a b + (>) :: Foo a b c -> Foo a b c -> Bool + (>) a b = cmp3.t305 False False True a b + max :: Foo a b c -> Foo a b c -> Foo a b c + max a b = cmp3.t310 b a a a b + min :: Foo a b c -> Foo a b c -> Foo a b c + min a b = cmp3.t315 a a b a b + cmp3 = + let + AbsBinds [tt316] [] [(cmp3, cmp3)] + cmp3 :: tt316 -> tt316 -> tt316 -> Foo a b c -> Foo a b c -> tt316 + cmp3 lt eq gt a b + = case (con2tag.Foo) a of + a# -> case (con2tag.Foo) b of + b# -> if a# `eqInt` b# then + if a# `ltInt` b# then + lt + else + gt + else + cmp3eq.t48.t419 lt eq gt a b + where + AbsBinds + [a, b, c, tt400] + [d.Ord.t402, d.Ord.t404, d.Ord.t403] + [(cmp3eq, cmp3eq)] + (cmp3.t344, cmp3) + (cmp3.t341, cmp3.t344) + (cmp3.t363, cmp3) + (cmp3.t360, cmp3) + (cmp3.t382, cmp3.t360) + (cmp3.t379, cmp3.t360) + (cmp3.t401, cmp3.t363) + (cmp3.t398, cmp3.t363) + cmp3eq :: + tt400 + -> tt400 + -> tt400 + -> Foo a b c -> Foo a b c -> tt400 + cmp3eq + lt eq gt (MkFoo1 a1 a2) (MkFoo1 b1 b2) + = cmp3.t341 + lt + (cmp3.t344 lt eq gt a2 b2) + gt + a1 + b1 + cmp3eq + lt eq gt (:## a1 a2) (:## b1 b2) + = cmp3.t360 + lt + (cmp3.t363 lt eq gt a2 b2) + gt + a1 + b1 + cmp3eq + lt eq gt (MkFoo3 a1 a2) (MkFoo3 b1 b2) + = cmp3.t379 + lt + (cmp3.t382 lt eq gt a2 b2) + gt + a1 + b1 + cmp3eq + lt eq gt (:*** a1 a2) (:*** b1 b2) + = cmp3.t398 + lt + (cmp3.t401 lt eq gt a2 b2) + gt + a1 + b1 + cmp3eq.t48.t419 = cmp3eq + in cmp3 +AbsBinds [a, b, c] [] [(f1, f1)] + f1 :: a -> a -> Foo a b c + f1 x y = (MkFoo1) x y +AbsBinds [a, b, c] [] [(f1a, f1a)] + f1a :: a -> a -> Foo a b c + f1a x y = (MkFoo1) x y +AbsBinds [a, b, c] [] [(f2, f2)] + f2 :: b -> c -> Foo a b c + f2 x y = ((:##)) x y +AbsBinds [a, b, c] [] [(f2a, f2a)] + f2a :: b -> c -> Foo a b c + f2a x y = ((:##)) x y +AbsBinds [a, b, c] [] [(...., ....)] + (....) :: b -> b -> Foo a b c + (....) + x y = (MkFoo3) x y +AbsBinds [a, b, c] [] [(....., .....)] + (.....) :: b -> b -> Foo a b c + (.....) + x y = (MkFoo3) x y +AbsBinds [a, b, c] [] [(<<<<, <<<<)] + (<<<<) :: c -> c -> Foo a b c + (<<<<) + x y = ((:***)) x y + (<<<<) + x y = ((:***)) x y +AbsBinds [a] [d.Print002.Bar.t143] [(f3a, f3a)] + (Print002.Bar.meth1.t142, meth1) + f3a :: a -> a -> Bool + f3a x y = Print002.Bar.meth1.t142 x y +AbsBinds [a] [d.Print002.Bar.t151] [(f3b, f3b)] + (Print002.Bar.meth1.t149, meth1) + f3b :: a -> a -> Bool + f3b x y = x `Print002.Bar.meth1.t149` y +AbsBinds [a] [d.Print002.Bar.t158] [(f3c, f3c)] + (Print002.Bar./////.t157, (/////)) + f3c :: a -> a -> Bool + f3c x y = Print002.Bar./////.t157 x y +AbsBinds [a] [d.Print002.Bar.t166] [(f3d, f3d)] + (Print002.Bar./////.t164, (/////)) + f3d :: a -> a -> Bool + f3d x y = x `Print002.Bar./////.t164` y +AbsBinds [a, b, c] [] [(con2tag.Foo, con2tag.Foo)] + con2tag.Foo :: Foo a b c -> IntPrim + con2tag.Foo + (MkFoo1 _ _) + = 0# + con2tag.Foo + (:## _ _) + = 1# + con2tag.Foo + (MkFoo3 _ _) + = 2# + con2tag.Foo + (:*** _ _) + = 3# + +=-=-=-=-=INTERFACE STARTS HERE=-=-=-=-= Print002 +interface Print002 where +(....) :: b -> b -> Foo a b c {-# ARITY _ = 2 #-} +(.....) :: b -> b -> Foo a b c {-# ARITY _ = 2 #-} +(<<<<) :: c -> c -> Foo a b c {-# ARITY _ = 2 #-} +f1 :: a -> a -> Foo a b c {-# ARITY _ = 2 #-} +f1a :: a -> a -> Foo a b c {-# ARITY _ = 2 #-} +f2 :: b -> c -> Foo a b c {-# ARITY _ = 2 #-} +f2a :: b -> c -> Foo a b c {-# ARITY _ = 2 #-} +f3a :: Bar a => a -> a -> Bool {-# ARITY _ = 1 #-} +f3b :: Bar a => a -> a -> Bool {-# ARITY _ = 1 #-} +f3c :: Bar a => a -> a -> Bool {-# ARITY _ = 1 #-} +f3d :: Bar a => a -> a -> Bool {-# ARITY _ = 1 #-} +class Bar a where + meth1 :: a -> a -> Bool + (/////) :: a -> a -> Bool + meth2 :: a -> b -> Bool +class (Bar a) => Bar2 a +data Foo a b c = MkFoo1 a a | (:##) b c | MkFoo3 b b | (:***) c c +instance (Eq a, Eq b, Eq c) => Eq (Foo a b c) +instance (Ord a, Ord b, Ord c) => Ord (Foo a b c) +=-=-=-=-=INTERFACE STOPS HERE=-=-=-=-= + diff --git a/ghc/compiler/tests/printing/Print003.hs b/ghc/compiler/tests/printing/Print003.hs new file mode 100644 index 0000000..e95bd0c --- /dev/null +++ b/ghc/compiler/tests/printing/Print003.hs @@ -0,0 +1,6 @@ +module Word where + +infixl 8 `bitLsh`, `bitRsh` + +class Bits a where + bitRsh, bitLsh :: a -> Int -> a diff --git a/ghc/compiler/tests/printing/Print003.stderr b/ghc/compiler/tests/printing/Print003.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/printing/Print004.hs b/ghc/compiler/tests/printing/Print004.hs new file mode 100644 index 0000000..2ea3a20 --- /dev/null +++ b/ghc/compiler/tests/printing/Print004.hs @@ -0,0 +1,18 @@ +--!!! export a derived thingy which mentions an internal type +-- +{- from simonpj; who adds: + + It is NOT ENOUGH to put + + data OpaqueType deriving(Text) + + in the interface +-} + +module ExportOpaque( OpaqueType ) where + +data OpaqueType a = Con (FunnyInternalType a) deriving(Text) + +data FunnyInternalType a = Junk11 | Junk2 + +instance Ord a => Text (FunnyInternalType a) diff --git a/ghc/compiler/tests/printing/Print004.stderr b/ghc/compiler/tests/printing/Print004.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/reader/Jmakefile b/ghc/compiler/tests/reader/Jmakefile new file mode 100644 index 0000000..60e7f91 --- /dev/null +++ b/ghc/compiler/tests/reader/Jmakefile @@ -0,0 +1,9 @@ +runtests:: + @echo '###############################################################' + @echo '# Validation tests for the reader in the compiler. #' + @echo '###############################################################' + +RunStdTest(read001,$(GHC), -noC -ddump-rif2hs read001.hs -o2 read001.stderr) +RunStdTest(read002,$(GHC), -noC -ddump-rif2hs read002.hs -o2 read002.stderr) +/* gap 003 */ +RunStdTest(read004,$(GHC), -noC -fno-implicit-prelude -ddump-rif2hs read004.hs -o2 read004.stderr) diff --git a/ghc/compiler/tests/reader/OneA.hi b/ghc/compiler/tests/reader/OneA.hi new file mode 100644 index 0000000..42ed194 --- /dev/null +++ b/ghc/compiler/tests/reader/OneA.hi @@ -0,0 +1,15 @@ +interface OneA where + +import OneB ( fB ) renaming ( fB to fBa ) + +type SynA = Float + +data DataAA +data (Ord a) => DataAB a = ConAB1 a | ConAB2 deriving Text + +class (Ord a) => ClassA a where + clsA :: a -> String + +instance ClassA Int + +fA :: a -> a diff --git a/ghc/compiler/tests/reader/OneB.hi b/ghc/compiler/tests/reader/OneB.hi new file mode 100644 index 0000000..78f55ee --- /dev/null +++ b/ghc/compiler/tests/reader/OneB.hi @@ -0,0 +1,3 @@ +interface OneB where + +fB :: a -> a diff --git a/ghc/compiler/tests/reader/OneC.hi b/ghc/compiler/tests/reader/OneC.hi new file mode 100644 index 0000000..ded63cc --- /dev/null +++ b/ghc/compiler/tests/reader/OneC.hi @@ -0,0 +1,3 @@ +interface OneC where + +fC :: a -> a diff --git a/ghc/compiler/tests/reader/expr001.hs b/ghc/compiler/tests/reader/expr001.hs new file mode 100644 index 0000000..49853a7 --- /dev/null +++ b/ghc/compiler/tests/reader/expr001.hs @@ -0,0 +1,14 @@ +{- +From: Kevin Hammond +To: partain +Subject: Re: parsing problem w/ queens +Date: Wed, 9 Oct 91 17:31:46 BST + +OK, I've fixed that little problem by disallowing, +-} + +f x = x + if c then 1 else 2 +f x = x + 1::Int + +-- (the conditional/sig need to be parenthesised). If this is +-- problematic, let me know! diff --git a/ghc/compiler/tests/reader/read001.hs b/ghc/compiler/tests/reader/read001.hs new file mode 100644 index 0000000..4a97768 --- /dev/null +++ b/ghc/compiler/tests/reader/read001.hs @@ -0,0 +1,113 @@ +-- this module supposedly includes one of each Haskell construct + +-- HsImpExp stuff + +module OneOfEverything ( + fixn, + FooData, + FooDataB(..), + FooDataC( .. ), + EqTree(EqLeaf, EqBranch), + EqClass(..), + OrdClass(orda, ordb), + OneC.. , + OneOfEverything.. + ) where + +import OneA renaming ( fA to renamedA ) +import OneB ( fB ) +import OneC hiding ( fC ) +import OneC hiding ( fC ) renaming ( fc to renamedC ) + +-- HsDecls stuff + +infix 6 `fixn` +infixl 7 +# +infixr 8 `fixr` + +fixn x y = x +fixl x y = x +fixr x y = x + +type Pair a b = (a, b) + +data FooData = FooCon Int + +data FooDataB = FooConB Double + +data (Eq a) => EqTree a = EqLeaf a | EqBranch (EqLeaf a) (EqLeaf a) + +class (Eq a) => EqClass a where + eqc :: a -> Char + eqc x = '?' + +class (Ord a) => OrdClass a where + orda :: a -> Char + ordb :: a -> Char + ordc :: a -> Char + +instance (Eq a) => EqClass (EqTree a) where + eqc x = 'a' + +default (Integer, Rational) + +-- HsBinds stuff + +singlebind x = x + +bindwith :: (OrdClass a, OrdClass b) => a -> b -> b +bindwith a b = b + +reca a = recb a +recb a = reca a + +(~(a,b,c)) | nullity b = a + | nullity c = a + | otherwise = a + where + nullity = null + +-- HsMatches stuff + +mat a b c d | foof a b = d + | foof a c = d + | foof b c = d + where + foof a b = a == b + +-- HsExpr stuff +expr a b c d + = a + + (:) a b + + (a : b) + + (1 - 'c' - "abc" - 1.293) + + ( \ x y z -> x ) 42 + + (9 *) + + (* 8) + + (case x of + [] | null x -> 99 + | otherwise -> 98 + | True -> 97 + where + null x = False + ) + + [ z | z <- c, isSpace z ] + + let y = foo + in y + + [1,2,3,4] + + (4,3,2,1) + + (4 :: Num a => a) + + (if 42 == 42.0 then 1 else 4) + + [1..] + + [2,4..] + + [3..5] + + [4,8..999] + +-- HsPat stuff +f _ x 1 1.93 'c' "dog" ~y z@(Foo a b) (c `Bar` d) [1,2] (3,4) (n+42) = y + +-- HsLit stuff -- done above + +-- HsTypes stuff +g :: (Num a, Eq b) => Foo a -> [b] -> (a,a,a) -> b +g x y z = head y diff --git a/ghc/compiler/tests/reader/read001.stderr b/ghc/compiler/tests/reader/read001.stderr new file mode 100644 index 0000000..997116b --- /dev/null +++ b/ghc/compiler/tests/reader/read001.stderr @@ -0,0 +1,593 @@ +Parsed, Haskellised: +module OneOfEverything ( + fixn, + FooData, + FooDataB(..), + FooDataC(..), + EqTree(EqLeaf, EqBranch), + EqClass(..), + OrdClass(orda, ordb), + OneC.., + OneOfEverything.. + ) where +import Prelude {- + interface Prelude where + import PreludeBuiltin ( trace, Char ) + import PreludeCore ( Bool, String, ReadS, ShowS, Text ) + import PreludeRatio ( + %, numerator, denominator, approxRational ) + import PreludeComplex ( + realPart, + imagPart, + conjugate, + mkPolar, + cis, + polar, + magnitude, + phase ) + import PreludeList ( + head, + last, + tail, + init, + null, + \\, + genericLength, + length, + !!, + filter, + partition, + foldl1, + scanl, + scanl1, + foldr1, + scanr, + scanr1, + iterate, + repeat, + cycle, + take, + drop, + splitAt, + takeWhile, + dropWhile, + span, + break, + lines, + words, + unlines, + unwords, + nub, + reverse, + and, + or, + any, + all, + elem, + notElem, + sum, + product, + sums, + products, + maximum, + minimum, + concat, + transpose, + zip, + zip3, + zip4, + zip5, + zip6, + zip7, + zipWith, + zipWith3, + zipWith4, + zipWith5, + zipWith6, + zipWith7, + unzip, + unzip3, + unzip4, + unzip5, + unzip6, + unzip7 ) + import PreludeArray ( + array, + listArray, + !, + bounds, + indices, + elems, + assocs, + accumArray, + //, + accum, + amap, + ixmap ) + import PreludeText ( + reads, + shows, + show, + read, + showChar, + readLitChar, + showLitChar, + readSigned, + showSigned, + readDec, + showInt, + readFloat, + showFloat ) + import PreludeIO ( + stdin, + stdout, + stderr, + stdecho, + done, + readFile, + writeFile, + appendFile, + readBinFile, + writeBinFile, + appendBinFile, + deleteFile, + statusFile, + readChan, + appendChan, + readBinChan, + appendBinChan, + statusChan, + echo, + getArgs, + getProgName, + getEnv, + setEnv, + abort, + exit, + print, + prints, + interact ) + instance (Eq a, Eq b) => Eq (a, b) + instance (Ord a, Ord b) => Ord (a, b) + instance (Ix a, Ix b) => Ix (a, b) + instance (Text a, Text b) => Text (a, b) + instance (Binary a, Binary b) => Binary (a, b) + instance (Eq a, Eq b, Eq c) => Eq (a, b, c) + instance (Ord a, Ord b, Ord c) => Ord (a, b, c) + instance (Ix a, Ix b, Ix c) => Ix (a, b, c) + instance (Text a, Text b, Text c) => Text (a, b, c) + instance (Binary a, Binary b, Binary c) => Binary (a, b, c) + instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) + instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) + instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) + instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) + instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, + b, + c, + d) + ^ :: (Num b, Integral a) => b -> a -> b + ^^ :: (Fractional b, Integral a) => b -> a -> b + appendBin :: Bin -> Bin -> Bin + asTypeOf :: a -> a -> a + atan2 :: RealFloat a => a -> a -> a + chr :: Int -> Char + fromIntegral :: (Integral a, Num b) => a -> b + fromRealFrac :: (RealFrac a, Fractional b) => a -> b + gcd :: Integral a => a -> a -> a + isAlpha :: Char -> Bool + isAlphanum :: Char -> Bool + isAscii :: Char -> Bool + isControl :: Char -> Bool + isDigit :: Char -> Bool + isLower :: Char -> Bool + isNullBin :: Bin -> Bool + isPrint :: Char -> Bool + isSpace :: Char -> Bool + isUpper :: Char -> Bool + lcm :: Integral a => a -> a -> a + maxChar :: Char + maxInt :: Int + minChar :: Char + minInt :: Int + nullBin :: Bin + ord :: Char -> Int + subtract :: Num a => a -> a -> a + toLower :: Char -> Char + toUpper :: Char -> Char + until :: (a -> Bool) -> (a -> a) -> a -> a + trace :: String -> a -> a + % :: Integral a => a -> a -> Ratio a + numerator :: Integral a => Ratio a -> a + denominator :: Integral a => Ratio a -> a + approxRational :: RealFrac a => a -> a -> Rational + cis :: RealFloat a => a -> Complex a + conjugate :: RealFloat a => Complex a -> Complex a + imagPart :: RealFloat a => Complex a -> a + magnitude :: RealFloat a => Complex a -> a + mkPolar :: RealFloat a => a -> a -> Complex a + phase :: RealFloat a => Complex a -> a + polar :: RealFloat a => Complex a -> (a, a) + realPart :: RealFloat a => Complex a -> a + !! :: Integral a => [b] -> a -> b + \\ :: Eq a => [a] -> [a] -> [a] + all :: (a -> Bool) -> [a] -> Bool + and :: [Bool] -> Bool + any :: (a -> Bool) -> [a] -> Bool + break :: (a -> Bool) -> [a] -> ([a], [a]) + concat :: [[a]] -> [a] + cycle :: [a] -> [a] + drop :: Integral a => a -> [b] -> [b] + dropWhile :: (a -> Bool) -> [a] -> [a] + elem :: Eq a => a -> [a] -> Bool + filter :: (a -> Bool) -> [a] -> [a] + foldl1 :: (a -> a -> a) -> [a] -> a + foldr1 :: (a -> a -> a) -> [a] -> a + genericLength :: Num b => [a] -> b + head :: [a] -> a + init :: [a] -> [a] + iterate :: (a -> a) -> a -> [a] + last :: [a] -> a + length :: [a] -> Int + lines :: [Char] -> [[Char]] + maximum :: Ord a => [a] -> a + minimum :: Ord a => [a] -> a + notElem :: Eq a => a -> [a] -> Bool + nub :: Eq a => [a] -> [a] + null :: [a] -> Bool + or :: [Bool] -> Bool + partition :: (a -> Bool) -> [a] -> ([a], [a]) + product :: Num a => [a] -> a + products :: Num a => [a] -> [a] + repeat :: a -> [a] + reverse :: [a] -> [a] + scanl :: (b -> a -> b) -> b -> [a] -> [b] + scanl1 :: (a -> a -> a) -> [a] -> [a] + scanr :: (a -> b -> b) -> b -> [a] -> [b] + scanr1 :: (a -> a -> a) -> [a] -> [a] + span :: (a -> Bool) -> [a] -> ([a], [a]) + splitAt :: Integral a => a -> [b] -> ([b], [b]) + sum :: Num a => [a] -> a + sums :: Num a => [a] -> [a] + tail :: [a] -> [a] + take :: Integral a => a -> [b] -> [b] + takeWhile :: (a -> Bool) -> [a] -> [a] + transpose :: [[a]] -> [[a]] + unlines :: [[Char]] -> [Char] + unwords :: [[Char]] -> [Char] + unzip :: [(a, b)] -> ([a], [b]) + unzip3 :: [(a, b, c)] -> ([a], [b], [c]) + unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) + unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e]) + unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f]) + unzip7 :: + [(a, b, c, d, e, f, g)] + -> ([a], [b], [c], [d], [e], [f], [g]) + words :: [Char] -> [[Char]] + zip :: [a] -> [b] -> [(a, b)] + zip3 :: [a] -> [b] -> [c] -> [(a, b, c)] + zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] + zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)] + zip6 :: + [a] + -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)] + zip7 :: + [a] + -> [b] + -> [c] + -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)] + zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] + zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] + zipWith4 :: + (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] + zipWith5 :: + (a -> b -> c -> d -> e -> f) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] + zipWith6 :: + (a -> b -> c -> d -> e -> f -> g) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] + zipWith7 :: + (a -> b -> c -> d -> e -> f -> g -> h) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h] + ! :: Ix a => Array a b -> a -> b + // :: Ix a => Array a b -> [Assoc a b] -> Array a b + accum :: + Ix b => (c -> a -> c) + -> Array b c -> [Assoc b a] -> Array b c + accumArray :: + Ix b => (c -> a -> c) + -> c -> (b, b) -> [Assoc b a] -> Array b c + amap :: Ix b => (a -> c) -> Array b a -> Array b c + array :: Ix a => (a, a) -> [Assoc a b] -> Array a b + assocs :: Ix a => Array a b -> [Assoc a b] + bounds :: Ix b => Array b a -> (b, b) + elems :: Ix a => Array a b -> [b] + indices :: Ix b => Array b a -> [b] + ixmap :: + (Ix b, Ix a) => (b, b) -> (b -> a) -> Array a c -> Array b c + listArray :: Ix a => (a, a) -> [b] -> Array a b + read :: Text a => [Char] -> a + readDec :: Integral a => [Char] -> [(a, [Char])] + readFloat :: RealFloat a => [Char] -> [(a, [Char])] + readLitChar :: [Char] -> [(Char, [Char])] + readSigned :: + Real a => ([Char] -> [(a, [Char])]) + -> [Char] -> [(a, [Char])] + reads :: Text a => [Char] -> [(a, [Char])] + show :: Text a => a -> [Char] + showChar :: Char -> [Char] -> [Char] + showFloat :: RealFloat a => a -> [Char] -> [Char] + showInt :: Integral a => a -> [Char] -> [Char] + showLitChar :: Char -> [Char] -> [Char] + showSigned :: + Real a => (a -> [Char] -> [Char]) + -> Int -> a -> [Char] -> [Char] + shows :: Text a => a -> [Char] -> [Char] + abort :: IOError -> [Response] -> [Request] + appendBinChan :: + [Char] + -> Bin + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + appendBinFile :: + [Char] + -> Bin + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + appendChan :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + appendFile :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + binDispatch :: + (IOError -> [Response] -> a) + -> (Bin -> [Response] -> a) -> [Response] -> a + deleteFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + done :: [Response] -> [Request] + echo :: + Bool + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + exit :: IOError -> [Response] -> [Request] + getArgs :: + (IOError -> [Response] -> [Request]) + -> ([[Char]] -> [Response] -> [Request]) + -> [Response] -> [Request] + getEnv :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + getProgName :: + (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + interact :: ([Char] -> [Char]) -> [Response] -> [Request] + print :: Text a => a -> [Response] -> [Request] + prints :: Text a => a -> [Char] -> [Response] -> [Request] + readBinChan :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> (Bin -> [Response] -> [Request]) + -> [Response] -> [Request] + readBinFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> (Bin -> [Response] -> [Request]) + -> [Response] -> [Request] + readChan :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + readFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + setEnv :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + statusChan :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + statusFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + stdecho :: [Char] + stderr :: [Char] + stdin :: [Char] + stdout :: [Char] + strDispatch :: + (IOError -> [Response] -> a) + -> ([Char] -> [Response] -> a) -> [Response] -> a + strListDispatch :: + (IOError -> [Response] -> a) + -> ([[Char]] -> [Response] -> a) -> [Response] -> a + succDispatch :: + (IOError -> [Response] -> a) + -> ([Response] -> a) -> [Response] -> a + writeBinFile :: + [Char] + -> Bin + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + writeFile :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + -} +import OneA {- + interface OneA where + import OneB ( fB ) renaming (fB to fBa) + type SynA = Float + data DataAA + data Ord a => DataAB a + = ConAB1 a + | ConAB2 + deriving (Text) + class Ord a => ClassA a where + clsA :: a -> String + instance ClassA Int + fA :: a -> a + -} +renaming (fA to renamedA) +import OneB {- + interface OneB where + fB :: a -> a + -} + (fB) +import OneC {- + interface OneC where + fC :: a -> a + -} + hiding (fC) +import OneC {- + interface OneC where + fC :: a -> a + -} + hiding (fC) +renaming (fc to renamedC) +infixr 9 . +infixr 8 ^ +infixr 8 ^^ +infixr 3 && +infixr 2 || +infixr 0 $ +infixl 9 ! +infixl 9 // +infix 1 := +infix 6 :+ +infixr 8 ** +infixl 7 * +infixl 7 / +infixl 7 `quot` +infixl 7 `rem` +infixl 7 `div` +infixl 7 `mod` +infixl 6 + +infixl 6 - +infix 4 == +infix 4 /= +infix 4 < +infix 4 <= +infix 4 >= +infix 4 > +infixl 9 !! +infix 5 \\ +infix 4 `elem` +infix 4 `notElem` +infixl 7 % +infix 6 `fixn` +infixl 7 +# +infixr 8 `fixr` +type Pair a b = (a, b) +data FooData + = FooCon Int +data FooDataB + = FooConB Double +data Eq a => EqTree a + = EqLeaf a + | EqBranch (EqLeaf a) (EqLeaf a) +class Eq a => EqClass a where + eqc :: a -> Char + eqc x = '?' +class Ord a => OrdClass a where + orda :: a -> Char + ordb :: a -> Char + ordc :: a -> Char +instance Eq a => EqClass EqTree a where + eqc x = 'a' +default (Integer, Rational) +bindwith :: (OrdClass a, OrdClass b) => a -> b -> b +g :: (Num a, Eq b) => Foo a -> [b] -> (a, a, a) -> b +{- rec -} +fixn x y = x +fixl x y = x +fixr x y = x +singlebind + x = x +bindwith + a b = b +reca a = recb a +recb a = reca a +~(a, b, c) + | nullity b = a + | nullity c = a + | otherwise = a + where + {- rec -} + nullity = null +mat a b c d | foof a b = d + | foof a c = d + | foof b c = d + where + {- rec -} + foof a b = a == b +expr a b c d = ((((((((a + ((:) a b)) + (a : b)) + + (((1 - 'c') - "abc") - 1.2929999999999999)) + + ((\ x y z -> x) 42)) + + ((9 *))) + + ((* 8))) + + (case x of + [] | null x -> 99 + | otherwise -> 98 + | True -> 97 + where + {- rec -} + null x = False)) + + ([ z | z <- c, isSpace z ])) + + (let + {- rec -} + y = foo + in (((((((y + ([1, 2, 3, 4])) + ((4, 3, 2, 1))) + + ((4 :: Num a => a))) + + (if 42 == 42.000000000000000 then 1 else 4)) + + ([ 1 .. ])) + + ([ 2, 4 .. ])) + + ([ 3 .. 5 ])) + + ([ 4, 8 .. 999 ])) +f _ + x + 1 + 1.9299999999999999 + 'c' + "dog" + ~y + (z@(Foo a b)) + (c Bar d) + [1, 2] + (3, 4) + (n+42) = y +g x y z = head y + +Enter trace(0): +doRenamings:tossing them away +Exit trace(0) + +Unknown name in export list: FooDataC +"read001.hs", line 38: undefined type constructor: EqLeaf +"read001.hs", line 38: undefined type constructor: EqLeaf +"read001.hs", line 112: undefined type constructor: Foo +"read001.hs", line 95: undefined value: x +"read001.hs", line 95: undefined value: x +"read001.hs", line 95: undefined value: foo +"read001.hs", line 107: undefined value: Foo +"read001.hs", line 107: undefined value: Bar +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/reader/read002.hs b/ghc/compiler/tests/reader/read002.hs new file mode 100644 index 0000000..9cc2153 --- /dev/null +++ b/ghc/compiler/tests/reader/read002.hs @@ -0,0 +1,13 @@ +--!!! tests fixity reading and printing + +infixl 1 `f` +infixr 2 \\\ +infix 3 :==> +infix 4 `MkFoo` + +data Foo = MkFoo Int | Float :==> Double + +x `f` y = x + +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) xs ys = xs diff --git a/ghc/compiler/tests/reader/read002.stderr b/ghc/compiler/tests/reader/read002.stderr new file mode 100644 index 0000000..f8a8600 --- /dev/null +++ b/ghc/compiler/tests/reader/read002.stderr @@ -0,0 +1,466 @@ +Parsed, Haskellised: +module Main where +import Prelude {- + interface Prelude where + import PreludeBuiltin ( trace, Char ) + import PreludeCore ( Bool, String, ReadS, ShowS, Text ) + import PreludeRatio ( + %, numerator, denominator, approxRational ) + import PreludeComplex ( + realPart, + imagPart, + conjugate, + mkPolar, + cis, + polar, + magnitude, + phase ) + import PreludeList ( + head, + last, + tail, + init, + null, + \\, + genericLength, + length, + !!, + filter, + partition, + foldl1, + scanl, + scanl1, + foldr1, + scanr, + scanr1, + iterate, + repeat, + cycle, + take, + drop, + splitAt, + takeWhile, + dropWhile, + span, + break, + lines, + words, + unlines, + unwords, + nub, + reverse, + and, + or, + any, + all, + elem, + notElem, + sum, + product, + sums, + products, + maximum, + minimum, + concat, + transpose, + zip, + zip3, + zip4, + zip5, + zip6, + zip7, + zipWith, + zipWith3, + zipWith4, + zipWith5, + zipWith6, + zipWith7, + unzip, + unzip3, + unzip4, + unzip5, + unzip6, + unzip7 ) + import PreludeArray ( + array, + listArray, + !, + bounds, + indices, + elems, + assocs, + accumArray, + //, + accum, + amap, + ixmap ) + import PreludeText ( + reads, + shows, + show, + read, + showChar, + readLitChar, + showLitChar, + readSigned, + showSigned, + readDec, + showInt, + readFloat, + showFloat ) + import PreludeIO ( + stdin, + stdout, + stderr, + stdecho, + done, + readFile, + writeFile, + appendFile, + readBinFile, + writeBinFile, + appendBinFile, + deleteFile, + statusFile, + readChan, + appendChan, + readBinChan, + appendBinChan, + statusChan, + echo, + getArgs, + getProgName, + getEnv, + setEnv, + abort, + exit, + print, + prints, + interact ) + instance (Eq a, Eq b) => Eq (a, b) + instance (Ord a, Ord b) => Ord (a, b) + instance (Ix a, Ix b) => Ix (a, b) + instance (Text a, Text b) => Text (a, b) + instance (Binary a, Binary b) => Binary (a, b) + instance (Eq a, Eq b, Eq c) => Eq (a, b, c) + instance (Ord a, Ord b, Ord c) => Ord (a, b, c) + instance (Ix a, Ix b, Ix c) => Ix (a, b, c) + instance (Text a, Text b, Text c) => Text (a, b, c) + instance (Binary a, Binary b, Binary c) => Binary (a, b, c) + instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) + instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) + instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) + instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) + instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, + b, + c, + d) + ^ :: (Num b, Integral a) => b -> a -> b + ^^ :: (Fractional b, Integral a) => b -> a -> b + appendBin :: Bin -> Bin -> Bin + asTypeOf :: a -> a -> a + atan2 :: RealFloat a => a -> a -> a + chr :: Int -> Char + fromIntegral :: (Integral a, Num b) => a -> b + fromRealFrac :: (RealFrac a, Fractional b) => a -> b + gcd :: Integral a => a -> a -> a + isAlpha :: Char -> Bool + isAlphanum :: Char -> Bool + isAscii :: Char -> Bool + isControl :: Char -> Bool + isDigit :: Char -> Bool + isLower :: Char -> Bool + isNullBin :: Bin -> Bool + isPrint :: Char -> Bool + isSpace :: Char -> Bool + isUpper :: Char -> Bool + lcm :: Integral a => a -> a -> a + maxChar :: Char + maxInt :: Int + minChar :: Char + minInt :: Int + nullBin :: Bin + ord :: Char -> Int + subtract :: Num a => a -> a -> a + toLower :: Char -> Char + toUpper :: Char -> Char + until :: (a -> Bool) -> (a -> a) -> a -> a + trace :: String -> a -> a + % :: Integral a => a -> a -> Ratio a + numerator :: Integral a => Ratio a -> a + denominator :: Integral a => Ratio a -> a + approxRational :: RealFrac a => a -> a -> Rational + cis :: RealFloat a => a -> Complex a + conjugate :: RealFloat a => Complex a -> Complex a + imagPart :: RealFloat a => Complex a -> a + magnitude :: RealFloat a => Complex a -> a + mkPolar :: RealFloat a => a -> a -> Complex a + phase :: RealFloat a => Complex a -> a + polar :: RealFloat a => Complex a -> (a, a) + realPart :: RealFloat a => Complex a -> a + !! :: Integral a => [b] -> a -> b + \\ :: Eq a => [a] -> [a] -> [a] + all :: (a -> Bool) -> [a] -> Bool + and :: [Bool] -> Bool + any :: (a -> Bool) -> [a] -> Bool + break :: (a -> Bool) -> [a] -> ([a], [a]) + concat :: [[a]] -> [a] + cycle :: [a] -> [a] + drop :: Integral a => a -> [b] -> [b] + dropWhile :: (a -> Bool) -> [a] -> [a] + elem :: Eq a => a -> [a] -> Bool + filter :: (a -> Bool) -> [a] -> [a] + foldl1 :: (a -> a -> a) -> [a] -> a + foldr1 :: (a -> a -> a) -> [a] -> a + genericLength :: Num b => [a] -> b + head :: [a] -> a + init :: [a] -> [a] + iterate :: (a -> a) -> a -> [a] + last :: [a] -> a + length :: [a] -> Int + lines :: [Char] -> [[Char]] + maximum :: Ord a => [a] -> a + minimum :: Ord a => [a] -> a + notElem :: Eq a => a -> [a] -> Bool + nub :: Eq a => [a] -> [a] + null :: [a] -> Bool + or :: [Bool] -> Bool + partition :: (a -> Bool) -> [a] -> ([a], [a]) + product :: Num a => [a] -> a + products :: Num a => [a] -> [a] + repeat :: a -> [a] + reverse :: [a] -> [a] + scanl :: (b -> a -> b) -> b -> [a] -> [b] + scanl1 :: (a -> a -> a) -> [a] -> [a] + scanr :: (a -> b -> b) -> b -> [a] -> [b] + scanr1 :: (a -> a -> a) -> [a] -> [a] + span :: (a -> Bool) -> [a] -> ([a], [a]) + splitAt :: Integral a => a -> [b] -> ([b], [b]) + sum :: Num a => [a] -> a + sums :: Num a => [a] -> [a] + tail :: [a] -> [a] + take :: Integral a => a -> [b] -> [b] + takeWhile :: (a -> Bool) -> [a] -> [a] + transpose :: [[a]] -> [[a]] + unlines :: [[Char]] -> [Char] + unwords :: [[Char]] -> [Char] + unzip :: [(a, b)] -> ([a], [b]) + unzip3 :: [(a, b, c)] -> ([a], [b], [c]) + unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) + unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e]) + unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f]) + unzip7 :: + [(a, b, c, d, e, f, g)] + -> ([a], [b], [c], [d], [e], [f], [g]) + words :: [Char] -> [[Char]] + zip :: [a] -> [b] -> [(a, b)] + zip3 :: [a] -> [b] -> [c] -> [(a, b, c)] + zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] + zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)] + zip6 :: + [a] + -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)] + zip7 :: + [a] + -> [b] + -> [c] + -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)] + zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] + zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] + zipWith4 :: + (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e] + zipWith5 :: + (a -> b -> c -> d -> e -> f) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] + zipWith6 :: + (a -> b -> c -> d -> e -> f -> g) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] + zipWith7 :: + (a -> b -> c -> d -> e -> f -> g -> h) + -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h] + ! :: Ix a => Array a b -> a -> b + // :: Ix a => Array a b -> [Assoc a b] -> Array a b + accum :: + Ix b => (c -> a -> c) + -> Array b c -> [Assoc b a] -> Array b c + accumArray :: + Ix b => (c -> a -> c) + -> c -> (b, b) -> [Assoc b a] -> Array b c + amap :: Ix b => (a -> c) -> Array b a -> Array b c + array :: Ix a => (a, a) -> [Assoc a b] -> Array a b + assocs :: Ix a => Array a b -> [Assoc a b] + bounds :: Ix b => Array b a -> (b, b) + elems :: Ix a => Array a b -> [b] + indices :: Ix b => Array b a -> [b] + ixmap :: + (Ix b, Ix a) => (b, b) -> (b -> a) -> Array a c -> Array b c + listArray :: Ix a => (a, a) -> [b] -> Array a b + read :: Text a => [Char] -> a + readDec :: Integral a => [Char] -> [(a, [Char])] + readFloat :: RealFloat a => [Char] -> [(a, [Char])] + readLitChar :: [Char] -> [(Char, [Char])] + readSigned :: + Real a => ([Char] -> [(a, [Char])]) + -> [Char] -> [(a, [Char])] + reads :: Text a => [Char] -> [(a, [Char])] + show :: Text a => a -> [Char] + showChar :: Char -> [Char] -> [Char] + showFloat :: RealFloat a => a -> [Char] -> [Char] + showInt :: Integral a => a -> [Char] -> [Char] + showLitChar :: Char -> [Char] -> [Char] + showSigned :: + Real a => (a -> [Char] -> [Char]) + -> Int -> a -> [Char] -> [Char] + shows :: Text a => a -> [Char] -> [Char] + abort :: IOError -> [Response] -> [Request] + appendBinChan :: + [Char] + -> Bin + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + appendBinFile :: + [Char] + -> Bin + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + appendChan :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + appendFile :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + binDispatch :: + (IOError -> [Response] -> a) + -> (Bin -> [Response] -> a) -> [Response] -> a + deleteFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + done :: [Response] -> [Request] + echo :: + Bool + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + exit :: IOError -> [Response] -> [Request] + getArgs :: + (IOError -> [Response] -> [Request]) + -> ([[Char]] -> [Response] -> [Request]) + -> [Response] -> [Request] + getEnv :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + getProgName :: + (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + interact :: ([Char] -> [Char]) -> [Response] -> [Request] + print :: Text a => a -> [Response] -> [Request] + prints :: Text a => a -> [Char] -> [Response] -> [Request] + readBinChan :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> (Bin -> [Response] -> [Request]) + -> [Response] -> [Request] + readBinFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> (Bin -> [Response] -> [Request]) + -> [Response] -> [Request] + readChan :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + readFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + setEnv :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + statusChan :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + statusFile :: + [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Char] -> [Response] -> [Request]) + -> [Response] -> [Request] + stdecho :: [Char] + stderr :: [Char] + stdin :: [Char] + stdout :: [Char] + strDispatch :: + (IOError -> [Response] -> a) + -> ([Char] -> [Response] -> a) -> [Response] -> a + strListDispatch :: + (IOError -> [Response] -> a) + -> ([[Char]] -> [Response] -> a) -> [Response] -> a + succDispatch :: + (IOError -> [Response] -> a) + -> ([Response] -> a) -> [Response] -> a + writeBinFile :: + [Char] + -> Bin + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + writeFile :: + [Char] + -> [Char] + -> (IOError -> [Response] -> [Request]) + -> ([Response] -> [Request]) -> [Response] -> [Request] + -} +infixr 9 . +infixr 8 ^ +infixr 8 ^^ +infixr 3 && +infixr 2 || +infixr 0 $ +infixl 9 ! +infixl 9 // +infix 1 := +infix 6 :+ +infixr 8 ** +infixl 7 * +infixl 7 / +infixl 7 `quot` +infixl 7 `rem` +infixl 7 `div` +infixl 7 `mod` +infixl 6 + +infixl 6 - +infix 4 == +infix 4 /= +infix 4 < +infix 4 <= +infix 4 >= +infix 4 > +infixl 9 !! +infix 5 \\ +infix 4 `elem` +infix 4 `notElem` +infixl 7 % +infixl 1 `f` +infixr 2 \\\ +infix 3 :==> +infix 4 `MkFoo` +data Foo + = MkFoo Int + | (:==>) Float Double +\\\ :: Eq a => [a] -> [a] -> [a] +{- rec -} +f x y = x +(\\\) + xs ys = xs + diff --git a/ghc/compiler/tests/reader/read003.hs b/ghc/compiler/tests/reader/read003.hs new file mode 100644 index 0000000..0bb8a24 --- /dev/null +++ b/ghc/compiler/tests/reader/read003.hs @@ -0,0 +1,5 @@ +~(a,b,c) | nullity b = a + | nullity c = a + | otherwise = a + where + nullity = null diff --git a/ghc/compiler/tests/reader/read004.hs b/ghc/compiler/tests/reader/read004.hs new file mode 100644 index 0000000..77ab5a0 --- /dev/null +++ b/ghc/compiler/tests/reader/read004.hs @@ -0,0 +1,43 @@ +--!!! string gaps +--!!! + +----------- + +main = appendChan stdout "\ + +\Some girls give me money\n\ + +\Some girls buy me clothes\n\ + +\..." + exit done + +----------- + +main2 = appendChan stdout "\ +\ \ +..." exit done + +----------- + +main3 = appendChan stdout "\ + +\Some girls give me money\n\ +-- and here is a comment +\Some girls buy me clothes\n\ + +\..." + exit done + +----------- + +main3 = appendChan stdout "\ +{- + and here is a nested {- comment -} +-} +\Some girls give me money\n\ + +\Some girls buy me clothes\n\ + +\..." + exit done diff --git a/ghc/compiler/tests/reader/read004.stderr b/ghc/compiler/tests/reader/read004.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/rename/Int10.hi b/ghc/compiler/tests/rename/Int10.hi new file mode 100644 index 0000000..1d1439b --- /dev/null +++ b/ghc/compiler/tests/rename/Int10.hi @@ -0,0 +1,21 @@ +interface Int10 where + +data T1 a = C1 a + +data T2 a b = T2C1 a | T2C2 b + +data T3 a b c = T3C1 a | T3C2 b | T3C3 c + +data T4 a b c d = T4C1 a | T4C2 b | T4C3 c | T4C4 d + +data T5 a b c d e = T5C1 a | T5C2 b | T5C3 c | T5C4 d | T5C5 e + +data T6 a = T6C6 a + +data T7 a b = T7C6 a | T7C7 b + +data T8 a b c = T8C1 a | T8C2 b | T8C3 c + +data T9 a b c d = T9C1 a | T9C2 b | T9C3 c | T9C4 d + +data T10 a b c d e = T10C1 a | T10C2 b | T10C3 c | T10C4 d | T10C5 e diff --git a/ghc/compiler/tests/rename/Jmakefile b/ghc/compiler/tests/rename/Jmakefile new file mode 100644 index 0000000..b018f9d --- /dev/null +++ b/ghc/compiler/tests/rename/Jmakefile @@ -0,0 +1,29 @@ +#define IHaveSubdirs + +SUBDIRS = bevan-bug-1 + +runtests:: + @echo '###############################################################' + @echo '# Validation tests for the renamer (incl dependency analysis) #' + @echo '###############################################################' + +TEST_FLAGS=/*-ddump-rn1 -ddump-rn2 -ddump-rn3*/ -ddump-rn4 + +RunStdTest(rn001,$(GHC), -noC $(TEST_FLAGS) rn001.hs -o2 rn001.stderr -x1) +RunStdTest(rn002,$(GHC), -noC $(TEST_FLAGS) rn002.hs -o2 rn002.stderr -x1) +RunStdTest(rn003,$(GHC), -noC $(TEST_FLAGS) rn003.hs -o2 rn003.stderr) +RunStdTest(rn004,$(GHC), -noC $(TEST_FLAGS) rn004.hs -o2 rn004.stderr -x1) +RunStdTest(rn005,$(GHC), -noC $(TEST_FLAGS) rn005.hs -o2 rn005.stderr) +RunStdTest(rn006,$(GHC), -noC $(TEST_FLAGS) rn006.hs -o2 rn006.stderr) +RunStdTest(rn007,$(GHC), -noC $(TEST_FLAGS) rn007.hs -o2 rn007.stderr -x1) +RunStdTest(rn008,$(GHC), -noC $(TEST_FLAGS) rn008.hs -o2 rn008.stderr -x1) +RunStdTest(rn009,$(GHC), -noC $(TEST_FLAGS) rn009.hs -o2 rn009.stderr) +RunStdTest(rn010,$(GHC), -noC $(TEST_FLAGS) rn010.hs -o2 rn010.stderr) +RunStdTest(rn011,$(GHC), -noC $(TEST_FLAGS) rn011.hs -o2 rn011.stderr) +RunStdTest(rn012,$(GHC), -noC $(TEST_FLAGS) rn012.hs -o2 rn012.stderr) +RunStdTest(rn013,$(GHC), -noC $(TEST_FLAGS) rn013.hs -o2 rn013.stderr) +RunStdTest(rn014,$(GHC), -noC $(TEST_FLAGS) rn014.hs -o2 rn014.stderr) +RunStdTest(rn015,$(GHC), -noC $(TEST_FLAGS) rn015.hs -o2 rn015.stderr -x1) +RunStdTest(rn016,$(GHC), -noC $(TEST_FLAGS) rn016.hs -o2 rn016.stderr) +XCOMM for rn017, the interface produced is what matters +RunStdTest(rn017,$(GHC), -noC $(TEST_FLAGS) -hi rn017.hs -o2 rn017.stderr) diff --git a/ghc/compiler/tests/rename/Rn016.hi b/ghc/compiler/tests/rename/Rn016.hi new file mode 100644 index 0000000..b098b36 --- /dev/null +++ b/ghc/compiler/tests/rename/Rn016.hi @@ -0,0 +1,11 @@ +interface Rn016 where +import X(K) + +class K a where + op1 :: a -> a -> a + op2 :: Int -> a + +instance K Int +instance K Bool +instance K [a] + diff --git a/ghc/compiler/tests/rename/Rn017.hi b/ghc/compiler/tests/rename/Rn017.hi new file mode 100644 index 0000000..f5a4264 --- /dev/null +++ b/ghc/compiler/tests/rename/Rn017.hi @@ -0,0 +1,8 @@ +interface Rn017 where +import Bar (a, b, Wibble(..)) +import Burf(Wobble) +a :: Int -> Int +b :: Int -> Int +c :: Int -> Int +data Wibble = MkWibble Wobble +data Wobble diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Jmakefile b/ghc/compiler/tests/rename/bevan-bug-1/Jmakefile new file mode 100644 index 0000000..bdf38e7 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Jmakefile @@ -0,0 +1,4 @@ +XCOMM a renamer bug sent in by Stephen Bevan; +XCOMM going as far as -ddump-tc guarantees that renaming was happy. + +RunStdTest(bevan-bug-1,$(GHC), -noC -ddump-tc Lexer_Ops.lhs -o2 bevan-bug-1.stderr) diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Lexeme.hi b/ghc/compiler/tests/rename/bevan-bug-1/Lexeme.hi new file mode 100644 index 0000000..f98169a --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Lexeme.hi @@ -0,0 +1,18 @@ +interface Lexeme where +import Oberon_Id(Oberon_Id) +import Oberon_Integer(Oberon_Integer) +import Oberon_Real(Oberon_Real) +import Oberon_String(Oberon_String) +import Symbol(Symbol) +show_lexeme :: Lexeme -> [Char] -> [Char] + {-# ARITY show_lexeme = 0 #-} +data Lexeme = Symbol_Lexeme Symbol | Id_Lexeme Oberon_Id | Int_Lexeme Oberon_Integer | Real_Lexeme Oberon_Real | Long_Real_Lexeme Oberon_Real | String_Lexeme Oberon_String | Char_Lexeme Oberon_Integer | Error_Lexeme Char | EOF_Lexeme | Unterminated_String_Lexeme | Unterminated_Comment_Lexeme | Malformed_Hex_Integer | Malformed_Real_Number +instance Eq Lexeme + {-# ARITY (==) = 2 #-} + {-# ARITY (/=) = 0 #-} +instance Text Lexeme + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Buffer.hi b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Buffer.hi new file mode 100644 index 0000000..5764f49 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Buffer.hi @@ -0,0 +1,13 @@ +interface Lexer_Buffer where +add :: Char -> Lexer_Buffer -> Lexer_Buffer + {-# ARITY add = 2 #-} +empty :: Lexer_Buffer + {-# ARITY empty = 0 #-} +flush :: Lexer_Buffer -> Lexer_Buffer + {-# ARITY flush = 1 #-} +len :: Lexer_Buffer -> Int + {-# ARITY len = 1 #-} +to_string :: Lexer_Buffer -> [Char] + {-# ARITY to_string = 1 #-} +data Lexer_Buffer + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Combinators.hi b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Combinators.hi new file mode 100644 index 0000000..a554bbc --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Combinators.hi @@ -0,0 +1,11 @@ +interface Lexer_Combinators where +import Lexer_State(Lexer_State) +and_also :: (Lexer_State -> (b, Lexer_State)) -> (Lexer_State -> (a, Lexer_State)) -> Lexer_State -> (b, Lexer_State) + {-# ARITY and_also = 3 #-} +and_then :: (Lexer_State -> (a, Lexer_State)) -> (Lexer_State -> (b, Lexer_State)) -> Lexer_State -> (b, Lexer_State) + {-# ARITY and_then = 3 #-} +and_with :: (Lexer_State -> (a, Lexer_State)) -> (a -> Lexer_State -> (b, Lexer_State)) -> Lexer_State -> (b, Lexer_State) + {-# ARITY and_with = 3 #-} +return :: a -> Lexer_State -> (a, Lexer_State) + {-# ARITY return = 2 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Ops.lhs b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Ops.lhs new file mode 100644 index 0000000..b367957 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Ops.lhs @@ -0,0 +1,97 @@ + $Id: Lexer_Ops.lhs,v 1.1 1996/01/08 20:17:58 partain Exp $ + +>module Lexer_Ops where + +>import Lexer_Buffer(Lexer_Buffer, add, empty, flush, len, to_string) +> renaming +> (add to add_char, empty to empty_buffer, to_string to buffer_to_string) + +>import Lexer_Combinators(and_with, return) + +>import Lexer_State +> (Lexer_State,Lexer_Action(..),i_buffer,i_source_pos,p_buffer,p_source_pos) + +>import Oberon_Id(Oberon_Id,from_string) renaming (from_string to string_to_id) + +>import Oberon_Integer +> (Oberon_Integer, from_decimal_string, from_hex_string, from_int) +> renaming +> ( from_decimal_string to decimal_string_to_int +> , from_hex_string to hex_string_to_int +> ) + +>import Oberon_Real(Oberon_Real, from_string) renaming +> (from_string to string_to_real) + +>import Oberon_String(Oberon_String, from_string) renaming +> (from_string to string_to_string) + +>import Lexer_Combinators(and_then) + +>import Source_Position(Source_Position, next_line, shift_column, start) +> renaming (start to start_position) + +>t_source_pos transformer = +> p_source_pos `and_with` \pos -> +> i_source_pos (transformer pos) + +>t_buffer transformer = +> p_buffer `and_with` \buff -> +> i_buffer (transformer buff) + + +>buffer_len :: Lexer_Action Int +>buffer_len = +> p_buffer `and_with` \buff -> +> return (len buff) + + +>decimal_to_int :: Lexer_Action Oberon_Integer +>decimal_to_int = +> p_buffer `and_with` \buff -> +> return (decimal_string_to_int (buffer_to_string buff)) + +>flush_buffer :: Lexer_Action () +>flush_buffer = t_buffer flush + +>hex_to_int :: Lexer_Action Oberon_Integer +>hex_to_int = +> p_buffer `and_with` \buff -> +> return (hex_string_to_int (buffer_to_string buff)) + +>move_input_column :: Int -> Lexer_Action () +>move_input_column dist = t_source_pos (flip shift_column dist) + +>next_input_line :: Lexer_Action () +>next_input_line = t_source_pos next_line + +>store_char :: Char -> Lexer_Action () +>store_char c = t_buffer (add_char c) + +>to_char :: Lexer_Action Oberon_Integer +>to_char = +> p_buffer `and_with` \buff -> +> return ((from_int . toInteger . ord . head . buffer_to_string) buff) + +Converts the string in the buffer into a character (actually an +integer since characters are represented as integers). The +pre-condition is that there is exactly one character in the buffer +when this is called. + + +>to_id :: Lexer_Action Oberon_Id +>to_id = +> p_buffer `and_with` \buff -> +> return (string_to_id (buffer_to_string buff)) + +>to_real :: Lexer_Action Oberon_Real +>to_real = +> p_buffer `and_with` \buff -> +> return (string_to_real (buffer_to_string buff)) + +>to_string :: Lexer_Action Oberon_String +>to_string = +> p_buffer `and_with` \buff -> +> return (string_to_string (buffer_to_string buff)) + +% eof diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Lexer_State.hi b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_State.hi new file mode 100644 index 0000000..a06e093 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_State.hi @@ -0,0 +1,22 @@ +interface Lexer_State where +import Lexer_Buffer(Lexer_Buffer) +import Source_Position(Source_Position) +i_buffer :: Lexer_Buffer -> Lexer_State -> ((), Lexer_State) + {-# ARITY i_buffer = 2 #-} +i_input :: [Char] -> Lexer_State -> ((), Lexer_State) + {-# ARITY i_input = 2 #-} +i_source_pos :: Source_Position -> Lexer_State -> ((), Lexer_State) + {-# ARITY i_source_pos = 2 #-} +initial_state :: [Char] -> Lexer_State + {-# ARITY initial_state = 1 #-} +make :: [Char] -> Source_Position -> Lexer_Buffer -> Lexer_State + {-# ARITY make = 3 #-} +p_buffer :: Lexer_State -> (Lexer_Buffer, Lexer_State) + {-# ARITY p_buffer = 1 #-} +p_input :: Lexer_State -> ([Char], Lexer_State) + {-# ARITY p_input = 1 #-} +p_source_pos :: Lexer_State -> (Source_Position, Lexer_State) + {-# ARITY p_source_pos = 1 #-} +type Lexer_Action a = Lexer_State -> (a, Lexer_State) +data Lexer_State = Lexer_State [Char] Source_Position Lexer_Buffer + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Token.hi b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Token.hi new file mode 100644 index 0000000..68dff3b --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Lexer_Token.hi @@ -0,0 +1,16 @@ +interface Lexer_Token where +import Lexeme(Lexeme) +import Source_Position(Source_Position) +kind :: Token -> Lexeme + {-# ARITY kind = 1 #-} +make :: Source_Position -> Lexeme -> Token + {-# ARITY make = 2 #-} +position :: Token -> Source_Position + {-# ARITY position = 1 #-} +data Token = Token Lexeme Source_Position +instance Text Token + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Id.hi b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Id.hi new file mode 100644 index 0000000..18341f3 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Id.hi @@ -0,0 +1,15 @@ +interface Oberon_Id where +from_string :: [Char] -> Oberon_Id + {-# ARITY from_string = 1 #-} +to_string :: Oberon_Id -> [Char] + {-# ARITY to_string = 1 #-} +data Oberon_Id +instance Eq Oberon_Id + {-# ARITY (==) = 2 #-} + {-# ARITY (/=) = 0 #-} +instance Text Oberon_Id + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Integer.hi b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Integer.hi new file mode 100644 index 0000000..ef0f1ec --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Integer.hi @@ -0,0 +1,21 @@ +interface Oberon_Integer where +from_decimal_string :: [Char] -> Oberon_Integer + {-# ARITY from_decimal_string = 1 #-} +from_hex_string :: [Char] -> Oberon_Integer + {-# ARITY from_hex_string = 1 #-} +from_int :: Integer -> Oberon_Integer + {-# ARITY from_int = 1 #-} +isHexDigit :: Char -> Bool + {-# ARITY isHexDigit = 1 #-} +is_short_int :: Oberon_Integer -> Bool + {-# ARITY is_short_int = 1 #-} +data Oberon_Integer +instance Eq Oberon_Integer + {-# ARITY (==) = 2 #-} + {-# ARITY (/=) = 0 #-} +instance Text Oberon_Integer + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Real.hi b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Real.hi new file mode 100644 index 0000000..35f3544 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_Real.hi @@ -0,0 +1,13 @@ +interface Oberon_Real where +from_string :: [Char] -> Oberon_Real + {-# ARITY from_string = 0 #-} +data Oberon_Real +instance Eq Oberon_Real + {-# ARITY (==) = 2 #-} + {-# ARITY (/=) = 0 #-} +instance Text Oberon_Real + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Oberon_String.hi b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_String.hi new file mode 100644 index 0000000..fd1b17a --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Oberon_String.hi @@ -0,0 +1,13 @@ +interface Oberon_String where +from_string :: [Char] -> Oberon_String + {-# ARITY from_string = 1 #-} +data Oberon_String +instance Eq Oberon_String + {-# ARITY (==) = 2 #-} + {-# ARITY (/=) = 0 #-} +instance Text Oberon_String + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Source_Position.hi b/ghc/compiler/tests/rename/bevan-bug-1/Source_Position.hi new file mode 100644 index 0000000..f0583e9 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Source_Position.hi @@ -0,0 +1,18 @@ +interface Source_Position where +make :: Int -> Int -> Source_Position + {-# ARITY make = 2 #-} +next_line :: Source_Position -> Source_Position + {-# ARITY next_line = 1 #-} +shift_column :: Source_Position -> Int -> Source_Position + {-# ARITY shift_column = 2 #-} +show_pos :: Source_Position -> [Char] -> [Char] + {-# ARITY show_pos = 1 #-} +start :: Source_Position + {-# ARITY start = 0 #-} +data Source_Position = Source_Position Int Int +instance Text Source_Position + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/Symbol.hi b/ghc/compiler/tests/rename/bevan-bug-1/Symbol.hi new file mode 100644 index 0000000..048f321 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/Symbol.hi @@ -0,0 +1,12 @@ +interface Symbol where +data Symbol + = Ampersand_Symbol | And_Symbol | Array_Symbol | Bar_Symbol | By_Symbol | Begin_Symbol | Case_Symbol | Circumflex_Symbol | Close_Brace_Symbol | Close_Bracket_Symbol | Close_Paren_Symbol | Colon_Equal_Symbol | Colon_Symbol | Comma_Symbol | Const_Symbol | Div_Symbol | Do_Symbol | Dot_Dot_Symbol | Dot_Symbol | Else_Symbol | Elseif_Symbol | End_Symbol | Equal_Symbol | Exit_Symbol | For_Symbol | GE_Symbol | GT_Symbol | Hash_Symbol | If_Symbol | Import_Symbol | In_Symbol | Is_Symbol | LE_Symbol | LT_Symbol | Loop_Symbol | Minus_Symbol | Mod_Symbol | Module_Symbol | Nil_Symbol | Of_Symbol | Open_Brace_Symbol | Open_Bracket_Symbol | Open_Paren_Symbol | Or_Symbol | Plus_Symbol | Pointer_Symbol | Proc_Symbol | Record_Symbol | Repeat_Symbol | Return_Symbol | Semi_Colon_Symbol | Set_Symbol | Slash_Symbol | Star_Symbol | Tilde_Symbol | Then_Symbol | To_Symbol | Type_Symbol | Until_Symbol | Var_Symbol | With_Symbol | While_Symbol +instance Eq Symbol + {-# ARITY (==) = 2 #-} + {-# ARITY (/=) = 0 #-} +instance Text Symbol + {-# ARITY readsPrec = 0 #-} + {-# ARITY showsPrec = 2 #-} + {-# ARITY readList = 0 #-} + {-# ARITY showList = 0 #-} + diff --git a/ghc/compiler/tests/rename/bevan-bug-1/bevan-bug-1.stderr b/ghc/compiler/tests/rename/bevan-bug-1/bevan-bug-1.stderr new file mode 100644 index 0000000..1fef6c9 --- /dev/null +++ b/ghc/compiler/tests/rename/bevan-bug-1/bevan-bug-1.stderr @@ -0,0 +1,147 @@ +Typechecked: +AbsBinds [] [] [(t_source_pos.t2, Lexer_Ops.t_source_pos)] + {- nonrec -} + t_source_pos.t2 :: + (Source_Position.Source_Position -> Source_Position.Source_Position) + -> Lexer_State.Lexer_State -> ((), Lexer_State.Lexer_State) + t_source_pos.t2 + transformer.r49 + = (Lexer_Combinators.and_with + [Source_Position.Source_Position, ()]) + Lexer_State.p_source_pos + (\ pos.r50 -> Lexer_State.i_source_pos + (transformer.r49 pos.r50)) +AbsBinds [] [] [(t_buffer.t11, Lexer_Ops.t_buffer)] + {- nonrec -} + t_buffer.t11 :: + (Lexer_Buffer.Lexer_Buffer -> Lexer_Buffer.Lexer_Buffer) + -> Lexer_State.Lexer_State -> ((), Lexer_State.Lexer_State) + t_buffer.t11 + transformer.r51 + = (Lexer_Combinators.and_with [Lexer_Buffer.Lexer_Buffer, ()]) + Lexer_State.p_buffer + (\ buff.r52 -> Lexer_State.i_buffer + (transformer.r51 buff.r52)) +AbsBinds [] [] [(buffer_len.t20, Lexer_Ops.buffer_len)] + {- nonrec -} + buffer_len.t20 :: Lexer_State.Lexer_State -> (Int, Lexer_State.Lexer_State) + buffer_len.t20 + = (Lexer_Combinators.and_with [Lexer_Buffer.Lexer_Buffer, Int]) + Lexer_State.p_buffer + (\ buff.r53 -> (Lexer_Combinators.return Int) + (Lexer_Buffer.len buff.r53)) +AbsBinds [] [] [(decimal_to_int.t28, Lexer_Ops.decimal_to_int)] + {- nonrec -} + decimal_to_int.t28 :: + Lexer_State.Lexer_State + -> (Oberon_Integer.Oberon_Integer, Lexer_State.Lexer_State) + decimal_to_int.t28 + = (Lexer_Combinators.and_with + [Lexer_Buffer.Lexer_Buffer, Oberon_Integer.Oberon_Integer]) + Lexer_State.p_buffer + (\ buff.r54 -> (Lexer_Combinators.return + Oberon_Integer.Oberon_Integer) + (Oberon_Integer.from_decimal_string + (Lexer_Buffer.to_string buff.r54))) +AbsBinds [] [] [(flush_buffer.t36, Lexer_Ops.flush_buffer)] + {- nonrec -} + flush_buffer.t36 :: Lexer_State.Lexer_State -> ((), Lexer_State.Lexer_State) + flush_buffer.t36 = Lexer_Ops.t_buffer Lexer_Buffer.flush +AbsBinds [] [] [(hex_to_int.t39, Lexer_Ops.hex_to_int)] + {- nonrec -} + hex_to_int.t39 :: + Lexer_State.Lexer_State + -> (Oberon_Integer.Oberon_Integer, Lexer_State.Lexer_State) + hex_to_int.t39 + = (Lexer_Combinators.and_with + [Lexer_Buffer.Lexer_Buffer, Oberon_Integer.Oberon_Integer]) + Lexer_State.p_buffer + (\ buff.r55 -> (Lexer_Combinators.return + Oberon_Integer.Oberon_Integer) + (Oberon_Integer.from_hex_string + (Lexer_Buffer.to_string buff.r55))) +AbsBinds [] [] [(move_input_column.t47, Lexer_Ops.move_input_column)] + {- nonrec -} + move_input_column.t47 :: Int -> Lexer_State.Lexer_Action () + move_input_column.t47 + dist.r56 = Lexer_Ops.t_source_pos + ((flip [Source_Position.Source_Position, + Int, + Source_Position.Source_Position]) + Source_Position.shift_column dist.r56) +AbsBinds [] [] [(next_input_line.t54, Lexer_Ops.next_input_line)] + {- nonrec -} + next_input_line.t54 :: + Lexer_State.Lexer_State -> ((), Lexer_State.Lexer_State) + next_input_line.t54 = Lexer_Ops.t_source_pos Source_Position.next_line +AbsBinds [] [] [(store_char.t57, Lexer_Ops.store_char)] + {- nonrec -} + store_char.t57 :: Char -> Lexer_State.Lexer_Action () + store_char.t57 + c.r57 = Lexer_Ops.t_buffer (Lexer_Buffer.add c.r57) +AbsBinds [] [] [(to_char.t61, Lexer_Ops.to_char)] + (toInteger.t79, int2Integer) + {- nonrec -} + to_char.t61 :: + Lexer_State.Lexer_State + -> (Oberon_Integer.Oberon_Integer, Lexer_State.Lexer_State) + to_char.t61 + = (Lexer_Combinators.and_with + [Lexer_Buffer.Lexer_Buffer, Oberon_Integer.Oberon_Integer]) + Lexer_State.p_buffer + (\ buff.r58 -> (Lexer_Combinators.return + Oberon_Integer.Oberon_Integer) + ((((.) [Lexer_Buffer.Lexer_Buffer, + [Char], + Oberon_Integer.Oberon_Integer]) + (((.) [[Char], + Char, + Oberon_Integer.Oberon_Integer]) + (((.) [Char, + Int, + Oberon_Integer.Oberon_Integer]) + (((.) [Int, + Integer, + Oberon_Integer.Oberon_Integer]) + Oberon_Integer.from_int + toInteger.t79) + ord) + (head Char)) + Lexer_Buffer.to_string) buff.r58)) +AbsBinds [] [] [(to_id.t88, Lexer_Ops.to_id)] + {- nonrec -} + to_id.t88 :: + Lexer_State.Lexer_State + -> (Oberon_Id.Oberon_Id, Lexer_State.Lexer_State) + to_id.t88 + = (Lexer_Combinators.and_with + [Lexer_Buffer.Lexer_Buffer, Oberon_Id.Oberon_Id]) + Lexer_State.p_buffer + (\ buff.r59 -> (Lexer_Combinators.return Oberon_Id.Oberon_Id) + (Oberon_Id.from_string + (Lexer_Buffer.to_string buff.r59))) +AbsBinds [] [] [(to_real.t96, Lexer_Ops.to_real)] + {- nonrec -} + to_real.t96 :: + Lexer_State.Lexer_State + -> (Oberon_Real.Oberon_Real, Lexer_State.Lexer_State) + to_real.t96 + = (Lexer_Combinators.and_with + [Lexer_Buffer.Lexer_Buffer, Oberon_Real.Oberon_Real]) + Lexer_State.p_buffer + (\ buff.r60 -> (Lexer_Combinators.return Oberon_Real.Oberon_Real) + (Oberon_Real.from_string + (Lexer_Buffer.to_string buff.r60))) +AbsBinds [] [] [(to_string.t104, Lexer_Ops.to_string)] + {- nonrec -} + to_string.t104 :: + Lexer_State.Lexer_State + -> (Oberon_String.Oberon_String, Lexer_State.Lexer_State) + to_string.t104 + = (Lexer_Combinators.and_with + [Lexer_Buffer.Lexer_Buffer, Oberon_String.Oberon_String]) + Lexer_State.p_buffer + (\ buff.r61 -> (Lexer_Combinators.return + Oberon_String.Oberon_String) + (Oberon_String.from_string + (Lexer_Buffer.to_string buff.r61))) diff --git a/ghc/compiler/tests/rename/rn001.hs b/ghc/compiler/tests/rename/rn001.hs new file mode 100644 index 0000000..f2648a9 --- /dev/null +++ b/ghc/compiler/tests/rename/rn001.hs @@ -0,0 +1,10 @@ +--!!! rn001: super-simple set of bindings, +--!!! incl wildcard pattern-bindings and *duplicates* + +x = [] +y = [] +y = [] +_ = [] +_ = 1 +z = [] +_ = [] diff --git a/ghc/compiler/tests/rename/rn001.stderr b/ghc/compiler/tests/rename/rn001.stderr new file mode 100644 index 0000000..aed3e0a --- /dev/null +++ b/ghc/compiler/tests/rename/rn001.stderr @@ -0,0 +1,74 @@ +Renamed-pass4: +module Main where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- nonrec -} +Main.x = [] +{- nonrec -} +Main.y = [] +{- nonrec -} +Main.y = [] +{- nonrec -} +_ = [] +{- nonrec -} +_ = 1 +{- nonrec -} +Main.z = [] +{- nonrec -} +_ = [] +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + + +"rn001.hs", line 5: multiple declarations of variable: + y ( "rn001.hs", line 5, "rn001.hs", line 6) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/rename/rn002.hs b/ghc/compiler/tests/rename/rn002.hs new file mode 100644 index 0000000..51a09b6 --- /dev/null +++ b/ghc/compiler/tests/rename/rn002.hs @@ -0,0 +1,4 @@ +--!!! split definition of f (error) +f [] = [] +g x = x +f (x:xs) = [] diff --git a/ghc/compiler/tests/rename/rn002.stderr b/ghc/compiler/tests/rename/rn002.stderr new file mode 100644 index 0000000..08f0579 --- /dev/null +++ b/ghc/compiler/tests/rename/rn002.stderr @@ -0,0 +1,69 @@ +Renamed-pass4: +module Main where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- nonrec -} +Main.f + [] = [] +{- nonrec -} +Main.g + x = x +{- nonrec -} +Main.f + (x : xs) = [] +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + + +"rn002.hs", line 2: multiple declarations of variable: + f ( "rn002.hs", line 2, "rn002.hs", line 4) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/rename/rn003.hs b/ghc/compiler/tests/rename/rn003.hs new file mode 100644 index 0000000..493cfa2 --- /dev/null +++ b/ghc/compiler/tests/rename/rn003.hs @@ -0,0 +1,9 @@ +module Foo (f) where +-- export food +f x = x + +--!!! weird patterns with no variables +1 = f 1 +[] = f [] +1 = f (f 1) +[] = f (f []) diff --git a/ghc/compiler/tests/rename/rn003.stderr b/ghc/compiler/tests/rename/rn003.stderr new file mode 100644 index 0000000..c18f4e2 --- /dev/null +++ b/ghc/compiler/tests/rename/rn003.stderr @@ -0,0 +1,67 @@ +Renamed-pass4: +module Foo ( + f + ) where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- nonrec -} +Foo.f + x = x +{- nonrec -} +1 = Foo.f 1 +{- nonrec -} +[] = Foo.f ([]) +{- nonrec -} +1 = Foo.f (Foo.f 1) +{- nonrec -} +[] = Foo.f (Foo.f ([])) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn004.hs b/ghc/compiler/tests/rename/rn004.hs new file mode 100644 index 0000000..247d04b --- /dev/null +++ b/ghc/compiler/tests/rename/rn004.hs @@ -0,0 +1,9 @@ +module Foo where + +--!!! multiple definitions, but hidden in patterns + +f x = x + where + a = [] + (b,c,a) = ([],[],d) + [d,b,_] = ([],a,[]) diff --git a/ghc/compiler/tests/rename/rn004.stderr b/ghc/compiler/tests/rename/rn004.stderr new file mode 100644 index 0000000..a9e55c7 --- /dev/null +++ b/ghc/compiler/tests/rename/rn004.stderr @@ -0,0 +1,71 @@ +Renamed-pass4: +module Foo where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- nonrec -} +Foo.f + x = x + where + {- nonrec -} + a = [] + {- rec -} + (b, c, a) = ([], [], d) + [d, b, _] = ([], a, []) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + + +"rn004.hs", line 7: multiple declarations of variable in binding group: + a ( "rn004.hs", line 7, "rn004.hs", line 8) +"rn004.hs", line 8: multiple declarations of variable in binding group: + b ( "rn004.hs", line 8, "rn004.hs", line 9) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/rename/rn005.hs b/ghc/compiler/tests/rename/rn005.hs new file mode 100644 index 0000000..f1df424 --- /dev/null +++ b/ghc/compiler/tests/rename/rn005.hs @@ -0,0 +1,8 @@ +--!!! rn005: simplest case: a few non-recursive bindings + +module Test where + +f = [] +g x = x +h x y = x +i x y z = x diff --git a/ghc/compiler/tests/rename/rn005.stderr b/ghc/compiler/tests/rename/rn005.stderr new file mode 100644 index 0000000..dfcd629 --- /dev/null +++ b/ghc/compiler/tests/rename/rn005.stderr @@ -0,0 +1,65 @@ +Renamed-pass4: +module Test where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- nonrec -} +Test.f = [] +{- nonrec -} +Test.g + x = x +{- nonrec -} +Test.h + x y = x +{- nonrec -} +Test.i + x y z = x +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn006.hs b/ghc/compiler/tests/rename/rn006.hs new file mode 100644 index 0000000..6524bba --- /dev/null +++ b/ghc/compiler/tests/rename/rn006.hs @@ -0,0 +1,14 @@ +--!!! rn006: two sets of mutually-recursive blobs: +--!!! f, g, h are mut rec +--!!! i, j, k are mut rec + +module Test where + +f x = g x x +i x = j x x + +g x y = h x x y +j x y = k x x y + +h x y z = f z +k x y z = i z diff --git a/ghc/compiler/tests/rename/rn006.stderr b/ghc/compiler/tests/rename/rn006.stderr new file mode 100644 index 0000000..c81bd62 --- /dev/null +++ b/ghc/compiler/tests/rename/rn006.stderr @@ -0,0 +1,68 @@ +Renamed-pass4: +module Test where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- rec -} +Test.f + x = Test.g x x +Test.g + x y = Test.h x x y +Test.h + x y z = Test.f z +{- rec -} +Test.i + x = Test.j x x +Test.j + x y = Test.k x x y +Test.k + x y z = Test.i z +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn007.hs b/ghc/compiler/tests/rename/rn007.hs new file mode 100644 index 0000000..d743044 --- /dev/null +++ b/ghc/compiler/tests/rename/rn007.hs @@ -0,0 +1,20 @@ +--!!! rn007: as rn006, but w/ pattern bindings; +--!!! also a one-node recursive bindings +-- +module Test where + +-- a recursive blob of one node +a = a + +-- two sets of mutually-recursive blobs: +-- f, g, h are mut rec +-- i, j, k are mut rec + +(f1@(f2@(f3@f)), 1) = g 1 1 +(i1@(i2@(i3@i)), 1) = j 1 1 + +(Foo g 1 2) = (h, 1, 1, 2) +(Foo j 1 2) = (k, 1, 1, 2) + +(~ ~ ~ ~h, 1, 2, 3) = f 3 +(~ ~ ~ ~k, 1, 2, 3) = i 3 diff --git a/ghc/compiler/tests/rename/rn007.stderr b/ghc/compiler/tests/rename/rn007.stderr new file mode 100644 index 0000000..21d14df --- /dev/null +++ b/ghc/compiler/tests/rename/rn007.stderr @@ -0,0 +1,70 @@ +Renamed-pass4: +module Test where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- rec -} +Test.a = Test.a +{- rec -} +((Test.f1@(Test.f2@(Test.f3@Test.f))), 1) = Test.g 1 1 +(*UNBOUND*Foo Test.g 1 2) = (Test.h, 1, 1, 2) +(~~~~Test.h, 1, 2, 3) = Test.f 3 +{- rec -} +((Test.i1@(Test.i2@(Test.i3@Test.i))), 1) = Test.j 1 1 +(*UNBOUND*Foo Test.j 1 2) = (Test.k, 1, 1, 2) +(~~~~Test.k, 1, 2, 3) = Test.i 3 +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + + +"rn007.hs", line 16: undefined value: Foo +"rn007.hs", line 17: undefined value: Foo +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/rename/rn008.hs b/ghc/compiler/tests/rename/rn008.hs new file mode 100644 index 0000000..45fc0de --- /dev/null +++ b/ghc/compiler/tests/rename/rn008.hs @@ -0,0 +1,14 @@ +module Test where + +-- two sets of mutually-recursive blobs: +-- f, g, h are mut rec +-- i, j, k are mut rec + +(f1@(f2@(f3@f)), 1) = g 1 1 +(i1@(i2@(i3@i)), 1) = j 1 1 + +(Foo g 1 2) = (h, 1, 1, 2) +(Foo j 1 2) = (k, 1, 1, 2) + +(~ ~ ~ ~h, 1, 2, 3) = f 3 +(~ ~ ~ ~k, 1, 2, 3) = i 3 diff --git a/ghc/compiler/tests/rename/rn008.stderr b/ghc/compiler/tests/rename/rn008.stderr new file mode 100644 index 0000000..a6884df --- /dev/null +++ b/ghc/compiler/tests/rename/rn008.stderr @@ -0,0 +1,68 @@ +Renamed-pass4: +module Test where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +{- rec -} +((Test.f1@(Test.f2@(Test.f3@Test.f))), 1) = Test.g 1 1 +(*UNBOUND*Foo Test.g 1 2) = (Test.h, 1, 1, 2) +(~~~~Test.h, 1, 2, 3) = Test.f 3 +{- rec -} +((Test.i1@(Test.i2@(Test.i3@Test.i))), 1) = Test.j 1 1 +(*UNBOUND*Foo Test.j 1 2) = (Test.k, 1, 1, 2) +(~~~~Test.k, 1, 2, 3) = Test.i 3 +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + + +"rn008.hs", line 10: undefined value: Foo +"rn008.hs", line 11: undefined value: Foo +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/rename/rn009.hs b/ghc/compiler/tests/rename/rn009.hs new file mode 100644 index 0000000..dbf6966 --- /dev/null +++ b/ghc/compiler/tests/rename/rn009.hs @@ -0,0 +1,2 @@ +module Imp10 where +import Int10 diff --git a/ghc/compiler/tests/rename/rn009.stderr b/ghc/compiler/tests/rename/rn009.stderr new file mode 100644 index 0000000..cdbf46c --- /dev/null +++ b/ghc/compiler/tests/rename/rn009.stderr @@ -0,0 +1,94 @@ +Renamed-pass4: +module Imp10 where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +data Int10.T1 a + = Int10.C1 a +data Int10.T10 a b c d e + = Int10.T10C1 a + | Int10.T10C2 b + | Int10.T10C3 c + | Int10.T10C4 d + | Int10.T10C5 e +data Int10.T2 a b + = Int10.T2C1 a + | Int10.T2C2 b +data Int10.T3 a b c + = Int10.T3C1 a + | Int10.T3C2 b + | Int10.T3C3 c +data Int10.T4 a b c d + = Int10.T4C1 a + | Int10.T4C2 b + | Int10.T4C3 c + | Int10.T4C4 d +data Int10.T5 a b c d e + = Int10.T5C1 a + | Int10.T5C2 b + | Int10.T5C3 c + | Int10.T5C4 d + | Int10.T5C5 e +data Int10.T6 a + = Int10.T6C6 a +data Int10.T7 a b + = Int10.T7C6 a + | Int10.T7C7 b +data Int10.T8 a b c + = Int10.T8C1 a + | Int10.T8C2 b + | Int10.T8C3 c +data Int10.T9 a b c d + = Int10.T9C1 a + | Int10.T9C2 b + | Int10.T9C3 c + | Int10.T9C4 d +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn010.hs b/ghc/compiler/tests/rename/rn010.hs new file mode 100644 index 0000000..da32cce --- /dev/null +++ b/ghc/compiler/tests/rename/rn010.hs @@ -0,0 +1,12 @@ +module Imp100 where +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 + diff --git a/ghc/compiler/tests/rename/rn010.stderr b/ghc/compiler/tests/rename/rn010.stderr new file mode 100644 index 0000000..9e79363 --- /dev/null +++ b/ghc/compiler/tests/rename/rn010.stderr @@ -0,0 +1,94 @@ +Renamed-pass4: +module Imp100 where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +data Int10.T1 a + = Int10.C1 a +data Int10.T10 a b c d e + = Int10.T10C1 a + | Int10.T10C2 b + | Int10.T10C3 c + | Int10.T10C4 d + | Int10.T10C5 e +data Int10.T2 a b + = Int10.T2C1 a + | Int10.T2C2 b +data Int10.T3 a b c + = Int10.T3C1 a + | Int10.T3C2 b + | Int10.T3C3 c +data Int10.T4 a b c d + = Int10.T4C1 a + | Int10.T4C2 b + | Int10.T4C3 c + | Int10.T4C4 d +data Int10.T5 a b c d e + = Int10.T5C1 a + | Int10.T5C2 b + | Int10.T5C3 c + | Int10.T5C4 d + | Int10.T5C5 e +data Int10.T6 a + = Int10.T6C6 a +data Int10.T7 a b + = Int10.T7C6 a + | Int10.T7C7 b +data Int10.T8 a b c + = Int10.T8C1 a + | Int10.T8C2 b + | Int10.T8C3 c +data Int10.T9 a b c d + = Int10.T9C1 a + | Int10.T9C2 b + | Int10.T9C3 c + | Int10.T9C4 d +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn011.hs b/ghc/compiler/tests/rename/rn011.hs new file mode 100644 index 0000000..c71a553 --- /dev/null +++ b/ghc/compiler/tests/rename/rn011.hs @@ -0,0 +1,102 @@ +module Imp1000 where +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 + diff --git a/ghc/compiler/tests/rename/rn011.stderr b/ghc/compiler/tests/rename/rn011.stderr new file mode 100644 index 0000000..a3f4176 --- /dev/null +++ b/ghc/compiler/tests/rename/rn011.stderr @@ -0,0 +1,94 @@ +Renamed-pass4: +module Imp1000 where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +data Int10.T1 a + = Int10.C1 a +data Int10.T10 a b c d e + = Int10.T10C1 a + | Int10.T10C2 b + | Int10.T10C3 c + | Int10.T10C4 d + | Int10.T10C5 e +data Int10.T2 a b + = Int10.T2C1 a + | Int10.T2C2 b +data Int10.T3 a b c + = Int10.T3C1 a + | Int10.T3C2 b + | Int10.T3C3 c +data Int10.T4 a b c d + = Int10.T4C1 a + | Int10.T4C2 b + | Int10.T4C3 c + | Int10.T4C4 d +data Int10.T5 a b c d e + = Int10.T5C1 a + | Int10.T5C2 b + | Int10.T5C3 c + | Int10.T5C4 d + | Int10.T5C5 e +data Int10.T6 a + = Int10.T6C6 a +data Int10.T7 a b + = Int10.T7C6 a + | Int10.T7C7 b +data Int10.T8 a b c + = Int10.T8C1 a + | Int10.T8C2 b + | Int10.T8C3 c +data Int10.T9 a b c d + = Int10.T9C1 a + | Int10.T9C2 b + | Int10.T9C3 c + | Int10.T9C4 d +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn012.hs b/ghc/compiler/tests/rename/rn012.hs new file mode 100644 index 0000000..a49abc6 --- /dev/null +++ b/ghc/compiler/tests/rename/rn012.hs @@ -0,0 +1,52 @@ +module Imp500 where +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 +import Int10 + diff --git a/ghc/compiler/tests/rename/rn012.stderr b/ghc/compiler/tests/rename/rn012.stderr new file mode 100644 index 0000000..31b7a51 --- /dev/null +++ b/ghc/compiler/tests/rename/rn012.stderr @@ -0,0 +1,94 @@ +Renamed-pass4: +module Imp500 where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +data Int10.T1 a + = Int10.C1 a +data Int10.T10 a b c d e + = Int10.T10C1 a + | Int10.T10C2 b + | Int10.T10C3 c + | Int10.T10C4 d + | Int10.T10C5 e +data Int10.T2 a b + = Int10.T2C1 a + | Int10.T2C2 b +data Int10.T3 a b c + = Int10.T3C1 a + | Int10.T3C2 b + | Int10.T3C3 c +data Int10.T4 a b c d + = Int10.T4C1 a + | Int10.T4C2 b + | Int10.T4C3 c + | Int10.T4C4 d +data Int10.T5 a b c d e + = Int10.T5C1 a + | Int10.T5C2 b + | Int10.T5C3 c + | Int10.T5C4 d + | Int10.T5C5 e +data Int10.T6 a + = Int10.T6C6 a +data Int10.T7 a b + = Int10.T7C6 a + | Int10.T7C7 b +data Int10.T8 a b c + = Int10.T8C1 a + | Int10.T8C2 b + | Int10.T8C3 c +data Int10.T9 a b c d + = Int10.T9C1 a + | Int10.T9C2 b + | Int10.T9C3 c + | Int10.T9C4 d +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn013.hs b/ghc/compiler/tests/rename/rn013.hs new file mode 100644 index 0000000..e48c2c5 --- /dev/null +++ b/ghc/compiler/tests/rename/rn013.hs @@ -0,0 +1,21 @@ +module Mod10 where + +data T1 a = C1 a + +data T2 a b = T2C1 a | T2C2 b + +data T3 a b c = T3C1 a | T3C2 b | T3C3 c + +data T4 a b c d = T4C1 a | T4C2 b | T4C3 c | T4C4 d + +data T5 a b c d e = T5C1 a | T5C2 b | T5C3 c | T5C4 d | T5C5 e + +data T6 a = T6C6 a + +data T7 a b = T7C6 a | T7C7 b + +data T8 a b c = T8C1 a | T8C2 b | T8C3 c + +data T9 a b c d = T9C1 a | T9C2 b | T9C3 c | T9C4 d + +data T10 a b c d e = T10C1 a | T10C2 b | T10C3 c | T10C4 d | T10C5 e diff --git a/ghc/compiler/tests/rename/rn013.stderr b/ghc/compiler/tests/rename/rn013.stderr new file mode 100644 index 0000000..7f6d594 --- /dev/null +++ b/ghc/compiler/tests/rename/rn013.stderr @@ -0,0 +1,94 @@ +Renamed-pass4: +module Mod10 where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +data Mod10.T1 a + = Mod10.C1 a +data Mod10.T10 a b c d e + = Mod10.T10C1 a + | Mod10.T10C2 b + | Mod10.T10C3 c + | Mod10.T10C4 d + | Mod10.T10C5 e +data Mod10.T2 a b + = Mod10.T2C1 a + | Mod10.T2C2 b +data Mod10.T3 a b c + = Mod10.T3C1 a + | Mod10.T3C2 b + | Mod10.T3C3 c +data Mod10.T4 a b c d + = Mod10.T4C1 a + | Mod10.T4C2 b + | Mod10.T4C3 c + | Mod10.T4C4 d +data Mod10.T5 a b c d e + = Mod10.T5C1 a + | Mod10.T5C2 b + | Mod10.T5C3 c + | Mod10.T5C4 d + | Mod10.T5C5 e +data Mod10.T6 a + = Mod10.T6C6 a +data Mod10.T7 a b + = Mod10.T7C6 a + | Mod10.T7C7 b +data Mod10.T8 a b c + = Mod10.T8C1 a + | Mod10.T8C2 b + | Mod10.T8C3 c +data Mod10.T9 a b c d + = Mod10.T9C1 a + | Mod10.T9C2 b + | Mod10.T9C3 c + | Mod10.T9C4 d +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn014.hs b/ghc/compiler/tests/rename/rn014.hs new file mode 100644 index 0000000..6802fc7 --- /dev/null +++ b/ghc/compiler/tests/rename/rn014.hs @@ -0,0 +1 @@ +import Prelude diff --git a/ghc/compiler/tests/rename/rn014.stderr b/ghc/compiler/tests/rename/rn014.stderr new file mode 100644 index 0000000..8d5c455 --- /dev/null +++ b/ghc/compiler/tests/rename/rn014.stderr @@ -0,0 +1,54 @@ +Renamed-pass4: +module Main where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn015.hs b/ghc/compiler/tests/rename/rn015.hs new file mode 100644 index 0000000..8520347 --- /dev/null +++ b/ghc/compiler/tests/rename/rn015.hs @@ -0,0 +1,19 @@ +--!!! Class and instance decl + +module Test where + +class K a where + op1 :: a -> a -> a + op2 :: Int -> a + +instance K Int where + op1 a b = a+b + op2 x = x + +instance K Bool where + op1 a b = a + -- Pick up the default decl for op2 + +instance K [a] where + op3 a = a -- Oops! Isn't a class op of K + diff --git a/ghc/compiler/tests/rename/rn015.stderr b/ghc/compiler/tests/rename/rn015.stderr new file mode 100644 index 0000000..fc3df5e --- /dev/null +++ b/ghc/compiler/tests/rename/rn015.stderr @@ -0,0 +1,73 @@ +Renamed-pass4: +module Test where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +class Test.K a where + op1{op 1 cls Test.K} :: a -> a -> a + op2{op 2 cls Test.K} :: Int -> a +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +instance Test.K Bool where + op1{op 1 cls Test.K} + a b = a +instance Test.K Int where + op1{op 1 cls Test.K} + a b = a (+) b + op2{op 2 cls Test.K} + x = x +instance Test.K [a] where + *UNBOUND*op3 + a = a +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + + +"rn015.hs", line 18: "op3" is not an operation of class "K" +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/rename/rn016.hs b/ghc/compiler/tests/rename/rn016.hs new file mode 100644 index 0000000..b561ce1 --- /dev/null +++ b/ghc/compiler/tests/rename/rn016.hs @@ -0,0 +1,6 @@ +--!!! Import an interface defining a class and some instances + +module Main where + +import Rn016 + diff --git a/ghc/compiler/tests/rename/rn016.stderr b/ghc/compiler/tests/rename/rn016.stderr new file mode 100644 index 0000000..ff45b2e --- /dev/null +++ b/ghc/compiler/tests/rename/rn016.stderr @@ -0,0 +1,60 @@ +Renamed-pass4: +module Main where +infixl 9 PreludeArray.! +infixl 9 PreludeList.!! +infixl 7 PreludeRatio.% +infixl 7 (*) +infixl 6 (+) +infixl 6 (-) +infixl 7 (/) +infixl 9 PreludeArray.// +infixl 7 `div` +infixl 7 `mod` +infixl 7 `quot` +infixl 7 `rem` +infixr 0 $ +infixr 3 && +infixr 8 (**) +infixr 9 . +infixr 8 Prelude.^ +infixr 8 Prelude.^^ +infixr 2 || +infix 4 (/=) +infix 6 :+ +infix 1 := +infix 4 (<) +infix 4 (<=) +infix 4 (==) +infix 4 (>) +infix 4 (>=) +infix 5 PreludeList.\\ +class X.K a where + op1{op 1 cls X.K} :: a -> a -> a + op2{op 2 cls X.K} :: Int -> a +instance (Eq a, Eq b) => Eq (a, b) +instance (Eq a, Eq b, Eq c) => Eq (a, b, c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a, b, c, d) +instance (Ix a, Ix b) => Ix (a, b) +instance (Ix a, Ix b, Ix c) => Ix (a, b, c) +instance (Ix a, Ix b, Ix c, Ix d) => Ix (a, b, c, d) +instance (Binary a, Binary b) => Binary (a, b) +instance (Binary a, Binary b, Binary c) => Binary (a, b, c) +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a, b, c, d) +instance X.K Bool +instance X.K Int +instance X.K [a] +instance (Ord a, Ord b) => Ord (a, b) +instance (Ord a, Ord b, Ord c) => Ord (a, b, c) +instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) +instance (Text a, Text b) => Text (a, b) +instance (Text a, Text b, Text c) => Text (a, b, c) +instance (Text a, Text b, Text c, Text d) => Text (a, b, c, d) +PreludeArray.! :: Ix a => Array a b -> a -> b +PreludeList.!! :: Integral a => [b] -> a -> b +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +Prelude.^ :: (Num b, Integral a) => b -> a -> b +Prelude.^^ :: (Fractional b, Integral a) => b -> a -> b +PreludeList.or :: [Bool] -> Bool + diff --git a/ghc/compiler/tests/rename/rn017.hs b/ghc/compiler/tests/rename/rn017.hs new file mode 100644 index 0000000..3adc45f --- /dev/null +++ b/ghc/compiler/tests/rename/rn017.hs @@ -0,0 +1,13 @@ +module Test ( Test.. , Rn017.. ) where + +import Rn017 + +f x = x + +data Foo = MkFoo + +class FOO a where + op :: a -> Int + +instance FOO Foo where + op x = 42 diff --git a/ghc/compiler/tests/rename/rn017.stderr b/ghc/compiler/tests/rename/rn017.stderr new file mode 100644 index 0000000..d1f5d45 --- /dev/null +++ b/ghc/compiler/tests/rename/rn017.stderr @@ -0,0 +1,48 @@ +Renamer-pass4: +module Test ( + Test.., Rn017.. + ) where +infixl 7 PreludeRatio.% +infixl 9 PreludeArray.// +infixr 8 PreludeBasic.^ +infixr 8 PreludeBasic.^^ +infix 5 PreludeList.\\ +data Test.Foo + = Test.MkFoo +data Bar.Wibble + = Bar.MkWibble Burf.Wobble +data Burf.Wobble +class Test.FOO a where + op{op 1 cls Test.FOO} :: a -> Int +instance Test.FOO Test.Foo where + op{op 1 cls Test.FOO} + x = 42 +{- nonrec -} +Test.f + x = x +PreludeRatio.% :: Integral a => a -> a -> Ratio a +PreludeArray.// :: Ix a => Array a b -> [Assoc a b] -> Array a b +PreludeList.\\ :: Eq a => [a] -> [a] -> [a] +PreludeBasic.^ :: (Num b, Integral a) => b -> a -> b +PreludeBasic.^^ :: (Fractional b, Integral a) => b -> a -> b +Bar.a :: Int -> Int +Bar.b :: Int -> Int +Rn017.c :: Int -> Int +interface Test where +import Bar(Wibble(..), a, b) +import Burf(Wobble(..)) +import Rn017(c) +a :: Int -> Int +b :: Int -> Int +c :: Int -> Int +f :: a -> a + {-# ARITY f = 1 #-} +class FOO a where + op :: a -> Int + {-# ARITY op = 1 #-} +data Foo = MkFoo +data Wibble = MkWibble Wobble +data Wobble +instance FOO Foo + {-# ARITY op = 1 #-} + diff --git a/ghc/compiler/tests/rename/timing001.hs b/ghc/compiler/tests/rename/timing001.hs new file mode 100644 index 0000000..06fc56a --- /dev/null +++ b/ghc/compiler/tests/rename/timing001.hs @@ -0,0 +1,506 @@ +--!!! 500 defns chained together at the top-level + +a000 = a001 +a001 = a002 +a002 = a003 +a003 = a004 +a004 = a005 +a005 = a006 +a006 = a007 +a007 = a008 +a008 = a009 +a009 = a010 +a010 = a011 +a011 = a012 +a012 = a013 +a013 = a014 +a014 = a015 +a015 = a016 +a016 = a017 +a017 = a018 +a018 = a019 +a019 = a020 +a020 = a021 +a021 = a022 +a022 = a023 +a023 = a024 +a024 = a025 +a025 = a026 +a026 = a027 +a027 = a028 +a028 = a029 +a029 = a030 +a030 = a031 +a031 = a032 +a032 = a033 +a033 = a034 +a034 = a035 +a035 = a036 +a036 = a037 +a037 = a038 +a038 = a039 +a039 = a040 +a040 = a041 +a041 = a042 +a042 = a043 +a043 = a044 +a044 = a045 +a045 = a046 +a046 = a047 +a047 = a048 +a048 = a049 +a049 = a050 +a050 = a051 +a051 = a052 +a052 = a053 +a053 = a054 +a054 = a055 +a055 = a056 +a056 = a057 +a057 = a058 +a058 = a059 +a059 = a060 +a060 = a061 +a061 = a062 +a062 = a063 +a063 = a064 +a064 = a065 +a065 = a066 +a066 = a067 +a067 = a068 +a068 = a069 +a069 = a070 +a070 = a071 +a071 = a072 +a072 = a073 +a073 = a074 +a074 = a075 +a075 = a076 +a076 = a077 +a077 = a078 +a078 = a079 +a079 = a080 +a080 = a081 +a081 = a082 +a082 = a083 +a083 = a084 +a084 = a085 +a085 = a086 +a086 = a087 +a087 = a088 +a088 = a089 +a089 = a090 +a090 = a091 +a091 = a092 +a092 = a093 +a093 = a094 +a094 = a095 +a095 = a096 +a096 = a097 +a097 = a098 +a098 = a099 +a099 = a100 + +a100 = a101 +a101 = a102 +a102 = a103 +a103 = a104 +a104 = a105 +a105 = a106 +a106 = a107 +a107 = a108 +a108 = a109 +a109 = a110 +a110 = a111 +a111 = a112 +a112 = a113 +a113 = a114 +a114 = a115 +a115 = a116 +a116 = a117 +a117 = a118 +a118 = a119 +a119 = a120 +a120 = a121 +a121 = a122 +a122 = a123 +a123 = a124 +a124 = a125 +a125 = a126 +a126 = a127 +a127 = a128 +a128 = a129 +a129 = a130 +a130 = a131 +a131 = a132 +a132 = a133 +a133 = a134 +a134 = a135 +a135 = a136 +a136 = a137 +a137 = a138 +a138 = a139 +a139 = a140 +a140 = a141 +a141 = a142 +a142 = a143 +a143 = a144 +a144 = a145 +a145 = a146 +a146 = a147 +a147 = a148 +a148 = a149 +a149 = a150 +a150 = a151 +a151 = a152 +a152 = a153 +a153 = a154 +a154 = a155 +a155 = a156 +a156 = a157 +a157 = a158 +a158 = a159 +a159 = a160 +a160 = a161 +a161 = a162 +a162 = a163 +a163 = a164 +a164 = a165 +a165 = a166 +a166 = a167 +a167 = a168 +a168 = a169 +a169 = a170 +a170 = a171 +a171 = a172 +a172 = a173 +a173 = a174 +a174 = a175 +a175 = a176 +a176 = a177 +a177 = a178 +a178 = a179 +a179 = a180 +a180 = a181 +a181 = a182 +a182 = a183 +a183 = a184 +a184 = a185 +a185 = a186 +a186 = a187 +a187 = a188 +a188 = a189 +a189 = a190 +a190 = a191 +a191 = a192 +a192 = a193 +a193 = a194 +a194 = a195 +a195 = a196 +a196 = a197 +a197 = a198 +a198 = a199 +a199 = a200 + +a200 = a201 +a201 = a202 +a202 = a203 +a203 = a204 +a204 = a205 +a205 = a206 +a206 = a207 +a207 = a208 +a208 = a209 +a209 = a210 +a210 = a211 +a211 = a212 +a212 = a213 +a213 = a214 +a214 = a215 +a215 = a216 +a216 = a217 +a217 = a218 +a218 = a219 +a219 = a220 +a220 = a221 +a221 = a222 +a222 = a223 +a223 = a224 +a224 = a225 +a225 = a226 +a226 = a227 +a227 = a228 +a228 = a229 +a229 = a230 +a230 = a231 +a231 = a232 +a232 = a233 +a233 = a234 +a234 = a235 +a235 = a236 +a236 = a237 +a237 = a238 +a238 = a239 +a239 = a240 +a240 = a241 +a241 = a242 +a242 = a243 +a243 = a244 +a244 = a245 +a245 = a246 +a246 = a247 +a247 = a248 +a248 = a249 +a249 = a250 +a250 = a251 +a251 = a252 +a252 = a253 +a253 = a254 +a254 = a255 +a255 = a256 +a256 = a257 +a257 = a258 +a258 = a259 +a259 = a260 +a260 = a261 +a261 = a262 +a262 = a263 +a263 = a264 +a264 = a265 +a265 = a266 +a266 = a267 +a267 = a268 +a268 = a269 +a269 = a270 +a270 = a271 +a271 = a272 +a272 = a273 +a273 = a274 +a274 = a275 +a275 = a276 +a276 = a277 +a277 = a278 +a278 = a279 +a279 = a280 +a280 = a281 +a281 = a282 +a282 = a283 +a283 = a284 +a284 = a285 +a285 = a286 +a286 = a287 +a287 = a288 +a288 = a289 +a289 = a290 +a290 = a291 +a291 = a292 +a292 = a293 +a293 = a294 +a294 = a295 +a295 = a296 +a296 = a297 +a297 = a298 +a298 = a299 +a299 = a300 + +a300 = a301 +a301 = a302 +a302 = a303 +a303 = a304 +a304 = a305 +a305 = a306 +a306 = a307 +a307 = a308 +a308 = a309 +a309 = a310 +a310 = a311 +a311 = a312 +a312 = a313 +a313 = a314 +a314 = a315 +a315 = a316 +a316 = a317 +a317 = a318 +a318 = a319 +a319 = a320 +a320 = a321 +a321 = a322 +a322 = a323 +a323 = a324 +a324 = a325 +a325 = a326 +a326 = a327 +a327 = a328 +a328 = a329 +a329 = a330 +a330 = a331 +a331 = a332 +a332 = a333 +a333 = a334 +a334 = a335 +a335 = a336 +a336 = a337 +a337 = a338 +a338 = a339 +a339 = a340 +a340 = a341 +a341 = a342 +a342 = a343 +a343 = a344 +a344 = a345 +a345 = a346 +a346 = a347 +a347 = a348 +a348 = a349 +a349 = a350 +a350 = a351 +a351 = a352 +a352 = a353 +a353 = a354 +a354 = a355 +a355 = a356 +a356 = a357 +a357 = a358 +a358 = a359 +a359 = a360 +a360 = a361 +a361 = a362 +a362 = a363 +a363 = a364 +a364 = a365 +a365 = a366 +a366 = a367 +a367 = a368 +a368 = a369 +a369 = a370 +a370 = a371 +a371 = a372 +a372 = a373 +a373 = a374 +a374 = a375 +a375 = a376 +a376 = a377 +a377 = a378 +a378 = a379 +a379 = a380 +a380 = a381 +a381 = a382 +a382 = a383 +a383 = a384 +a384 = a385 +a385 = a386 +a386 = a387 +a387 = a388 +a388 = a389 +a389 = a390 +a390 = a391 +a391 = a392 +a392 = a393 +a393 = a394 +a394 = a395 +a395 = a396 +a396 = a397 +a397 = a398 +a398 = a399 +a399 = a400 + +a400 = a401 +a401 = a402 +a402 = a403 +a403 = a404 +a404 = a405 +a405 = a406 +a406 = a407 +a407 = a408 +a408 = a409 +a409 = a410 +a410 = a411 +a411 = a412 +a412 = a413 +a413 = a414 +a414 = a415 +a415 = a416 +a416 = a417 +a417 = a418 +a418 = a419 +a419 = a420 +a420 = a421 +a421 = a422 +a422 = a423 +a423 = a424 +a424 = a425 +a425 = a426 +a426 = a427 +a427 = a428 +a428 = a429 +a429 = a430 +a430 = a431 +a431 = a432 +a432 = a433 +a433 = a434 +a434 = a435 +a435 = a436 +a436 = a437 +a437 = a438 +a438 = a439 +a439 = a440 +a440 = a441 +a441 = a442 +a442 = a443 +a443 = a444 +a444 = a445 +a445 = a446 +a446 = a447 +a447 = a448 +a448 = a449 +a449 = a450 +a450 = a451 +a451 = a452 +a452 = a453 +a453 = a454 +a454 = a455 +a455 = a456 +a456 = a457 +a457 = a458 +a458 = a459 +a459 = a460 +a460 = a461 +a461 = a462 +a462 = a463 +a463 = a464 +a464 = a465 +a465 = a466 +a466 = a467 +a467 = a468 +a468 = a469 +a469 = a470 +a470 = a471 +a471 = a472 +a472 = a473 +a473 = a474 +a474 = a475 +a475 = a476 +a476 = a477 +a477 = a478 +a478 = a479 +a479 = a480 +a480 = a481 +a481 = a482 +a482 = a483 +a483 = a484 +a484 = a485 +a485 = a486 +a486 = a487 +a487 = a488 +a488 = a489 +a489 = a490 +a490 = a491 +a491 = a492 +a492 = a493 +a493 = a494 +a494 = a495 +a495 = a496 +a496 = a497 +a497 = a498 +a498 = a499 +a499 = [] -- !!! ta-dah!!! diff --git a/ghc/compiler/tests/rename/timing002.hs b/ghc/compiler/tests/rename/timing002.hs new file mode 100644 index 0000000..9c7146e --- /dev/null +++ b/ghc/compiler/tests/rename/timing002.hs @@ -0,0 +1,502 @@ +--!!! 500 defns chained together with "where"s + +a500 = let a000 = [] + a001 = a000 + a002 = a001 + a003 = a002 + a004 = a003 + a005 = a004 + a006 = a005 + a007 = a006 + a008 = a007 + a009 = a008 + a010 = a009 + a011 = a010 + a012 = a011 + a013 = a012 + a014 = a013 + a015 = a014 + a016 = a015 + a017 = a016 + a018 = a017 + a019 = a018 + a020 = a019 + a021 = a020 + a022 = a021 + a023 = a022 + a024 = a023 + a025 = a024 + a026 = a025 + a027 = a026 + a028 = a027 + a029 = a028 + a030 = a029 + a031 = a030 + a032 = a031 + a033 = a032 + a034 = a033 + a035 = a034 + a036 = a035 + a037 = a036 + a038 = a037 + a039 = a038 + a040 = a039 + a041 = a040 + a042 = a041 + a043 = a042 + a044 = a043 + a045 = a044 + a046 = a045 + a047 = a046 + a048 = a047 + a049 = a048 + a050 = a049 + a051 = a050 + a052 = a051 + a053 = a052 + a054 = a053 + a055 = a054 + a056 = a055 + a057 = a056 + a058 = a057 + a059 = a058 + a060 = a059 + a061 = a060 + a062 = a061 + a063 = a062 + a064 = a063 + a065 = a064 + a066 = a065 + a067 = a066 + a068 = a067 + a069 = a068 + a070 = a069 + a071 = a070 + a072 = a071 + a073 = a072 + a074 = a073 + a075 = a074 + a076 = a075 + a077 = a076 + a078 = a077 + a079 = a078 + a080 = a079 + a081 = a080 + a082 = a081 + a083 = a082 + a084 = a083 + a085 = a084 + a086 = a085 + a087 = a086 + a088 = a087 + a089 = a088 + a090 = a089 + a091 = a090 + a092 = a091 + a093 = a092 + a094 = a093 + a095 = a094 + a096 = a095 + a097 = a096 + a098 = a097 + a099 = a098 + a100 = a099 + a101 = a100 + a102 = a101 + a103 = a102 + a104 = a103 + a105 = a104 + a106 = a105 + a107 = a106 + a108 = a107 + a109 = a108 + a110 = a109 + a111 = a110 + a112 = a111 + a113 = a112 + a114 = a113 + a115 = a114 + a116 = a115 + a117 = a116 + a118 = a117 + a119 = a118 + a120 = a119 + a121 = a120 + a122 = a121 + a123 = a122 + a124 = a123 + a125 = a124 + a126 = a125 + a127 = a126 + a128 = a127 + a129 = a128 + a130 = a129 + a131 = a130 + a132 = a131 + a133 = a132 + a134 = a133 + a135 = a134 + a136 = a135 + a137 = a136 + a138 = a137 + a139 = a138 + a140 = a139 + a141 = a140 + a142 = a141 + a143 = a142 + a144 = a143 + a145 = a144 + a146 = a145 + a147 = a146 + a148 = a147 + a149 = a148 + a150 = a149 + a151 = a150 + a152 = a151 + a153 = a152 + a154 = a153 + a155 = a154 + a156 = a155 + a157 = a156 + a158 = a157 + a159 = a158 + a160 = a159 + a161 = a160 + a162 = a161 + a163 = a162 + a164 = a163 + a165 = a164 + a166 = a165 + a167 = a166 + a168 = a167 + a169 = a168 + a170 = a169 + a171 = a170 + a172 = a171 + a173 = a172 + a174 = a173 + a175 = a174 + a176 = a175 + a177 = a176 + a178 = a177 + a179 = a178 + a180 = a179 + a181 = a180 + a182 = a181 + a183 = a182 + a184 = a183 + a185 = a184 + a186 = a185 + a187 = a186 + a188 = a187 + a189 = a188 + a190 = a189 + a191 = a190 + a192 = a191 + a193 = a192 + a194 = a193 + a195 = a194 + a196 = a195 + a197 = a196 + a198 = a197 + a199 = a198 + a200 = a199 + a201 = a200 + a202 = a201 + a203 = a202 + a204 = a203 + a205 = a204 + a206 = a205 + a207 = a206 + a208 = a207 + a209 = a208 + a210 = a209 + a211 = a210 + a212 = a211 + a213 = a212 + a214 = a213 + a215 = a214 + a216 = a215 + a217 = a216 + a218 = a217 + a219 = a218 + a220 = a219 + a221 = a220 + a222 = a221 + a223 = a222 + a224 = a223 + a225 = a224 + a226 = a225 + a227 = a226 + a228 = a227 + a229 = a228 + a230 = a229 + a231 = a230 + a232 = a231 + a233 = a232 + a234 = a233 + a235 = a234 + a236 = a235 + a237 = a236 + a238 = a237 + a239 = a238 + a240 = a239 + a241 = a240 + a242 = a241 + a243 = a242 + a244 = a243 + a245 = a244 + a246 = a245 + a247 = a246 + a248 = a247 + a249 = a248 + a250 = a249 + a251 = a250 + a252 = a251 + a253 = a252 + a254 = a253 + a255 = a254 + a256 = a255 + a257 = a256 + a258 = a257 + a259 = a258 + a260 = a259 + a261 = a260 + a262 = a261 + a263 = a262 + a264 = a263 + a265 = a264 + a266 = a265 + a267 = a266 + a268 = a267 + a269 = a268 + a270 = a269 + a271 = a270 + a272 = a271 + a273 = a272 + a274 = a273 + a275 = a274 + a276 = a275 + a277 = a276 + a278 = a277 + a279 = a278 + a280 = a279 + a281 = a280 + a282 = a281 + a283 = a282 + a284 = a283 + a285 = a284 + a286 = a285 + a287 = a286 + a288 = a287 + a289 = a288 + a290 = a289 + a291 = a290 + a292 = a291 + a293 = a292 + a294 = a293 + a295 = a294 + a296 = a295 + a297 = a296 + a298 = a297 + a299 = a298 + a300 = a299 + a301 = a300 + a302 = a301 + a303 = a302 + a304 = a303 + a305 = a304 + a306 = a305 + a307 = a306 + a308 = a307 + a309 = a308 + a310 = a309 + a311 = a310 + a312 = a311 + a313 = a312 + a314 = a313 + a315 = a314 + a316 = a315 + a317 = a316 + a318 = a317 + a319 = a318 + a320 = a319 + a321 = a320 + a322 = a321 + a323 = a322 + a324 = a323 + a325 = a324 + a326 = a325 + a327 = a326 + a328 = a327 + a329 = a328 + a330 = a329 + a331 = a330 + a332 = a331 + a333 = a332 + a334 = a333 + a335 = a334 + a336 = a335 + a337 = a336 + a338 = a337 + a339 = a338 + a340 = a339 + a341 = a340 + a342 = a341 + a343 = a342 + a344 = a343 + a345 = a344 + a346 = a345 + a347 = a346 + a348 = a347 + a349 = a348 + a350 = a349 + a351 = a350 + a352 = a351 + a353 = a352 + a354 = a353 + a355 = a354 + a356 = a355 + a357 = a356 + a358 = a357 + a359 = a358 + a360 = a359 + a361 = a360 + a362 = a361 + a363 = a362 + a364 = a363 + a365 = a364 + a366 = a365 + a367 = a366 + a368 = a367 + a369 = a368 + a370 = a369 + a371 = a370 + a372 = a371 + a373 = a372 + a374 = a373 + a375 = a374 + a376 = a375 + a377 = a376 + a378 = a377 + a379 = a378 + a380 = a379 + a381 = a380 + a382 = a381 + a383 = a382 + a384 = a383 + a385 = a384 + a386 = a385 + a387 = a386 + a388 = a387 + a389 = a388 + a390 = a389 + a391 = a390 + a392 = a391 + a393 = a392 + a394 = a393 + a395 = a394 + a396 = a395 + a397 = a396 + a398 = a397 + a399 = a398 + a400 = a399 + a401 = a400 + a402 = a401 + a403 = a402 + a404 = a403 + a405 = a404 + a406 = a405 + a407 = a406 + a408 = a407 + a409 = a408 + a410 = a409 + a411 = a410 + a412 = a411 + a413 = a412 + a414 = a413 + a415 = a414 + a416 = a415 + a417 = a416 + a418 = a417 + a419 = a418 + a420 = a419 + a421 = a420 + a422 = a421 + a423 = a422 + a424 = a423 + a425 = a424 + a426 = a425 + a427 = a426 + a428 = a427 + a429 = a428 + a430 = a429 + a431 = a430 + a432 = a431 + a433 = a432 + a434 = a433 + a435 = a434 + a436 = a435 + a437 = a436 + a438 = a437 + a439 = a438 + a440 = a439 + a441 = a440 + a442 = a441 + a443 = a442 + a444 = a443 + a445 = a444 + a446 = a445 + a447 = a446 + a448 = a447 + a449 = a448 + a450 = a449 + a451 = a450 + a452 = a451 + a453 = a452 + a454 = a453 + a455 = a454 + a456 = a455 + a457 = a456 + a458 = a457 + a459 = a458 + a460 = a459 + a461 = a460 + a462 = a461 + a463 = a462 + a464 = a463 + a465 = a464 + a466 = a465 + a467 = a466 + a468 = a467 + a469 = a468 + a470 = a469 + a471 = a470 + a472 = a471 + a473 = a472 + a474 = a473 + a475 = a474 + a476 = a475 + a477 = a476 + a478 = a477 + a479 = a478 + a480 = a479 + a481 = a480 + a482 = a481 + a483 = a482 + a484 = a483 + a485 = a484 + a486 = a485 + a487 = a486 + a488 = a487 + a489 = a488 + a490 = a489 + a491 = a490 + a492 = a491 + a493 = a492 + a494 = a493 + a495 = a494 + a496 = a495 + a497 = a496 + a498 = a497 in + a498 diff --git a/ghc/compiler/tests/rename/timing003.hs b/ghc/compiler/tests/rename/timing003.hs new file mode 100644 index 0000000..201f4ef --- /dev/null +++ b/ghc/compiler/tests/rename/timing003.hs @@ -0,0 +1,506 @@ +--!!! 500 defns, not chained together + +a000 = [] +a001 = [] +a002 = [] +a003 = [] +a004 = [] +a005 = [] +a006 = [] +a007 = [] +a008 = [] +a009 = [] +a010 = [] +a011 = [] +a012 = [] +a013 = [] +a014 = [] +a015 = [] +a016 = [] +a017 = [] +a018 = [] +a019 = [] +a020 = [] +a021 = [] +a022 = [] +a023 = [] +a024 = [] +a025 = [] +a026 = [] +a027 = [] +a028 = [] +a029 = [] +a030 = [] +a031 = [] +a032 = [] +a033 = [] +a034 = [] +a035 = [] +a036 = [] +a037 = [] +a038 = [] +a039 = [] +a040 = [] +a041 = [] +a042 = [] +a043 = [] +a044 = [] +a045 = [] +a046 = [] +a047 = [] +a048 = [] +a049 = [] +a050 = [] +a051 = [] +a052 = [] +a053 = [] +a054 = [] +a055 = [] +a056 = [] +a057 = [] +a058 = [] +a059 = [] +a060 = [] +a061 = [] +a062 = [] +a063 = [] +a064 = [] +a065 = [] +a066 = [] +a067 = [] +a068 = [] +a069 = [] +a070 = [] +a071 = [] +a072 = [] +a073 = [] +a074 = [] +a075 = [] +a076 = [] +a077 = [] +a078 = [] +a079 = [] +a080 = [] +a081 = [] +a082 = [] +a083 = [] +a084 = [] +a085 = [] +a086 = [] +a087 = [] +a088 = [] +a089 = [] +a090 = [] +a091 = [] +a092 = [] +a093 = [] +a094 = [] +a095 = [] +a096 = [] +a097 = [] +a098 = [] +a099 = [] + +a100 = [] +a101 = [] +a102 = [] +a103 = [] +a104 = [] +a105 = [] +a106 = [] +a107 = [] +a108 = [] +a109 = [] +a110 = [] +a111 = [] +a112 = [] +a113 = [] +a114 = [] +a115 = [] +a116 = [] +a117 = [] +a118 = [] +a119 = [] +a120 = [] +a121 = [] +a122 = [] +a123 = [] +a124 = [] +a125 = [] +a126 = [] +a127 = [] +a128 = [] +a129 = [] +a130 = [] +a131 = [] +a132 = [] +a133 = [] +a134 = [] +a135 = [] +a136 = [] +a137 = [] +a138 = [] +a139 = [] +a140 = [] +a141 = [] +a142 = [] +a143 = [] +a144 = [] +a145 = [] +a146 = [] +a147 = [] +a148 = [] +a149 = [] +a150 = [] +a151 = [] +a152 = [] +a153 = [] +a154 = [] +a155 = [] +a156 = [] +a157 = [] +a158 = [] +a159 = [] +a160 = [] +a161 = [] +a162 = [] +a163 = [] +a164 = [] +a165 = [] +a166 = [] +a167 = [] +a168 = [] +a169 = [] +a170 = [] +a171 = [] +a172 = [] +a173 = [] +a174 = [] +a175 = [] +a176 = [] +a177 = [] +a178 = [] +a179 = [] +a180 = [] +a181 = [] +a182 = [] +a183 = [] +a184 = [] +a185 = [] +a186 = [] +a187 = [] +a188 = [] +a189 = [] +a190 = [] +a191 = [] +a192 = [] +a193 = [] +a194 = [] +a195 = [] +a196 = [] +a197 = [] +a198 = [] +a199 = [] + +a200 = [] +a201 = [] +a202 = [] +a203 = [] +a204 = [] +a205 = [] +a206 = [] +a207 = [] +a208 = [] +a209 = [] +a210 = [] +a211 = [] +a212 = [] +a213 = [] +a214 = [] +a215 = [] +a216 = [] +a217 = [] +a218 = [] +a219 = [] +a220 = [] +a221 = [] +a222 = [] +a223 = [] +a224 = [] +a225 = [] +a226 = [] +a227 = [] +a228 = [] +a229 = [] +a230 = [] +a231 = [] +a232 = [] +a233 = [] +a234 = [] +a235 = [] +a236 = [] +a237 = [] +a238 = [] +a239 = [] +a240 = [] +a241 = [] +a242 = [] +a243 = [] +a244 = [] +a245 = [] +a246 = [] +a247 = [] +a248 = [] +a249 = [] +a250 = [] +a251 = [] +a252 = [] +a253 = [] +a254 = [] +a255 = [] +a256 = [] +a257 = [] +a258 = [] +a259 = [] +a260 = [] +a261 = [] +a262 = [] +a263 = [] +a264 = [] +a265 = [] +a266 = [] +a267 = [] +a268 = [] +a269 = [] +a270 = [] +a271 = [] +a272 = [] +a273 = [] +a274 = [] +a275 = [] +a276 = [] +a277 = [] +a278 = [] +a279 = [] +a280 = [] +a281 = [] +a282 = [] +a283 = [] +a284 = [] +a285 = [] +a286 = [] +a287 = [] +a288 = [] +a289 = [] +a290 = [] +a291 = [] +a292 = [] +a293 = [] +a294 = [] +a295 = [] +a296 = [] +a297 = [] +a298 = [] +a299 = [] + +a300 = [] +a301 = [] +a302 = [] +a303 = [] +a304 = [] +a305 = [] +a306 = [] +a307 = [] +a308 = [] +a309 = [] +a310 = [] +a311 = [] +a312 = [] +a313 = [] +a314 = [] +a315 = [] +a316 = [] +a317 = [] +a318 = [] +a319 = [] +a320 = [] +a321 = [] +a322 = [] +a323 = [] +a324 = [] +a325 = [] +a326 = [] +a327 = [] +a328 = [] +a329 = [] +a330 = [] +a331 = [] +a332 = [] +a333 = [] +a334 = [] +a335 = [] +a336 = [] +a337 = [] +a338 = [] +a339 = [] +a340 = [] +a341 = [] +a342 = [] +a343 = [] +a344 = [] +a345 = [] +a346 = [] +a347 = [] +a348 = [] +a349 = [] +a350 = [] +a351 = [] +a352 = [] +a353 = [] +a354 = [] +a355 = [] +a356 = [] +a357 = [] +a358 = [] +a359 = [] +a360 = [] +a361 = [] +a362 = [] +a363 = [] +a364 = [] +a365 = [] +a366 = [] +a367 = [] +a368 = [] +a369 = [] +a370 = [] +a371 = [] +a372 = [] +a373 = [] +a374 = [] +a375 = [] +a376 = [] +a377 = [] +a378 = [] +a379 = [] +a380 = [] +a381 = [] +a382 = [] +a383 = [] +a384 = [] +a385 = [] +a386 = [] +a387 = [] +a388 = [] +a389 = [] +a390 = [] +a391 = [] +a392 = [] +a393 = [] +a394 = [] +a395 = [] +a396 = [] +a397 = [] +a398 = [] +a399 = [] + +a400 = [] +a401 = [] +a402 = [] +a403 = [] +a404 = [] +a405 = [] +a406 = [] +a407 = [] +a408 = [] +a409 = [] +a410 = [] +a411 = [] +a412 = [] +a413 = [] +a414 = [] +a415 = [] +a416 = [] +a417 = [] +a418 = [] +a419 = [] +a420 = [] +a421 = [] +a422 = [] +a423 = [] +a424 = [] +a425 = [] +a426 = [] +a427 = [] +a428 = [] +a429 = [] +a430 = [] +a431 = [] +a432 = [] +a433 = [] +a434 = [] +a435 = [] +a436 = [] +a437 = [] +a438 = [] +a439 = [] +a440 = [] +a441 = [] +a442 = [] +a443 = [] +a444 = [] +a445 = [] +a446 = [] +a447 = [] +a448 = [] +a449 = [] +a450 = [] +a451 = [] +a452 = [] +a453 = [] +a454 = [] +a455 = [] +a456 = [] +a457 = [] +a458 = [] +a459 = [] +a460 = [] +a461 = [] +a462 = [] +a463 = [] +a464 = [] +a465 = [] +a466 = [] +a467 = [] +a468 = [] +a469 = [] +a470 = [] +a471 = [] +a472 = [] +a473 = [] +a474 = [] +a475 = [] +a476 = [] +a477 = [] +a478 = [] +a479 = [] +a480 = [] +a481 = [] +a482 = [] +a483 = [] +a484 = [] +a485 = [] +a486 = [] +a487 = [] +a488 = [] +a489 = [] +a490 = [] +a491 = [] +a492 = [] +a493 = [] +a494 = [] +a495 = [] +a496 = [] +a497 = [] +a498 = [] +a499 = [] diff --git a/ghc/compiler/tests/simplCore/Jmakefile b/ghc/compiler/tests/simplCore/Jmakefile new file mode 100644 index 0000000..06ea194 --- /dev/null +++ b/ghc/compiler/tests/simplCore/Jmakefile @@ -0,0 +1,10 @@ +runtests:: + @echo '###############################################################' + @echo '# Validation tests for the simplifier. #' + @echo '###############################################################' + +FLAGS=-noC -O -ddump-simpl -dcore-lint + +/* 001 is really a desugarer test, but it is only tickled by the simplifier */ +RunStdTest(simpl001,$(GHC), $(FLAGS) simpl001.hs -o2 simpl001.stderr) +RunStdTest(simpl002,$(GHC), $(FLAGS) simpl002.hs -o2 simpl002.stderr) diff --git a/ghc/compiler/tests/simplCore/simpl001.hs b/ghc/compiler/tests/simplCore/simpl001.hs new file mode 100644 index 0000000..99cf51d --- /dev/null +++ b/ghc/compiler/tests/simplCore/simpl001.hs @@ -0,0 +1,11 @@ +--!!! Desugaring sections with function-type arguments +-- + +-- type Foo a b = a -> (b -> a) -> b + +(++++) :: (a -> (b -> a) -> b) -> (a -> (b -> a) -> b) -> a -> (b -> a) -> b +x ++++ y = y + +g a xs = map (++++ a) xs + +h b xs = map (b ++++) xs diff --git a/ghc/compiler/tests/simplCore/simpl001.stderr b/ghc/compiler/tests/simplCore/simpl001.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/simplCore/simpl002.hs b/ghc/compiler/tests/simplCore/simpl002.hs new file mode 100644 index 0000000..206e861 --- /dev/null +++ b/ghc/compiler/tests/simplCore/simpl002.hs @@ -0,0 +1,9 @@ +--!!! class/instance mumble that failed Lint at one time +-- +class Foo a where + op :: Int -> a -> Bool + +data Wibble a b c = MkWibble a b c + +instance (Foo a, Foo b, Foo c) => Foo (Wibble a b c) where + op x y = error "xxx" diff --git a/ghc/compiler/tests/simplCore/simpl002.stderr b/ghc/compiler/tests/simplCore/simpl002.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/stranal/default.lhs b/ghc/compiler/tests/stranal/default.lhs new file mode 100644 index 0000000..010e8d5 --- /dev/null +++ b/ghc/compiler/tests/stranal/default.lhs @@ -0,0 +1,15 @@ +> data Boolean = FF | TT +> data Pair a b = MkPair a b +> data LList alpha = Nill | Conss alpha (LList alpha) +> data Nat = Zero | Succ Nat +> data Tree x = Leaf x | Node (Tree x) (Tree x) +> data A a = MkA a (A a) +> +> append :: LList a -> LList a -> LList a +> append xs ys = case xs of +> Conss z zs -> Conss z (append zs ys) +> v -> ys + + + + diff --git a/ghc/compiler/tests/stranal/fact.lhs b/ghc/compiler/tests/stranal/fact.lhs new file mode 100644 index 0000000..2507c6b --- /dev/null +++ b/ghc/compiler/tests/stranal/fact.lhs @@ -0,0 +1,2 @@ +> fact :: Int -> Int +> fact n = if n==0 then 2 else (fact n) * n diff --git a/ghc/compiler/tests/stranal/fun.lhs b/ghc/compiler/tests/stranal/fun.lhs new file mode 100644 index 0000000..d86208b --- /dev/null +++ b/ghc/compiler/tests/stranal/fun.lhs @@ -0,0 +1,5 @@ +> data Fun = MkFun (Fun -> Fun) +> data LList a = Nill | Conss a (LList a) + +> id :: Fun -> Fun +> id f = f diff --git a/ghc/compiler/tests/stranal/goo.lhs b/ghc/compiler/tests/stranal/goo.lhs new file mode 100644 index 0000000..ddf666b --- /dev/null +++ b/ghc/compiler/tests/stranal/goo.lhs @@ -0,0 +1,9 @@ +> data Goo a = Gsimpl | Gcompl ([Goo a]) +> data Moo a b = Msimple | Mcompl (Moo b a) + + +> idGoo :: Goo a -> Goo a +> idGoo x = x + +> idMoo :: Moo a -> Moo a +> idMoo x = x diff --git a/ghc/compiler/tests/stranal/ins.lhs b/ghc/compiler/tests/stranal/ins.lhs new file mode 100644 index 0000000..120b46f --- /dev/null +++ b/ghc/compiler/tests/stranal/ins.lhs @@ -0,0 +1,26 @@ +TEST OF DEFACTORISATION FOR FUNCTIONS THAT DROP + POLYMORPHIC VARIABLES + +> data Boolean = FF | TT +> data Pair a b = MkPair a b +> data LList alpha = Nill | Conss alpha (LList alpha) +> data Nat = Zero | Succ Nat +> data Tree x = Leaf x | Node (Tree x) (Tree x) +> data A a = MkA a (A a) +> +> append :: LList a -> LList a -> LList a +> append xs ys = case xs of +> Nill -> ys +> Conss z zs -> Conss z (append zs ys) + +The following function drops @b@. + +> flat :: Tree (Pair a b) -> LList a +> flat t = case t of +> Leaf (MkPair a b) -> Conss a Nill +> Node l r -> append (flat l) (flat r) +> +> fl :: Boolean -> LList Boolean +> fl x = flat (Leaf (MkPair TT Zero)) +> + diff --git a/ghc/compiler/tests/stranal/map.lhs b/ghc/compiler/tests/stranal/map.lhs new file mode 100644 index 0000000..d79ec03 --- /dev/null +++ b/ghc/compiler/tests/stranal/map.lhs @@ -0,0 +1,31 @@ +> data Boolean = FF | TT +> data Pair a b = MkPair a b +> data LList alpha = Nill | Conss alpha (LList alpha) +> data Nat = Zero | Succ Nat +> data Tree x = Leaf x | Node (Tree x) (Tree x) +> data A a = MkA a (A a) + +> {- +> map :: (a -> b) -> [a] -> [b] +> map f xs = case xs of +> [] -> [] +> (y:ys) -> (f y):(map f ys) + +> map_ide :: [[a]] -> [[a]] +> map_ide = map (\x->x) +>-} + +> id :: a -> a +> id x = x + +> idNat :: Nat -> Nat +> idNat x = x + +> idBool :: Boolean -> Boolean +> idBool x = x + +> fun :: (a->b) -> a -> b +> fun f x = g f +> where +> g f = f x + diff --git a/ghc/compiler/tests/stranal/moo.lhs b/ghc/compiler/tests/stranal/moo.lhs new file mode 100644 index 0000000..3d6226b --- /dev/null +++ b/ghc/compiler/tests/stranal/moo.lhs @@ -0,0 +1,5 @@ +> data Moo a b = Msimple | Mcompl (Moo b a) + + +> idMoo :: Moo a -> Moo a +> idMoo x = x diff --git a/ghc/compiler/tests/stranal/sim.lhs b/ghc/compiler/tests/stranal/sim.lhs new file mode 100644 index 0000000..c788681 --- /dev/null +++ b/ghc/compiler/tests/stranal/sim.lhs @@ -0,0 +1,102 @@ +> data Boolean = FF | TT +> data Pair a b = MkPair a b +> data LList alpha = Nill | Conss alpha (LList alpha) +> data Nat = Zero | Succ Nat +> data Tree x = Leaf x | Node (Tree x) (Tree x) +> data A a = MkA a (A a) +>{- +> id :: a -> a +> id x = x +> +> idb :: Boolean -> Boolean +> idb b = b +> +> swap :: Pair a b -> Pair b a +> swap t = case t of +> MkPair x y -> MkPair y x +> +> bang :: A (A a) -> Boolean +> bang x = case x of +> MkA y ys -> TT +> +> neg :: Boolean -> Boolean +> neg b = case b of +> FF -> TT +> TT -> FF +> +> null :: LList x -> Boolean +> null l = case l of +> Nill -> TT +> _ -> FF +> +> loop :: Boolean -> a +> loop b = loop b +>-} +> idl :: LList a -> LList a +> idl xs = case xs of +> Conss y ys -> Conss y (idl ys) +> _ -> Nill +>{- +> idn :: Nat -> Nat +> idn n = case n of +> Zero -> Zero +> Succ m -> Succ (idn m) +> +> add :: Nat -> Nat -> Nat +> add a b = case a of +> Zero -> b +> Succ c -> Succ (add c b) +> +> length :: LList a -> Nat +> length xs = case xs of +> Nill -> Zero +> Conss y ys -> Succ(length ys) +> +> before :: LList Nat -> LList Nat +> before xs = case xs of +> Nill -> Nill +> Conss y ys -> case y of +> Zero -> Nill +> Succ n -> Conss y (before ys) +> +> reverse :: LList a -> LList a +> reverse rs = case rs of +> Nill -> Nill +> Conss y ys -> append (reverse ys) (Conss y Nill) +> +> f :: Nat -> Nat +> f n = case n of +> Zero -> Zero +> Succ m -> Succ (g m) +> +> g :: Nat -> Nat +> g n = case n of +> Zero -> Zero +> Succ m -> Succ (f m) +> +> append :: LList a -> LList a -> LList a +> append xs ys = case xs of +> Nill -> ys +> Conss z zs -> Conss z (append zs ys) +> +> flatten :: Tree alpha -> LList alpha +> flatten t = case t of +> Leaf x -> Conss x Nill +> Node l r -> append (flatten l) (flatten r) +> +> sum :: Tree Nat -> Nat +> sum t = case t of +> Leaf t -> t +> Node l r -> add (sum l) (sum r) +> +> suml :: LList Nat -> Nat +> suml Nill = Zero +> suml (Conss n ns) = add n (suml ns) +> +> map :: (a -> b) -> LList a -> LList b +> map f xs = case xs of +> Nill -> Nill +> Conss y ys -> Conss (f y) (map f ys) +>-} + + diff --git a/ghc/compiler/tests/stranal/syn.lhs b/ghc/compiler/tests/stranal/syn.lhs new file mode 100644 index 0000000..00da926 --- /dev/null +++ b/ghc/compiler/tests/stranal/syn.lhs @@ -0,0 +1,14 @@ +THIS TEST IS FOR TYPE SYNONIMS AND FACTORISATION IN THEIR PRESENCE. + +> data M a = A | B a (M a) +> data L a = N | C a (Syn a) +> type Syn b = L b +> +> idL :: L (Syn c) -> L (Syn c) +> idL N = N +> idL (C x l) = C x (idL l) +> +> idM:: M (L (Syn x)) -> M (L (Syn x)) +> idM A = A +> idM (B x l) = B (idL x) (idM l) + diff --git a/ghc/compiler/tests/stranal/test.lhs b/ghc/compiler/tests/stranal/test.lhs new file mode 100644 index 0000000..d1e1925 --- /dev/null +++ b/ghc/compiler/tests/stranal/test.lhs @@ -0,0 +1,5 @@ +> data LList t = Nill | Conss t (LList t) +> data BBool = TTrue | FFalse + +> f Nill = TTrue +> f (Conss a as) = FFalse diff --git a/ghc/compiler/tests/stranal/tst.lhs b/ghc/compiler/tests/stranal/tst.lhs new file mode 100644 index 0000000..5353935 --- /dev/null +++ b/ghc/compiler/tests/stranal/tst.lhs @@ -0,0 +1,2 @@ +> a :: [a] -> [[a]] +> a x = [x] diff --git a/ghc/compiler/tests/stranal/unu.lhs b/ghc/compiler/tests/stranal/unu.lhs new file mode 100644 index 0000000..3932285 --- /dev/null +++ b/ghc/compiler/tests/stranal/unu.lhs @@ -0,0 +1,75 @@ +> data Boolean = FF | TT +> data Pair a b = Mkpair a b +> data LList alpha = Nill | Conss alpha (LList alpha) +> data Nat = Zero | Succ Nat +> data Tree t = Leaf t | Node (Tree t) (Tree t) +> data A a = MkA a (A a) +> data Foo baz = MkFoo (Foo (Foo baz)) +>{- +> append1 :: LList a -> LList a -> LList a +> append1 xs ys = append2 xs +> where +> append2 xs = case xs of +> Nill -> ys +> Conss x xs -> Conss x (append3 xs) +> append3 xs = case xs of +> Nill -> ys +> Conss x xs -> Conss x (append2 xs) +> +> loop :: a -> a +> loop x = loop x +> +> hd :: LList b -> b +> hd Nill = loop +> hd (Conss y ys) = y +> +> hdb :: LList (LList b) -> LList b +> hdb = hd +> +> append :: [a] -> [a] -> [a] +> append [] ys = ys +> append (x:xs) ys = x:(append xs ys) +> +> f :: [a] -> [a] +> f y = append x (f y) +> where x = append x (f y) +>-} +> app :: LList a -> LList a -> LList a +> app Nill Nill = Nill +> app xs ys = case xs of +> Nill -> ys +> Conss z zs -> Conss z (app zs ys) +>{- +> app :: LList a -> LList a -> LList a +> app xs ys = case xs of +> Nill -> case ys of +> Nill -> Nill +> Conss u us -> ap +> Conss a as -> ap +> where ap = case xs of +> Nill -> ys +> Conss z zs -> Conss z (app zs ys) +> +> app :: LList a -> LList a -> LList a +> app xs ys = case xs of +> Nill -> case ys of +> Nill -> Nill +> Conss u us -> ap xs ys +> Conss a as -> ap xs ys +> +> ap xs ys = case xs of +> Nill -> ys +> Conss z zs -> Conss z (app zs ys) +> +> ap :: LList a -> LList a -> LList a +> ap xs ys = case xs of +> Nill -> ys +> Conss z zs -> Conss z (ap zs ys) +> +> app :: LList a -> LList a -> LList a +> app xs ys = case xs of +> Nill -> case ys of +> Nill -> Nill +> Conss u us -> ap xs ys +> Conss a as -> ap xs ys +>-} diff --git a/ghc/compiler/tests/typecheck/Jmakefile b/ghc/compiler/tests/typecheck/Jmakefile new file mode 100644 index 0000000..a4ca9c7 --- /dev/null +++ b/ghc/compiler/tests/typecheck/Jmakefile @@ -0,0 +1,7 @@ +#define IHaveSubdirs + +SUBDIRS = /* TEMPORARILY OUT: check_mess */ \ + should_fail \ + /* TEMPORARILY OUT: test_exps */ \ + should_succeed \ + bugs diff --git a/ghc/compiler/tests/typecheck/should_fail/Digraph.hs b/ghc/compiler/tests/typecheck/should_fail/Digraph.hs new file mode 100644 index 0000000..a52d489 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/Digraph.hs @@ -0,0 +1,56 @@ +--!!! trying to have a polymorphic type sig where inappropriate +-- +module Digraph where + +data MaybeErr val err = Succeeded val | Failed err deriving () + +type Edge vertex = (vertex, vertex) +type Cycle vertex = [vertex] + +stronglyConnComp :: Eq vertex => [Edge vertex] -> [vertex] -> [[vertex]] + +stronglyConnComp es vs + = snd (span_tree (new_range reversed_edges) + ([],[]) + ( snd (dfs (new_range es) ([],[]) vs) ) + ) + where + -- *********** the offending type signature ************** + reversed_edges :: Eq v => [Edge v] + reversed_edges = map swap es + + -- WRONGOLA: swap :: Eq v => Edge v -> Edge v + swap (x,y) = (y, x) + + -- WRONGOLA?: new_range :: Eq v => [Edge v] -> v -> [v] + + new_range [] w = [] + new_range ((x,y):xys) w + = if x==w + then (y : (new_range xys w)) + else (new_range xys w) + + {- WRONGOLA?: + span_tree :: Eq v => (v -> [v]) + -> ([v], [[v]]) + -> [v] + -> ([v], [[v]]) + -} + + span_tree r (vs,ns) [] = (vs,ns) + span_tree r (vs,ns) (x:xs) + | x `elem` vs = span_tree r (vs,ns) xs + | otherwise = span_tree r (vs',(x:ns'):ns) xs + where + (vs',ns') = dfs r (x:vs,[]) (r x) + +dfs :: Eq v => (v -> [v]) + -> ([v], [v]) + -> [v] + -> ([v], [v]) + +dfs r (vs,ns) [] = (vs,ns) +dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs + | otherwise = dfs r (vs',(x:ns')++ns) xs + where + (vs',ns') = dfs r (x:vs,[]) (r x) diff --git a/ghc/compiler/tests/typecheck/should_fail/Digraph.stderr b/ghc/compiler/tests/typecheck/should_fail/Digraph.stderr new file mode 100644 index 0000000..a61101c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/Digraph.stderr @@ -0,0 +1,8 @@ + +"Digraph.hs", line 19: Type signature is too polymorphic: + Signature: [Edge v] + Monomorphic type variables: v + In a type signature: [Edge v] +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/Jmakefile b/ghc/compiler/tests/typecheck/should_fail/Jmakefile new file mode 100644 index 0000000..8ab9db4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/Jmakefile @@ -0,0 +1,78 @@ +TEST_FLAGS=-noC -ddump-tc + +RunStdTest(tcfail001,$(GHC),$(TEST_FLAGS) tcfail001.hs -x1 -o2 tcfail001.stderr) +RunStdTest(tcfail002,$(GHC),$(TEST_FLAGS) tcfail002.hs -x1 -o2 tcfail002.stderr) +RunStdTest(tcfail003,$(GHC),$(TEST_FLAGS) tcfail003.hs -x1 -o2 tcfail003.stderr) +RunStdTest(tcfail004,$(GHC),$(TEST_FLAGS) tcfail004.hs -x1 -o2 tcfail004.stderr) +RunStdTest(tcfail005,$(GHC),$(TEST_FLAGS) tcfail005.hs -x1 -o2 tcfail005.stderr) +RunStdTest(tcfail006,$(GHC),$(TEST_FLAGS) tcfail006.hs -x1 -o2 tcfail006.stderr) +RunStdTest(tcfail007,$(GHC),$(TEST_FLAGS) tcfail007.hs -x1 -o2 tcfail007.stderr) +RunStdTest(tcfail008,$(GHC),$(TEST_FLAGS) tcfail008.hs -x1 -o2 tcfail008.stderr) +RunStdTest(tcfail009,$(GHC),$(TEST_FLAGS) tcfail009.hs -x1 -o2 tcfail009.stderr) + +RunStdTest(tcfail010,$(GHC),$(TEST_FLAGS) tcfail010.hs -x1 -o2 tcfail010.stderr) +RunStdTest(tcfail011,$(GHC),$(TEST_FLAGS) tcfail011.hs -x1 -o2 tcfail011.stderr) +RunStdTest(tcfail012,$(GHC),$(TEST_FLAGS) tcfail012.hs -x1 -o2 tcfail012.stderr) +RunStdTest(tcfail013,$(GHC),$(TEST_FLAGS) tcfail013.hs -x1 -o2 tcfail013.stderr) +RunStdTest(tcfail014,$(GHC),$(TEST_FLAGS) tcfail014.hs -x1 -o2 tcfail014.stderr) +RunStdTest(tcfail015,$(GHC),$(TEST_FLAGS) tcfail015.hs -x1 -o2 tcfail015.stderr) +RunStdTest(tcfail016,$(GHC),$(TEST_FLAGS) tcfail016.hs -x1 -o2 tcfail016.stderr) +RunStdTest(tcfail017,$(GHC),$(TEST_FLAGS) tcfail017.hs -x1 -o2 tcfail017.stderr) +RunStdTest(tcfail018,$(GHC),$(TEST_FLAGS) tcfail018.hs -x1 -o2 tcfail018.stderr) +RunStdTest(tcfail019,$(GHC),$(TEST_FLAGS) tcfail019.hs -x1 -o2 tcfail019.stderr) + +RunStdTest(tcfail020,$(GHC),$(TEST_FLAGS) tcfail020.hs -x1 -o2 tcfail020.stderr) +RunStdTest(tcfail021,$(GHC),$(TEST_FLAGS) tcfail021.hs -x1 -o2 tcfail021.stderr) +RunStdTest(tcfail022,$(GHC),$(TEST_FLAGS) tcfail022.hs -x1 -o2 tcfail022.stderr) +RunStdTest(tcfail023,$(GHC),$(TEST_FLAGS) tcfail023.hs -x1 -o2 tcfail023.stderr) +RunStdTest(tcfail024,$(GHC),$(TEST_FLAGS) tcfail024.hs -x1 -o2 tcfail024.stderr) +RunStdTest(tcfail025,$(GHC),$(TEST_FLAGS) tcfail025.hs -x1 -o2 tcfail025.stderr) +RunStdTest(tcfail026,$(GHC),$(TEST_FLAGS) tcfail026.hs -x1 -o2 tcfail026.stderr) +RunStdTest(tcfail027,$(GHC),$(TEST_FLAGS) tcfail027.hs -x1 -o2 tcfail027.stderr) +RunStdTest(tcfail028,$(GHC),$(TEST_FLAGS) tcfail028.hs -x1 -o2 tcfail028.stderr) +RunStdTest(tcfail029,$(GHC),$(TEST_FLAGS) tcfail029.hs -x1 -o2 tcfail029.stderr) + +RunStdTest(tcfail030,$(GHC),$(TEST_FLAGS) tcfail030.hs -x1 -o2 tcfail030.stderr) +RunStdTest(tcfail031,$(GHC),$(TEST_FLAGS) tcfail031.hs -x1 -o2 tcfail031.stderr) +RunStdTest(tcfail032,$(GHC),$(TEST_FLAGS) tcfail032.hs -x1 -o2 tcfail032.stderr) +RunStdTest(tcfail033,$(GHC),$(TEST_FLAGS) tcfail033.hs -x1 -o2 tcfail033.stderr) +RunStdTest(tcfail034,$(GHC),$(TEST_FLAGS) tcfail034.hs -x1 -o2 tcfail034.stderr) +RunStdTest(tcfail035,$(GHC),$(TEST_FLAGS) tcfail035.hs -x1 -o2 tcfail035.stderr) +RunStdTest(tcfail036,$(GHC),$(TEST_FLAGS) tcfail036.hs -x1 -o2 tcfail036.stderr) +RunStdTest(tcfail037,$(GHC),$(TEST_FLAGS) tcfail037.hs -x1 -o2 tcfail037.stderr) +RunStdTest(tcfail038,$(GHC),$(TEST_FLAGS) tcfail038.hs -x1 -o2 tcfail038.stderr) +RunStdTest(tcfail039,$(GHC),$(TEST_FLAGS) tcfail039.hs -x1 -o2 tcfail039.stderr) + +RunStdTest(tcfail040,$(GHC),$(TEST_FLAGS) tcfail040.hs -x1 -o2 tcfail040.stderr) +RunStdTest(tcfail041,$(GHC),$(TEST_FLAGS) tcfail041.hs -x1 -o2 tcfail041.stderr) +RunStdTest(tcfail042,$(GHC),$(TEST_FLAGS) tcfail042.hs -x1 -o2 tcfail042.stderr) +RunStdTest(tcfail043,$(GHC),$(TEST_FLAGS) tcfail043.hs -x1 -o2 tcfail043.stderr) +RunStdTest(tcfail044,$(GHC),$(TEST_FLAGS) tcfail044.hs -x1 -o2 tcfail044.stderr) +RunStdTest(tcfail045,$(GHC),$(TEST_FLAGS) -fglasgow-exts tcfail045.hs -x1 -o2 tcfail045.stderr) +RunStdTest(tcfail046,$(GHC),$(TEST_FLAGS) tcfail046.hs -x1 -o2 tcfail046.stderr) +RunStdTest(tcfail047,$(GHC),$(TEST_FLAGS) tcfail047.hs -x1 -o2 tcfail047.stderr) +RunStdTest(tcfail048,$(GHC),$(TEST_FLAGS) tcfail048.hs -x1 -o2 tcfail048.stderr) +RunStdTest(tcfail049,$(GHC),$(TEST_FLAGS) tcfail049.hs -x1 -o2 tcfail049.stderr) + +RunStdTest(tcfail050,$(GHC),$(TEST_FLAGS) tcfail050.hs -x1 -o2 tcfail050.stderr) +RunStdTest(tcfail051,$(GHC),$(TEST_FLAGS) tcfail051.hs -x1 -o2 tcfail051.stderr) +RunStdTest(tcfail052,$(GHC),$(TEST_FLAGS) tcfail052.hs -x1 -o2 tcfail052.stderr) +RunStdTest(tcfail053,$(GHC),$(TEST_FLAGS) tcfail053.hs -x1 -o2 tcfail053.stderr) +RunStdTest(tcfail054,$(GHC),$(TEST_FLAGS) tcfail054.hs -x1 -o2 tcfail054.stderr) +RunStdTest(tcfail055,$(GHC),$(TEST_FLAGS) tcfail055.hs -x1 -o2 tcfail055.stderr) +RunStdTest(tcfail056,$(GHC),$(TEST_FLAGS) tcfail056.hs -x1 -o2 tcfail056.stderr) +RunStdTest(tcfail057,$(GHC),$(TEST_FLAGS) tcfail057.hs -x1 -o2 tcfail057.stderr) +RunStdTest(tcfail058,$(GHC),$(TEST_FLAGS) tcfail058.hs -x1 -o2 tcfail058.stderr) +RunStdTest(tcfail059,$(GHC),$(TEST_FLAGS) -hi tcfail059.hs -x1 -o2 tcfail059.stderr) + +RunStdTest(tcfail060,$(GHC),$(TEST_FLAGS) -hi tcfail060.hs -x1 -o2 tcfail060.stderr) +RunStdTest(tcfail061,$(GHC),$(TEST_FLAGS) -hi tcfail061.hs -x1 -o2 tcfail061.stderr) +RunStdTest(tcfail062,$(GHC),$(TEST_FLAGS) -hi tcfail062.hs -x1 -o2 tcfail062.stderr) +RunStdTest(tcfail063,$(GHC),$(TEST_FLAGS) -hi tcfail063.hs -x1 -o2 tcfail063.stderr) +RunStdTest(tcfail064,$(GHC),$(TEST_FLAGS) -hi Fail064.hs -x1 -o2 tcfail064.stderr) +RunStdTest(tcfail065,$(GHC),$(TEST_FLAGS) -hi tcfail065.hs -x1 -o2 tcfail065.stderr) +RunStdTest(tcfail066,$(GHC),$(TEST_FLAGS) -hi tcfail066.hs -x1 -o2 tcfail066.stderr) +RunStdTest(tcfail067,$(GHC),$(TEST_FLAGS) -hi tcfail067.hs -x1 -o2 tcfail067.stderr) +RunStdTest(tcfail068,$(GHC) -fglasgow-exts,$(TEST_FLAGS) -hi tcfail068.hs -x1 -o2 tcfail068.stderr) + +RunStdTest(Digraph,$(GHC),$(TEST_FLAGS) Digraph.hs -x1 -o2 Digraph.stderr) diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail001.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail001.hs new file mode 100644 index 0000000..4e4ae93 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail001.hs @@ -0,0 +1,8 @@ +--!!! This should fail with a type error: the instance method +--!!! has a function type when it should have the type [a]. + +class A a where + op :: a + +instance (A a, A a) => A [a] where + op [] = [] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail001.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail001.stderr new file mode 100644 index 0000000..bb40cb4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail001.stderr @@ -0,0 +1,8 @@ + +"tcfail001.hs", line 8: + Couldn't match type "[tt5] -> [tt6]" against "[a]". + Inside a function binding: + op ... [] = [] +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail002.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail002.hs new file mode 100644 index 0000000..b1fdd16 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail002.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +c (x:y) = x +c z = z diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail002.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail002.stderr new file mode 100644 index 0000000..449dd5c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail002.stderr @@ -0,0 +1,9 @@ + +"tcfail002.hs", line 3: + Type variable "tt4" occurs within the type "[tt4]". + Inside two equations or case alternatives: + ... (x : y) -> x + ... z -> z +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail003.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail003.hs new file mode 100644 index 0000000..8458014 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail003.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +(d:e) = [1,'a'] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail003.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail003.stderr new file mode 100644 index 0000000..b875b06 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail003.stderr @@ -0,0 +1,6 @@ + +"tcfail003.hs", line 3: No such instance: + class "Num", type "Char" (at an overloaded literal: 1) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail004.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail004.hs new file mode 100644 index 0000000..513680b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail004.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +(f,g) = (1,2,3) diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail004.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail004.stderr new file mode 100644 index 0000000..6272111 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail004.stderr @@ -0,0 +1,8 @@ + +"tcfail004.hs", line 3: + Couldn't match type "(ot0, ot1)" against "(tt6, tt8, tt10)". + In a pattern binding: + (f, g) = (1, 2, 3) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail005.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail005.hs new file mode 100644 index 0000000..ca211e1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail005.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +(h:i) = (1,'a') diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail005.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail005.stderr new file mode 100644 index 0000000..f3c1a12 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail005.stderr @@ -0,0 +1,8 @@ + +"tcfail005.hs", line 3: + Couldn't match type "[tt4]" against "(tt5, Char)". + In a pattern binding: + (h : i) = (1, 'a') +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail006.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail006.hs new file mode 100644 index 0000000..37fd1f9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail006.hs @@ -0,0 +1,5 @@ +module ShouldFail where + +(j,k) = case (if True then True else False) of + True -> (True,1) + False -> (1,True) diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail006.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail006.stderr new file mode 100644 index 0000000..122557c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail006.stderr @@ -0,0 +1,6 @@ + +"tcfail006.hs", line 5: No such instance: + class "Num", type "Bool" (at an overloaded literal: 1) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail007.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail007.hs new file mode 100644 index 0000000..ee24983 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail007.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +n x | True = x+1 + | False = True diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail007.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail007.stderr new file mode 100644 index 0000000..207597e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail007.stderr @@ -0,0 +1,6 @@ + +"tcfail007.hs", line 4: No such instance: + class "Num", type "Bool" (at an overloaded literal: 1) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail008.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail008.hs new file mode 100644 index 0000000..dbc9d0c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail008.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +o = 1:2 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail008.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail008.stderr new file mode 100644 index 0000000..c4a2f19 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail008.stderr @@ -0,0 +1,6 @@ + +"tcfail008.hs", line 3: No such instance: + class "Num", type "[tt3]" (at an overloaded literal: 2) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail009.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail009.hs new file mode 100644 index 0000000..e8afa0f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail009.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +p = [(1::Int)..(2::Integer)] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail009.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail009.stderr new file mode 100644 index 0000000..86760a4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail009.stderr @@ -0,0 +1,7 @@ + +"tcfail009.hs", line 3: + Couldn't match type "Integer" against "Int". + In an arithmetic sequence: [ (1 :: Int) .. (2 :: Integer) ] +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail010.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail010.hs new file mode 100644 index 0000000..8b79335 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail010.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +q = \ (y:z) -> z+2 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail010.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail010.stderr new file mode 100644 index 0000000..46c8072 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail010.stderr @@ -0,0 +1,6 @@ + +"tcfail010.hs", line 3: No such instance: + class "Num", type "[tt4]" (at a use of an overloaded identifier: +) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail011.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail011.hs new file mode 100644 index 0000000..89f5c4b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail011.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +z = \y -> x x where x = y diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail011.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail011.stderr new file mode 100644 index 0000000..9ec109e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail011.stderr @@ -0,0 +1,5 @@ + +"tcfail011.hs", line 3: undefined value: y +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail012.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail012.hs new file mode 100644 index 0000000..67e5fa0 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail012.hs @@ -0,0 +1,3 @@ +module ShouldFail where + +True = [] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail012.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail012.stderr new file mode 100644 index 0000000..c1bb07e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail012.stderr @@ -0,0 +1,8 @@ + +"tcfail012.hs", line 3: + Couldn't match type "Bool" against "[tt0]". + In a pattern binding: + True = [] +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail013.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail013.hs new file mode 100644 index 0000000..c9ccc52 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail013.hs @@ -0,0 +1,4 @@ +module ShouldFail where + +f [] = 1 +f True = 2 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail013.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail013.stderr new file mode 100644 index 0000000..81b18dd --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail013.stderr @@ -0,0 +1,9 @@ + +"tcfail013.hs", line 3: + Couldn't match type "[tt2]" against "Bool". + Inside two equations or case alternatives: + ... [] -> 1 + ... True -> 2 +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail014.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail014.hs new file mode 100644 index 0000000..7d91699 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail014.hs @@ -0,0 +1,5 @@ +module ShouldFail where + +f x = g+1 + where g y = h+2 + where h z = z z diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail014.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail014.stderr new file mode 100644 index 0000000..c9390b2 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail014.stderr @@ -0,0 +1,10 @@ + +"tcfail014.hs", line 5: + Type variable "ot8" occurs within the type "ot8 -> ot9". + Too many arguments in application of function "z" + +"tcfail014.hs", line 6: No such instance: + class "Num", type "tt19 -> tt20" (at an overloaded literal: 1) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail015.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail015.hs new file mode 100644 index 0000000..ae929e3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail015.hs @@ -0,0 +1,9 @@ +module ShouldFail where + +data AList a = ANull | ANode a (AList a) + +type IntList = AList Int + +g (ANull) = 2 +g (ANode b (ANode c d)) | b = c+1 + | otherwise = 4 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail015.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail015.stderr new file mode 100644 index 0000000..4463818 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail015.stderr @@ -0,0 +1,6 @@ + +"tcfail015.hs", line 7: No such instance: + class "Num", type "Bool" (at an overloaded literal: 2) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail016.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail016.hs new file mode 100644 index 0000000..2dfd4a5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail016.hs @@ -0,0 +1,9 @@ +module ShouldFail where + +type AnnExpr a = (a,Expr a) + +data Expr a = Var [Char] + | App (AnnExpr a) (AnnExpr a) + +g (Var name) = [name] +g (App e1 e2) = (g e1)++(g e2) diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail016.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail016.stderr new file mode 100644 index 0000000..9d2fc28 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail016.stderr @@ -0,0 +1,11 @@ + +"tcfail016.hs", line 8: + Couldn't match type "(a, Expr a)" against "Expr a". + Inside a function binding: + g ... (Var name) + = [name] + (App e1 e2) + = (g e1) ++ (g e2) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail017.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail017.hs new file mode 100644 index 0000000..db3215d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail017.hs @@ -0,0 +1,13 @@ + +module ShouldFail where + +class C a where + op1 :: a -> a + +class (C a) => B a where + op2 :: a -> a -> a + +instance (B a) => B [a] where + op2 xs ys = xs + + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail017.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail017.stderr new file mode 100644 index 0000000..2c17257 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail017.stderr @@ -0,0 +1,6 @@ + +"tcfail017.hs", line 11: No such instance: + class "C", type "[a]" (at an instance declaration) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail018.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail018.hs new file mode 100644 index 0000000..d91306a --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail018.hs @@ -0,0 +1,5 @@ + + +module ShouldSucc where + +(a:[]) = 1 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail018.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail018.stderr new file mode 100644 index 0000000..7f564f4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail018.stderr @@ -0,0 +1,6 @@ + +"tcfail018.hs", line 5: No such instance: + class "Num", type "[tt3]" (at an overloaded literal: 1) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail019.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail019.hs new file mode 100644 index 0000000..b3da9cd --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail019.hs @@ -0,0 +1,21 @@ + +module P where + +class A a where + p1 :: a -> a + p2 :: a -> a -> a + +class (A b) => B b where + p3 :: b + p4 :: b -> b + +class (A c) => C c where + p5 :: c -> c + p6 :: c -> Int + +class (B d,C d) => D d where + p7 :: d -> d + +instance D [a] where + p7 l = [] + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail019.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail019.stderr new file mode 100644 index 0000000..7ac11dc --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail019.stderr @@ -0,0 +1,6 @@ + +"tcfail019.hs", line 20: No such instance: + class "B", type "[a]" (at an instance declaration) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail020.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail020.hs new file mode 100644 index 0000000..9697838 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail020.hs @@ -0,0 +1,17 @@ + +module P where + +class A a where + p1 :: a -> a + p2 :: a -> a -> a + +class (A b) => B b where + p3 :: b + +instance (A a) => B [a] where + p3 = [] + +data X = XC --, causes stack dump + +--instance B Bool where +-- p3 = True diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail020.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail020.stderr new file mode 100644 index 0000000..760faee --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail020.stderr @@ -0,0 +1,6 @@ + +"tcfail020.hs", line 12: No such instance: + class "A", type "[a]" (at an instance declaration) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail021.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail021.hs new file mode 100644 index 0000000..6afdea7 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail021.hs @@ -0,0 +1,2 @@ + +f x x = 2 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail021.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail021.stderr new file mode 100644 index 0000000..8b4e139 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail021.stderr @@ -0,0 +1,6 @@ + +"tcfail021.hs", line 2: multiple declarations of variable in pattern: + x ( "tcfail021.hs", line 2, "tcfail021.hs", line 2) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail022.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail022.hs new file mode 100644 index 0000000..d5e51ed --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail022.hs @@ -0,0 +1,6 @@ + +f x = 2 + +g x = 6 + +f x = 3 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail022.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail022.stderr new file mode 100644 index 0000000..277f09d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail022.stderr @@ -0,0 +1,6 @@ + +"tcfail022.hs", line 2: multiple declarations of variable: + f ( "tcfail022.hs", line 2, "tcfail022.hs", line 6) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail023.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail023.hs new file mode 100644 index 0000000..ae2a356 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail023.hs @@ -0,0 +1,13 @@ + +data B = C + +class A a where + op :: a -> a + +instance A B where + op C = True + +instance A B where + op C = True + + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail023.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail023.stderr new file mode 100644 index 0000000..52dd9fa --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail023.stderr @@ -0,0 +1,11 @@ + +"tcfail023.hs", line 8: Duplicate/overlapping instances: + class "A", type "B"; at "tcfail023.hs", line 8 and "tcfail023.hs", line 11 + +"tcfail023.hs", line 11: + Couldn't match type "Bool" against "B". + Inside a function binding: + op ... C = True +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail024.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail024.hs new file mode 100644 index 0000000..3dc5678 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail024.hs @@ -0,0 +1,4 @@ + +data F = A | B + +data G = A | C diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail024.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail024.stderr new file mode 100644 index 0000000..f48129d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail024.stderr @@ -0,0 +1,6 @@ + +"tcfail024.hs", line 2: multiple declarations of variable: + A ( "tcfail024.hs", line 2, "tcfail024.hs", line 4) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail025.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail025.hs new file mode 100644 index 0000000..b342618 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail025.hs @@ -0,0 +1,6 @@ + +type A = Int + +type B = Bool + +type A = [Bool] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail025.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail025.stderr new file mode 100644 index 0000000..02efd9b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail025.stderr @@ -0,0 +1,6 @@ + +"tcfail025.hs", line 6: multiple declarations of type synonym: + A ( "tcfail025.hs", line 6, "tcfail025.hs", line 2) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail026.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail026.hs new file mode 100644 index 0000000..725b0d1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail026.hs @@ -0,0 +1,9 @@ + +class A a where + op1 :: a + +class B a where + op2 :: b -> b + +class A a where + op3 :: a diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail026.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail026.stderr new file mode 100644 index 0000000..950e459 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail026.stderr @@ -0,0 +1,6 @@ + +"tcfail026.hs", line 9: multiple declarations of class: + A ( "tcfail026.hs", line 9, "tcfail026.hs", line 3) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail027.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail027.hs new file mode 100644 index 0000000..b80430b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail027.hs @@ -0,0 +1,7 @@ +--!!! tests for CycleErr in classes + +class (B a) => A a where + op1 :: a -> a + +class (A a) => B a where + op2 :: a -> a -> a diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail027.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail027.stderr new file mode 100644 index 0000000..e86e6ab --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail027.stderr @@ -0,0 +1,7 @@ + +The following classes form a cycle: + "tcfail027.hs", line 4: A + "tcfail027.hs", line 7: B +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail028.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail028.hs new file mode 100644 index 0000000..8e8c294 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail028.hs @@ -0,0 +1,3 @@ +--!!! tests for ArityErr + +data A a b = B (A a) diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail028.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail028.stderr new file mode 100644 index 0000000..edc5403 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail028.stderr @@ -0,0 +1,6 @@ + +"tcfail028.hs", line 3: Type has too few arguments: + "A" should have 2 argument(s), but has been given 1 argument(s) instead +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail029.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail029.hs new file mode 100644 index 0000000..312e6fe --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail029.hs @@ -0,0 +1,5 @@ +--!!! tests for InstOpErr + +data Foo = Bar | Baz + +f x = x > Bar diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail029.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail029.stderr new file mode 100644 index 0000000..2ba7250 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail029.stderr @@ -0,0 +1,6 @@ + +"tcfail029.hs", line 5: No such instance: + class "Ord", type "Foo" (at a use of an overloaded identifier: >) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail030.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail030.hs new file mode 100644 index 0000000..2aa8659 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail030.hs @@ -0,0 +1 @@ +--!!! empty file diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail030.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail030.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail030.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail031.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail031.hs new file mode 100644 index 0000000..c81ced8 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail031.hs @@ -0,0 +1,2 @@ + +f x = if 'a' then 1 else 2 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail031.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail031.stderr new file mode 100644 index 0000000..5f304ee --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail031.stderr @@ -0,0 +1,6 @@ + +"tcfail031.hs", line 2: + Couldn't match type "Char" against "Bool". In a predicate expression: 'a' +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail032.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail032.hs new file mode 100644 index 0000000..0e8884d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail032.hs @@ -0,0 +1,16 @@ +{- This test gives the following not-very-wonderful error message. + + "tc_sig.hs", line 3: Type signature does not match the inferred type: + Signature: t76 -> Int + Inferred type: t75 + +It *is* an error, because x does not have the polytype + forall a. Eq a => a -> Int +becuase it is monomorphic, but the error message isn't very illuminating. +-} + +module TcSig where + +f x = (x :: (Eq a) => a -> Int) + + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail032.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail032.stderr new file mode 100644 index 0000000..53fee2d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail032.stderr @@ -0,0 +1,8 @@ + +"tcfail032.hs", line 14: Type signature is too polymorphic: + Signature: a -> Int + Monomorphic type variables: a + In an expression with a type signature: x:: a -> Int +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail033.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail033.hs new file mode 100644 index 0000000..5c8b4d8 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail033.hs @@ -0,0 +1,3 @@ +-- from Jon Hill + +buglet = [ x | (x,y) <- buglet ] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail033.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail033.stderr new file mode 100644 index 0000000..b441c25 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail033.stderr @@ -0,0 +1,8 @@ + +"tcfail033.hs", line 3: + Type variable "tt2" occurs within the type "(tt2, tt3)". + In a pattern binding: + buglet = [ x | (x, y) <- buglet ] +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail034.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail034.hs new file mode 100644 index 0000000..e0d0ffe --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail034.hs @@ -0,0 +1,37 @@ +{- +From: Jon Hill +To: glasgow-haskell-bugs +Subject: Unfriendly error message +Date: Thu, 25 Jun 1992 09:22:55 +0100 + +Hello again, + +I came across a rather nasty error message when I gave a function an +incorrect type signature (the context is wrong). I can remember reading +in the source about this problem - I just thought I'd let you know anyway :-) +-} + +test::(Num a, Eq a) => a -> Bool +test x = (x `mod` 3) == 0 + +{- +granite> ndph bug002.ldh +Data Parallel Haskell Compiler, version 0.01 (Glasgow 0.07) + + +"", line : Cannot express dicts in terms of dictionaries available: +dicts_encl: + "", line : dict.87 :: + "", line : dict.88 :: +dicts_encl': + "", line : dict.87 :: + "", line : dict.88 :: +dicts: + "", line : dict.87 :: + "", line : dict.88 :: +super_class_dict: "", line : dict.80 :: +Fail: Compilation errors found + +dph: execution of the Haskell compiler had trouble + +-} diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail034.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail034.stderr new file mode 100644 index 0000000..db6fbf4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail034.stderr @@ -0,0 +1,7 @@ + +These overloadings don't match type signature: + "tcfail034.hs", line 15; class "Integral", type "a" + (at a use of an overloaded identifier: mod) +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail035.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail035.hs new file mode 100644 index 0000000..a0b9f0e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail035.hs @@ -0,0 +1,9 @@ +--!!! instances with empty where parts: duplicate +-- +module M where + +data NUM = ONE | TWO +instance Num NUM +instance Num NUM +instance Eq NUM +instance Text NUM diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail035.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail035.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail036.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail036.hs new file mode 100644 index 0000000..eb9f9af --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail036.hs @@ -0,0 +1,10 @@ +--!!! prelude class name in an instance-tycon position +-- +module M where + +data NUM = ONE | TWO +instance Num NUM + where ONE + ONE = TWO +instance Num NUM +instance Eq Num +--instance Text Num diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail036.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail036.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail037.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail037.hs new file mode 100644 index 0000000..07b308b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail037.hs @@ -0,0 +1,11 @@ +--!!! PreludeCore entities cannot be redefined at the top-level +-- +module M where + +data NUM = ONE | TWO + +f a b = a + b +f :: NUM -> NUM -> NUM + +ONE + ONE = TWO + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail037.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail037.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail038.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail038.hs new file mode 100644 index 0000000..7d03529 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail038.hs @@ -0,0 +1,11 @@ +--!!! duplicate class-method declarations + +module M where + +data NUM = ONE | TWO +instance Eq NUM where + a == b = True + a /= b = False + a == b = False + a /= b = True + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail038.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail038.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail039.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail039.hs new file mode 100644 index 0000000..f0df10c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail039.hs @@ -0,0 +1,12 @@ +--!!! bogus re-use of prelude class-method name (==) +-- +module M where + +data NUM = ONE | TWO +class EQ a where + (==) :: a -> a -> Bool + +instance EQ NUM +-- a /= b = False +-- a == b = True +-- a /= b = False diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail039.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail039.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail040.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail040.hs new file mode 100644 index 0000000..c611518 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail040.hs @@ -0,0 +1,29 @@ +--!!! instances of functions +-- +module M where + +data NUM = ONE | TWO + +class EQ a where + (===) :: a -> a -> Bool + +class ORD a where + (<<) :: a -> a -> Bool + a << b = True + +instance EQ (a -> b) where + f === g = True + +instance ORD (a -> b) + +f = (<<) === (<<) +--f :: (EQ a,Num a) => a -> a -> Bool + + +{- +instance EQ NUM where +-- a /= b = False + a === b = True +-- a /= b = False + +-} diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail040.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail040.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail041.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail041.hs new file mode 100644 index 0000000..ca92003 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail041.hs @@ -0,0 +1,60 @@ +{- +To: Lennart Augustsson +Cc: partain@dcs.gla.ac.uk, John Peterson (Yale) , + simonpj@dcs.gla.ac.uk +Subject: Type checking matter +Date: Fri, 23 Oct 92 15:28:38 +0100 +From: Simon L Peyton Jones + + +I've looked at the enclosed again. It seems to me that +since "s" includes a recursive call to "sort", inside the body +of "sort", then "sort" is monomorphic, and hence so is "s"; +hence the type signature (which claims full polymorphism) is +wrong. + +[Lennart says he can't see any free variables inside "s", but there +is one, namely "sort"!] + +Will: one for the should-fail suite? + +Simon + + +------- Forwarded Message + + +From: Lennart Augustsson +To: partain +Subject: Re: just to show you I'm a nice guy... +Date: Tue, 26 May 92 17:30:12 +0200 + +> Here's a fairly simple module from our compiler, which includes what +> we claim is an illegal type signature (grep ILLEGAL ...). +> Last time I checked, hbc accepted this module. + +Not that I don't believe you, but why is this illegal? +As far as I can see there are no free variables in the function s, +which makes me believe that it can typechecked like a top level +definition. And for a top level defn the signature should be +all right. + + -- Lennart +- ------- End of forwarded message ------- +-} + +sort :: Ord a => [a] -> [a] +sort xs = s xs (length xs) + where + s :: Ord b => [b] -> Int -> [b] -- This signature is WRONG + s xs k = if k <= 1 then xs + else merge (sort ys) (sort zs) + where (ys,zs) = init_last xs (k `div` (2::Int)) + +-- Defns of merge and init_last are just dummies with the correct types +merge :: Ord a => [a] -> [a] -> [a] +merge xs ys = xs + +init_last :: [a] -> Int -> ([a],[a]) +init_last a b = (a,a) + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail041.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail041.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail042.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail042.hs new file mode 100644 index 0000000..566bfea --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail042.hs @@ -0,0 +1,28 @@ +--!!! weird class/instance examples off the haskell list +-- + +class Foo a where foo :: a -> a +class Foo a => Bar a where bar :: a -> a + + +instance Num a => Foo [a] where + foo [] = [] + foo (x:xs) = map (x+) xs + + +instance (Eq a, Text a) => Bar [a] where + bar [] = [] + bar (x:xs) = foo xs where u = x==x + v = show x + +------------------------------------------ + +{- +class Foo a => Bar2 a where bar2 :: a -> a + +instance (Eq a, Text a) => Foo [a] + +instance Num a => Bar2 [a] + +data X a = X a +-} diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail042.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail042.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail043.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail043.hs new file mode 100644 index 0000000..cc1983b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail043.hs @@ -0,0 +1,222 @@ +-- The translation of this program should assign only one dictionary to +-- the function search (an Ord dictionary). Instead, it assigns two. +-- The output produced currently displays this. + +-- 10/12/92: This program is actually erroneous. The pattern-binding for +-- search falls under the monomorphism restriction, and there is no +-- call to search which might fix its type. So there should be a complaint. +-- But the actual error message is horrible: +-- +-- "bug001.hs", line 26: Ambiguous overloading: +-- class "Ord_", type "a" (at a use of an overloaded identifier: gt) +-- class "Eq_", type "a" (at a use of an overloaded identifier: eq) + + + +class Eq_ a where + eq :: a -> a -> Bool + +instance Eq_ Int where + eq = eqIntEq + +instance (Eq_ a) => Eq_ [a] where + eq = \ xs ys -> + if (null xs) + then (null ys) + else if (null ys) + then False + else and (eq (hd xs) (hd ys)) (eq (tl xs) (tl ys)) + +class (Eq_ a) => Ord_ a where + gt :: a -> a -> Bool + +instance Ord_ Int where + gt = ordIntGt + +search + = \ a bs -> if gt (hd bs) a + then False + else if eq a (hd bs) then True else search a (tl bs) + +and :: Bool -> Bool -> Bool +and True True = True + +hd :: [a] -> a +hd (a:as) = a + +tl :: [a] -> [a] +tl (a:as) = as + +ordIntGt :: Int -> Int -> Bool +ordIntGt 2 3 = True + +eqIntEq :: Int -> Int -> Bool +eqIntEq 2 3 = True + +null :: [a] -> Bool +null [] = True + + + +{- + +=============================================== +Main.Eq__INST_PreludeBuiltin.Int = + let + AbsBinds [] [] [(eq, eq)] + {- nonrec -} + {-# LINE 2 "test3.hs" -} + + eq :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + eq = Main.eqIntEq + in ({-dict-} [] [eq]) + +Main.Eq__INST_PreludeBuiltin.List = + /\ t135 -> + \{-dict-} _dict138 -> + let + {- nonrec -} + _dict136 = {-singleDict-} _dict138 + {- nonrec -} + _dict129 = {-singleDict-} _dict136 + AbsBinds [] [] [(eq, eq)] + {- nonrec -} + + _dict133 = + Main.Eq__INST_PreludeBuiltin.List + [t135] [{-singleDict-} _dict136] + {- nonrec -} + {-# LINE 5 "test3.hs" -} + + eq :: [t135] -> [t135] -> PreludeCore.Bool + eq = \ xs ys -> + +if (Main.null t135) xs then + (Main.null t135) ys + else + + if (Main.null t135) ys then + PreludeCore.False + else + + Main.and + + + ((Main.Eq_.eq t135 _dict129) + + + ((Main.hd t135) xs) + ((Main.hd t135) ys)) + + + + + + +(Main.Eq_.eq [t135] _dict133) + + + + ((Main.tl t135) xs) + ((Main.tl t135) ys)) + in ({-dict-} [] [eq]) +Main.Ord__INST_PreludeBuiltin.Int = + let + {- nonrec -} + _dict142 = Main.Eq__INST_PreludeBuiltin.Int [] [] + AbsBinds [] [] [(gt, gt)] + {- nonrec -} + {-# LINE 16 "test3.hs" -} + + gt :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + gt = Main.ordIntGt + in ({-dict-} [_dict142] [gt]) + +Main.Eq_.eq = /\ a -> \{-classdict-} [] [eq] -> eq + +Main.Ord_.gt = /\ a -> \{-classdict-} [_dict56] [gt] -> gt + +Main.Ord__TO_Main.Eq_ = /\ a -> \{-classdict-} [_dict58] [gt] -> ???_dict58??? + +AbsBinds [t60] [] [(hd, Main.hd)] + {- nonrec -} + + + + hd :: [t60] -> t60 + hd (a PreludeBuiltin.: as) + = a + +AbsBinds [t68] [] [(tl, Main.tl)] + {- nonrec -} + + + + + tl :: [t68] -> [t68] + tl (a PreludeBuiltin.: as) + = as + + +AbsBinds [t91] [_dict85, _dict88] [(search, Main.search)] + {- rec -} + {-# LINE 19 "test3.hs" -} + + + search :: t91 -> [t91] -> PreludeCore.Bool + search + = \ a bs -> + + +if (Main.Ord_.gt t91 _dict85) ((Main.hd t91) bs) a then + PreludeCore.False + else + + if (Main.Eq_.eq t91 _dict88) a ((Main.hd t91) bs) then + PreludeCore.True + else + + search a ((Main.tl t91) bs) +AbsBinds [] [] [(and, Main.and)] + {- nonrec -} + and :: PreludeCore.Bool -> PreludeCore.Bool -> PreludeCore.Bool + and PreludeCore.True PreludeCore.True + = PreludeCore.True +AbsBinds [] [] [(ordIntGt, Main.ordIntGt)] + {- nonrec -} + _dict97 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict98 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict100 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict101 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + + + + ordIntGt :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + ordIntGt + 2 3 = PreludeCore.True +AbsBinds [] [] [(eqIntEq, Main.eqIntEq)] + {- nonrec -} + _dict105 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict106 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict108 = PreludeCore.Num_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + _dict109 = PreludeCore.Eq_INST_PreludeBuiltin.Int [] [] + {- nonrec -} + + eqIntEq :: PreludeBuiltin.Int -> PreludeBuiltin.Int -> PreludeCore.Bool + eqIntEq + 2 3 = PreludeCore.True + + +AbsBinds [t112] [] [(null, Main.null)] + {- nonrec -} + + null :: [t112] -> PreludeCore.Bool + null [] = PreludeCore.True +-} diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail043.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail043.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail044.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail044.hs new file mode 100644 index 0000000..9d05640 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail044.hs @@ -0,0 +1,22 @@ +--!!! tcfail044: duplicated type variable in instance decls +-- +module Main where + +instance (Eq a) => Eq (a->a) + + +instance (Num a) => Num (a->a) where + f + g = \x -> f x + g x + negate f = \x -> - (f x) + f * g = \x -> f x * g x + fromInteger n = \x -> fromInteger n + +ss :: Float -> Float +cc :: Float -> Float +tt :: Float -> Float + +ss = sin * sin +cc = cos * cos +tt = ss + cc + +main _ = [AppendChan stdout ((show (tt 0.4))++ " "++(show (tt 1.652)))] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail044.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail044.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail045.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail045.hs new file mode 100644 index 0000000..f13b603 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail045.hs @@ -0,0 +1,7 @@ +--!!! a bad _CCallable thing (from a bug from Satnam) +-- +data Socket = Socket# _Addr +instance _CCallable Socket + +f :: Socket -> PrimIO () +f x = _ccall_ foo x diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail045.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail045.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail046.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail046.hs new file mode 100644 index 0000000..c58988a --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail046.hs @@ -0,0 +1,32 @@ +--!! function types in deriving Eq things +-- From a bug report by Dave Harrison + +module Simulation(Process(..), + Status, + Pid(..), + Time(..), + Continuation, + Message, + MessList(..) ) where + +type Process a = Pid -> Time -> Message a -> ( MessList a, + Continuation a) + +data Continuation a = Do (Process a) deriving Eq + + +type ProcList a = [ (Pid, Status, Process a) ] +data Status = Active | Passive | Busy Integer | Terminated + deriving Eq + + +data Message a = Create (Process a) | Created Pid | Activate Pid | + Passivate Pid | Terminate Pid | Wait Pid Time | + Query Pid a | Data Pid a | Event | + Output Pid String + deriving Eq + +type MessList a = [ Message a ] + +type Pid = Integer +type Time = Integer diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail046.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail046.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail047.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail047.hs new file mode 100644 index 0000000..12770a3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail047.hs @@ -0,0 +1,6 @@ + +class A a where + op1 :: a -> a + +instance A (a,(b,c)) where + op1 a = a diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail047.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail047.stderr new file mode 100644 index 0000000..fd0781b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail047.stderr @@ -0,0 +1,2 @@ +"tcfail047.hs", line 5: syntax error; on input: ( +ghc: execution of the Haskell parser had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail048.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail048.hs new file mode 100644 index 0000000..5b58e20 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail048.hs @@ -0,0 +1,3 @@ + +class (B a) => C a where + op1 :: a -> a diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail048.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail048.stderr new file mode 100644 index 0000000..5d16831 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail048.stderr @@ -0,0 +1,5 @@ + +"tcfail048.hs", line 3: undefined class: B +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail049.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail049.hs new file mode 100644 index 0000000..3fa7791 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail049.hs @@ -0,0 +1,2 @@ + +f x = g x diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail049.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail049.stderr new file mode 100644 index 0000000..8156893 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail049.stderr @@ -0,0 +1,5 @@ + +"tcfail049.hs", line 2: undefined value: g +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail050.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail050.hs new file mode 100644 index 0000000..a1fa354 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail050.hs @@ -0,0 +1,2 @@ + +f x = B x diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail050.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail050.stderr new file mode 100644 index 0000000..0f3df12 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail050.stderr @@ -0,0 +1,5 @@ + +"tcfail050.hs", line 2: undefined value: B +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail051.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail051.hs new file mode 100644 index 0000000..f94aa9d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail051.hs @@ -0,0 +1,3 @@ + +instance B Bool where + op1 a = a diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail051.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail051.stderr new file mode 100644 index 0000000..1ea74dc --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail051.stderr @@ -0,0 +1,7 @@ + +"tcfail051.hs", line 3: undefined class: B + +"tcfail051.hs", line 3: "op1" is not an operation of class "*UNBOUND*B". +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail052.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail052.hs new file mode 100644 index 0000000..0948805 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail052.hs @@ -0,0 +1,2 @@ + +data C a = B a c diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail052.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail052.stderr new file mode 100644 index 0000000..33d2255 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail052.stderr @@ -0,0 +1,5 @@ + +"tcfail052.hs", line 2: undefined type variable: c +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail053.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail053.hs new file mode 100644 index 0000000..99028ab --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail053.hs @@ -0,0 +1,2 @@ + +data B = C A diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail053.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail053.stderr new file mode 100644 index 0000000..8030f97 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail053.stderr @@ -0,0 +1,5 @@ + +"tcfail053.hs", line 2: undefined type constructor: A +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail054.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail054.hs new file mode 100644 index 0000000..69ce2e8 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail054.hs @@ -0,0 +1,2 @@ + +f (B a) = True diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail054.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail054.stderr new file mode 100644 index 0000000..4c2a2f6 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail054.stderr @@ -0,0 +1,5 @@ + +"tcfail054.hs", line 2: undefined value: B +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail055.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail055.hs new file mode 100644 index 0000000..fc6efe3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail055.hs @@ -0,0 +1,2 @@ + +f x = (x + 1 :: Int) :: Float diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail055.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail055.stderr new file mode 100644 index 0000000..c3bd561 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail055.stderr @@ -0,0 +1,7 @@ + +"tcfail055.hs", line 2: + Couldn't match type "Int" against "Float". + In an expression with a type signature: (x (+) 1 :: Int):: Float +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail056.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail056.hs new file mode 100644 index 0000000..6e15f2b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail056.hs @@ -0,0 +1,10 @@ + +data Foo = MkFoo Bool + +instance Eq Foo where + (MkFoo x) == (MkFoo y) = x == y + +instance Eq Foo where + -- forgot to type "Ord" above + (MkFoo x) <= (MkFoo y) = x <= y + diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail056.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail056.stderr new file mode 100644 index 0000000..cb7ca89 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail056.stderr @@ -0,0 +1,5 @@ + +"tcfail056.hs", line 9: "<=" is not an operation of class "Eq". +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail057.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail057.hs new file mode 100644 index 0000000..bef0085 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail057.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +--!!! inadvertently using -> instead of => + +f :: (RealFrac a) -> a -> a +f x = x diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail057.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail057.stderr new file mode 100644 index 0000000..8159127 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail057.stderr @@ -0,0 +1,5 @@ + +"tcfail057.hs", line 5: undefined type constructor: RealFrac +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail058.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail058.hs new file mode 100644 index 0000000..191d564 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail058.hs @@ -0,0 +1,6 @@ +module ShouldFail where + +--!!! inadvertently using => instead of -> + +f :: (Array a) => a -> b +f x = x diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail058.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail058.stderr new file mode 100644 index 0000000..2ab1191 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail058.stderr @@ -0,0 +1,5 @@ + +"tcfail058.hs", line 5: undefined class: Array +Fail: Compilation errors found + +ghc: execution of the Haskell compiler had trouble diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail059.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail059.hs new file mode 100644 index 0000000..8f80a69 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail059.hs @@ -0,0 +1,3 @@ +--!! The tycon export shouldn't be allowed to succeed +-- +module Foo ( Bar(..) ) where { data Bar = Bar X; data X = Y } diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail059.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail059.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail060.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail060.hs new file mode 100644 index 0000000..1d85992 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail060.hs @@ -0,0 +1,9 @@ +--!! The class export shouldn't be allowed to succeed +-- +module Foo ( Baz(..) ) where + +class Baz a where + opx :: Int -> Bar -> a -> a + +data Bar = Bar X +data X = Y diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail060.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail060.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail061.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail061.hs new file mode 100644 index 0000000..4ed535e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail061.hs @@ -0,0 +1,10 @@ +--!! signature bugs exposed by Sigbjorne Finne +-- + +type Flarp a = (b,b) + +--More fun can be had if we change the signature slightly + +type Bob a = a + +type Flarp2 a = Bob (b,b) diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail061.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail061.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail062.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail062.hs new file mode 100644 index 0000000..8989d91 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail062.hs @@ -0,0 +1,37 @@ +--!!! bug report from Satnam +-- +module RubyAST +where + +type Module = (String,[Declaration]) + +data Declaration + = Architecture String StructuralExpression | + Behaviour String Parameter Parameter BehaviouralExpression + deriving (Eq, Text) + +data Parameter = ParameterVariable String | ParameterList [Parameter] + deriving (Eq, Text) + +nameOfModule :: Module -> String +nameOfModule (name, _) = name + +data StructuralExpression + = Variable String | + Serial StructuralExpression StructuralExpression | + Par [StructuralExpression] + deriving (Eq, Text) + +data BehaviouralExpression + = BehaviouralVariable String + | AndExpr BehaviouralExpression BehaviouralExpression + | OrExpr BehaviouralExpression BehaviouralExpression + | NotExpr BehaviouralExpression + deriving (Eq, Text) + + +type BehaviouralRelation + = (behaviouralExpression, behaviouralExpression) +-----^ typo ----------------^ typo (but so what?) + +type BehaviouralRelationList = [BehaviouralRelation] diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail062.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail062.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail063.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail063.hs new file mode 100644 index 0000000..562cdf4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail063.hs @@ -0,0 +1,5 @@ +--!!! no type variable on a context +--!!! reported by Sigbjorn Finne + +moby :: Num => Int -> a -> Int +moby x y = x+y diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail063.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail063.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail065.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail065.hs new file mode 100644 index 0000000..3029b19 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail065.hs @@ -0,0 +1,37 @@ +{- + +------- Forwarded Message + +Date: Wed, 30 Nov 1994 16:34:18 +0100 +From: John Hughes +To: augustss@cs.chalmers.se, simonpj@dcs.gla.ac.uk +Subject: Nice little program + + +Lennart, Simon, + +You might like to look at the fun little program below. + +THUMBS DOWN to hbc for compiling it (it prints [72, 101, 108, 108, 111]) +THUMBS UP to ghc for rejecting it --- but what an error message! +nhc and gofer both reject it with the right error message. +I haven't tried Yale Haskell. + +Enjoy! +- ---------------------------- +-} + +class HasX a where + setX :: x->a->a + +data X x = X x +instance HasX (X x) where + setX x (X _) = X x + +changetype x = case setX x (X (error "change type!")) of X y->y + +main = print (changetype "Hello" :: [Int]) + +{- +------- End of Forwarded Message +-} diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail065.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail065.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail066.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail066.hs new file mode 100644 index 0000000..f146acd --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail066.hs @@ -0,0 +1,41 @@ +--!! INLINE on recursive functions. +{- +Date: Thu, 8 Dec 94 11:38:24 GMT +From: Julian Seward (DRL PhD) +Message-Id: <9412081138.AA16652@rdf009.cs.man.ac.uk> +To: partain@dcs.gla.ac.uk +-} + +type IMonad a + = IMonadState -> IMonadReturn a + +data IMonadReturn a + = IMonadOk IMonadState a + | IMonadFail IMonadState String + +type IMonadState + = Int + + +returnI r = \s0 -> IMonadOk s0 r + +failI msg = \s0 -> IMonadFail s0 msg + +thenI m k + = \s0 -> case m s0 of + IMonadFail s1 msg -> IMonadFail s1 msg + IMonadOk s1 r1 -> k r1 s1 + +tickI n = \s0 -> IMonadOk (s0+n) () + +mapI f [] = returnI [] +mapI f (x:xs) = f x `thenI` ( \ fx -> + mapI f xs `thenI` ( \ fxs -> + returnI (fx:fxs) + )) + +{-# INLINE returnI #-} +{-# INLINE failI #-} +{-# INLINE thenI #-} +{-# INLINE tickI #-} +{-# INLINE mapI #-} diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail066.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail066.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail067.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail067.hs new file mode 100644 index 0000000..b84328c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail067.hs @@ -0,0 +1,98 @@ +module SubRange where + +infixr 1 `rangeOf` + + +data Ord a => SubRange a = SubRange (a, a) a + +type IntSubRange = SubRange Int + + +subRangeValue :: SubRange a -> a +subRangeValue (SubRange (lower, upper) value) = value + +subRange :: SubRange a -> (a, a) +subRange (SubRange r value) = r + +newRange :: (Ord a, Text a) => (a, a) -> a -> SubRange a +newRange r value = checkRange (SubRange r value) + + +checkRange :: (Ord a, Text a) => SubRange a -> SubRange a +checkRange (SubRange (lower, upper) value) + = if (value < lower) || (value > upper) then + error ("### sub range error. range = " ++ show lower ++ + ".." ++ show upper ++ " value = " ++ show value ++ "\n") + else + SubRange (lower, upper) value + + +instance Eq a => Eq (SubRange a) where + (==) a b = subRangeValue a == subRangeValue b + +instance (Ord a) => Ord (SubRange a) where + (<) = relOp (<) + (<=) = relOp (<=) + (>=) = relOp (>=) + (>) = relOp (>) + +relOp :: Ord a => (a->a->Bool) -> SubRange a -> SubRange a -> Bool +relOp op a b = (subRangeValue a) `op` (subRangeValue b) + +rangeOf :: (Ord a, Text a) => SubRange a -> SubRange a -> SubRange a +rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a)) + +showRange :: Text a => SubRange a -> String +showRange (SubRange (lower, upper) value) + = show value ++ " :" ++ show lower ++ ".." ++ show upper + +showRangePair :: (Text a, Text b) => (SubRange a, SubRange b) -> String +showRangePair (a, b) + = "(" ++ showRange a ++ ", " ++ showRange b ++ ")" + +showRangeTriple :: (Text a, Text b, Text c) => + (SubRange a, SubRange b, SubRange c) -> String +showRangeTriple (a, b, c) + = "(" ++ showRange a ++ ", " ++ showRange b ++ ", " ++ showRange c ++ ")" + + + +instance Num a => Num (SubRange a) where + negate = numSubRangeNegate + (+) = numSubRangeAdd + (-) = numSubRangeSubtract + (*) = numSubRangeMultiply + fromInteger a = SubRange (fromInteger a, fromInteger a) (fromInteger a) + +numSubRangeNegate :: (Ord a, Num a) => SubRange a -> SubRange a +numSubRangeNegate (SubRange (lower, upper) value) + = checkRange (SubRange (lower, upper) (-value)) + +numSubRangeBinOp :: Num a => (a -> a -> a) -> + SubRange a -> SubRange a -> SubRange a +numSubRangeBinOp op a b + = SubRange (result, result) result + where + result = (subRangeValue a) `op` (subRangeValue b) + +-- partain: +numSubRangeAdd, numSubRangeSubtract, numSubRangeMultiply :: Num a => SubRange a -> SubRange a -> SubRange a + +numSubRangeAdd = numSubRangeBinOp (+) +numSubRangeSubtract = numSubRangeBinOp (-) +numSubRangeMultiply = numSubRangeBinOp (*) + +unsignedBits :: Int -> (Int, Int) +unsignedBits n = (0, 2^n-1) + +signedBits :: Int -> (Int, Int) +signedBits n = (-2^(n-1), 2^(n-1)-1) + + +si_n :: Int -> Int -> IntSubRange +si_n bits value = SubRange (signedBits bits) value + +si8, si10, si16 :: Int -> IntSubRange +si8 = si_n 8 +si10 = si_n 10 +si16 = si_n 16 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail067.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail067.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail068.hs b/ghc/compiler/tests/typecheck/should_fail/tcfail068.hs new file mode 100644 index 0000000..2b17bce --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_fail/tcfail068.hs @@ -0,0 +1,92 @@ +--!! Make sure that state threads don't escape +--!! (example from Neil Ashton at York) +-- +module IndTree(IndTree(..), itgen, itiap, itrap, itrapstate) where + +--partain: import Auxiliary +import PreludeGlaST + +type IndTree s t = _MutableArray s (Int,Int) t + +itgen :: Constructed a => (Int,Int) -> a -> IndTree s a +itgen n x = + _runST ( + newArray ((1,1),n) x) + +itiap :: Constructed a => (Int,Int) -> (a->a) -> IndTree s a -> IndTree s a +itiap i f arr = + _runST ( + readArray arr i `thenStrictlyST` \val -> + writeArray arr i (f val) `seqStrictlyST` + returnStrictlyST arr) + +itrap :: Constructed a => ((Int,Int),(Int,Int)) -> (a->a) -> IndTree s a -> IndTree s a +itrap ((i,k),(j,l)) f arr = _runST(itrap' i k) + where + itrap' i k = if k > l then returnStrictlyST arr + else (itrapsnd i k `seqStrictlyST` + itrap' i (k+1)) + itrapsnd i k = if i > j then returnStrictlyST arr + else (readArray arr (i,k) `thenStrictlyST` \val -> + writeArray arr (i,k) (f val) `seqStrictlyST` + itrapsnd (i+1) k) + +itrapstate :: Constructed b => ((Int,Int),(Int,Int)) -> (a->b->(a,b)) -> ((Int,Int)->c->a) -> + (a->c) -> c -> IndTree s b -> (c, IndTree s b) +itrapstate ((i,k),(j,l)) f c d s arr = _runST(itrapstate' i k s) + where + itrapstate' i k s = if k > l then returnStrictlyST (s,arr) + else (itrapstatesnd i k s `thenStrictlyST` \(s,arr) -> + itrapstate' i (k+1) s) + itrapstatesnd i k s = if i > j then returnStrictlyST (s,arr) + else (readArray arr (i,k) `thenStrictlyST` \val -> + let (newstate, newval) = f (c (i,k) s) val + in writeArray arr (i,k) newval `seqStrictlyST` + itrapstatesnd (i+1) k (d newstate)) + +-- stuff from Auxiliary: copied here (partain) + +sap :: (a->b) -> (c,a) -> (c,b) +sap f (x,y) = (x, f y) + +fap :: (a->b) -> (a,c) -> (b,c) +fap f (x,y) = (f x, y) + +nonempty :: [a] -> Bool +nonempty [] = False +nonempty (_:_) = True + +-- const :: a -> b -> a +-- const k x = k + +-- id :: a -> a +-- id x = x + +compose :: [a->a] -> a -> a +compose = foldr (.) id + +data Maybe t = Just t | Nothing + +class Constructed a where + normal :: a -> Bool + +instance Constructed Bool where + normal True = True + normal False = True + +instance Constructed Int where + normal 0 = True + normal n = True + +instance (Constructed a, Constructed b) => Constructed (a,b) where + normal (x,y) = normal x && normal y + +-- pair :: (Constructed a, Constructed b) => a -> b -> (a,b) +-- pair x y | normal x && normal y = (x,y) + +instance Constructed (Maybe a) where + normal Nothing = True + normal (Just _) = True + +just :: Constructed a => a -> Maybe a +just x | normal x = Just x diff --git a/ghc/compiler/tests/typecheck/should_fail/tcfail068.stderr b/ghc/compiler/tests/typecheck/should_fail/tcfail068.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_succeed/ClassFoo.hi b/ghc/compiler/tests/typecheck/should_succeed/ClassFoo.hi new file mode 100644 index 0000000..eb94aa3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/ClassFoo.hi @@ -0,0 +1,4 @@ +interface ClassFoo where +class Foo a where + op1 :: a -> Int + op2 :: a -> a -> Int {-# ARITY op2 = 3 #-}{-# UPDATE op2 = 000 #-} {-# ARITY op1 = 1 #-}{-# UPDATE op1 = 0 #-} diff --git a/ghc/compiler/tests/typecheck/should_succeed/Jmakefile b/ghc/compiler/tests/typecheck/should_succeed/Jmakefile new file mode 100644 index 0000000..e29a59c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/Jmakefile @@ -0,0 +1,93 @@ +TEST_FLAGS=-noC -ddump-tc -dcore-lint -hi + +RunStdTest(tc001,$(GHC),$(TEST_FLAGS) tc001.hs -o2 tc001.stderr) +RunStdTest(tc002,$(GHC),$(TEST_FLAGS) tc002.hs -o2 tc002.stderr) +RunStdTest(tc003,$(GHC),$(TEST_FLAGS) tc003.hs -o2 tc003.stderr) +RunStdTest(tc004,$(GHC),$(TEST_FLAGS) tc004.hs -o2 tc004.stderr) +RunStdTest(tc005,$(GHC),$(TEST_FLAGS) tc005.hs -o2 tc005.stderr) +RunStdTest(tc006,$(GHC),$(TEST_FLAGS) tc006.hs -o2 tc006.stderr) +RunStdTest(tc007,$(GHC),$(TEST_FLAGS) tc007.hs -o2 tc007.stderr) +RunStdTest(tc008,$(GHC),$(TEST_FLAGS) tc008.hs -o2 tc008.stderr) +RunStdTest(tc009,$(GHC),$(TEST_FLAGS) tc009.hs -o2 tc009.stderr) + +RunStdTest(tc010,$(GHC),$(TEST_FLAGS) tc010.hs -o2 tc010.stderr) +RunStdTest(tc011,$(GHC),$(TEST_FLAGS) tc011.hs -o2 tc011.stderr) +RunStdTest(tc012,$(GHC),$(TEST_FLAGS) tc012.hs -o2 tc012.stderr) +RunStdTest(tc013,$(GHC),$(TEST_FLAGS) tc013.hs -o2 tc013.stderr) +RunStdTest(tc014,$(GHC),$(TEST_FLAGS) tc014.hs -o2 tc014.stderr) +RunStdTest(tc015,$(GHC),$(TEST_FLAGS) tc015.hs -o2 tc015.stderr) +RunStdTest(tc016,$(GHC),$(TEST_FLAGS) tc016.hs -o2 tc016.stderr) +RunStdTest(tc017,$(GHC),$(TEST_FLAGS) tc017.hs -o2 tc017.stderr) +RunStdTest(tc018,$(GHC),$(TEST_FLAGS) tc018.hs -o2 tc018.stderr) +RunStdTest(tc019,$(GHC),$(TEST_FLAGS) -fglasgow-exts tc019.hs -o2 tc019.stderr) + +RunStdTest(tc020,$(GHC),$(TEST_FLAGS) tc020.hs -o2 tc020.stderr) +RunStdTest(tc021,$(GHC),$(TEST_FLAGS) tc021.hs -o2 tc021.stderr) +RunStdTest(tc022,$(GHC),$(TEST_FLAGS) tc022.hs -o2 tc022.stderr) +RunStdTest(tc023,$(GHC),$(TEST_FLAGS) tc023.hs -o2 tc023.stderr) +RunStdTest(tc024,$(GHC),$(TEST_FLAGS) tc024.hs -o2 tc024.stderr) +RunStdTest(tc025,$(GHC),$(TEST_FLAGS) tc025.hs -o2 tc025.stderr) +RunStdTest(tc026,$(GHC),$(TEST_FLAGS) tc026.hs -o2 tc026.stderr) +RunStdTest(tc027,$(GHC),$(TEST_FLAGS) tc027.hs -o2 tc027.stderr) +RunStdTest(tc028,$(GHC),$(TEST_FLAGS) tc028.hs -o2 tc028.stderr) +RunStdTest(tc029,$(GHC),$(TEST_FLAGS) tc029.hs -o2 tc029.stderr) + +RunStdTest(tc030,$(GHC),$(TEST_FLAGS) tc030.hs -o2 tc030.stderr) +RunStdTest(tc031,$(GHC),$(TEST_FLAGS) tc031.hs -o2 tc031.stderr) +RunStdTest(tc032,$(GHC),$(TEST_FLAGS) tc032.hs -o2 tc032.stderr) +RunStdTest(tc033,$(GHC),$(TEST_FLAGS) tc033.hs -o2 tc033.stderr) +RunStdTest(tc034,$(GHC),$(TEST_FLAGS) tc034.hs -o2 tc034.stderr) +RunStdTest(tc035,$(GHC),$(TEST_FLAGS) tc035.hs -o2 tc035.stderr) +RunStdTest(tc036,$(GHC),$(TEST_FLAGS) tc036.hs -o2 tc036.stderr) +RunStdTest(tc037,$(GHC),$(TEST_FLAGS) tc037.hs -o2 tc037.stderr) +RunStdTest(tc038,$(GHC),$(TEST_FLAGS) tc038.hs -o2 tc038.stderr) +RunStdTest(tc039,$(GHC),$(TEST_FLAGS) tc039.hs -o2 tc039.stderr) + +RunStdTest(tc040,$(GHC),$(TEST_FLAGS) tc040.hs -o2 tc040.stderr) +RunStdTest(tc041,$(GHC),$(TEST_FLAGS) tc041.hs -o2 tc041.stderr) +RunStdTest(tc042,$(GHC),$(TEST_FLAGS) tc042.hs -o2 tc042.stderr) +RunStdTest(tc043,$(GHC),$(TEST_FLAGS) tc043.hs -o2 tc043.stderr) +RunStdTest(tc044,$(GHC),$(TEST_FLAGS) tc044.hs -o2 tc044.stderr) +RunStdTest(tc045,$(GHC),$(TEST_FLAGS) tc045.hs -o2 tc045.stderr) +RunStdTest(tc046,$(GHC),$(TEST_FLAGS) tc046.hs -o2 tc046.stderr) +RunStdTest(tc047,$(GHC),$(TEST_FLAGS) tc047.hs -o2 tc047.stderr) +RunStdTest(tc048,$(GHC),$(TEST_FLAGS) tc048.hs -o2 tc048.stderr) +RunStdTest(tc049,$(GHC),$(TEST_FLAGS) tc049.hs -o2 tc049.stderr) + +RunStdTest(tc050,$(GHC),$(TEST_FLAGS) tc050.hs -o2 tc050.stderr) +RunStdTest(tc051,$(GHC),$(TEST_FLAGS) tc051.hs -o2 tc051.stderr) +RunStdTest(tc052,$(GHC),$(TEST_FLAGS) tc052.hs -o2 tc052.stderr) +RunStdTest(tc053,$(GHC),$(TEST_FLAGS) tc053.hs -o2 tc053.stderr) +RunStdTest(tc054,$(GHC),$(TEST_FLAGS) tc054.hs -o2 tc054.stderr) +RunStdTest(tc055,$(GHC),$(TEST_FLAGS) tc055.hs -o2 tc055.stderr) +RunStdTest(tc056,$(GHC),$(TEST_FLAGS) tc056.hs -o2 tc056.stderr) +RunStdTest(tc057,$(GHC),$(TEST_FLAGS) tc057.hs -o2 tc057.stderr) +RunStdTest(tc058,$(GHC),$(TEST_FLAGS) tc058.hs -o2 tc058.stderr) +RunStdTest(tc059,$(GHC),$(TEST_FLAGS) tc059.hs -o2 tc059.stderr) + +RunStdTest(tc060,$(GHC),$(TEST_FLAGS) tc060.hs -o2 tc060.stderr) +RunStdTest(tc061,$(GHC),$(TEST_FLAGS) tc061.hs -o2 tc061.stderr) +RunStdTest(tc062,$(GHC),$(TEST_FLAGS) tc062.hs -o2 tc062.stderr) +RunStdTest(tc063,$(GHC),$(TEST_FLAGS) tc063.hs -o2 tc063.stderr) +RunStdTest(tc064,$(GHC),$(TEST_FLAGS) tc064.hs -o2 tc064.stderr) +RunStdTest(tc065,$(GHC),$(TEST_FLAGS) tc065.hs -o2 tc065.stderr) +RunStdTest(tc066,$(GHC),$(TEST_FLAGS) tc066.hs -o2 tc066.stderr) +RunStdTest(tc067,$(GHC),$(TEST_FLAGS) tc067.hs -o2 tc067.stderr) +RunStdTest(tc068,$(GHC),$(TEST_FLAGS) tc068.hs -o2 tc068.stderr) +RunStdTest(tc069,$(GHC),$(TEST_FLAGS) tc069.hs -o2 tc069.stderr) + +RunStdTest(tc070,$(GHC),$(TEST_FLAGS) tc070.hs -o2 tc070.stderr) +RunStdTest(tc073,$(GHC),$(TEST_FLAGS) tc073.hs -o2 tc073.stderr) +RunStdTest(tc074,$(GHC),$(TEST_FLAGS) tc074.hs -o2 tc074.stderr) +RunStdTest(tc075,$(GHC),$(TEST_FLAGS) tc075.hs -o2 tc075.stderr) +RunStdTest(tc076,$(GHC),$(TEST_FLAGS) tc076.hs -o2 tc076.stderr) +RunStdTest(tc077,$(GHC),$(TEST_FLAGS) tc077.hs -o2 tc077.stderr) +RunStdTest(tc078,$(GHC),$(TEST_FLAGS) tc078.hs -o2 tc078.stderr) +RunStdTest(tc079,$(GHC),$(TEST_FLAGS) tc079.hs -o2 tc079.stderr) + +RunStdTest(tc080,$(GHC),$(TEST_FLAGS) tc080.hs -o2 tc080.stderr) +RunStdTest(tc081,$(GHC),$(TEST_FLAGS) tc081.hs -o2 tc081.stderr) +RunStdTest(tc082,$(GHC),$(TEST_FLAGS) tc082.hs -o2 tc082.stderr) +RunStdTest(tc083,$(GHC),$(TEST_FLAGS) tc083.hs -o2 tc083.stderr) +RunStdTest(tc084,$(GHC),$(TEST_FLAGS) tc084.hs -o2 tc084.stderr) +RunStdTest(tc085,$(GHC),$(TEST_FLAGS) tc085.hs -o2 tc085.stderr) diff --git a/ghc/compiler/tests/typecheck/should_succeed/M.hi b/ghc/compiler/tests/typecheck/should_succeed/M.hi new file mode 100644 index 0000000..ffb4e0c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/M.hi @@ -0,0 +1,4 @@ +interface M where +class (ORD a, Text a) => EQ a where (===) :: a -> a -> Bool +class (Num a) => ORD a +data NUM = ONE | TWO diff --git a/ghc/compiler/tests/typecheck/should_succeed/ShouldSucceed.hi b/ghc/compiler/tests/typecheck/should_succeed/ShouldSucceed.hi new file mode 100644 index 0000000..3ea8fd3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/ShouldSucceed.hi @@ -0,0 +1,7 @@ +interface ShouldSucceed where { +{- TCE -} +{- CE -} +{- LVE -} +a :: Num t64 => t64 -> t64 +{- GIEinst -} +} diff --git a/ghc/compiler/tests/typecheck/should_succeed/TheUtils.hi b/ghc/compiler/tests/typecheck/should_succeed/TheUtils.hi new file mode 100644 index 0000000..6ce638b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/TheUtils.hi @@ -0,0 +1,33 @@ +interface TheUtils where +import Maybes(Labda) +import Pretty(PrettyRep) +let_1_0 :: a -> (a -> b) -> b {-# ARITY let_1_0 = 2 #-}{-# STRICTNESS let_1_0 = "T,F" ST #-} +assoc :: (Eq a) => a -> [(a, b)] -> String -> b {-# ARITY assoc = 4 #-}{-# STRICTNESS assoc = "2,F" ST #-} +assocWithDefault :: (Eq a) => [(a, b)] -> b -> a -> (b, Bool) {-# ARITY assocWithDefault = 4 #-}{-# STRICTNESS assocWithDefault = "1,F" ST #-} +cfst :: a -> b -> a {-# ARITY cfst = 2 #-}{-# STRICTNESS cfst = "0,0" ST #-} +hasNoDups :: (Eq a) => [a] -> Bool {-# ARITY hasNoDups = 2 #-}{-# STRICTNESS hasNoDups = "1,F" ST #-} +mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) {-# ARITY mapAccumL = 3 #-}{-# STRICTNESS mapAccumL = "2,F" ST #-} +mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) {-# ARITY mapAccumR = 3 #-}{-# STRICTNESS mapAccumR = "2,F" ST #-} +map2 :: (a -> b -> c) -> [a] -> [b] -> [c] {-# ARITY map2 = 3 #-}{-# STRICTNESS map2 = "1,F" ST #-} +map3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] {-# ARITY map3 = 4 #-}{-# STRICTNESS map3 = "1,F" ST #-} +applyToPair :: (a -> b, c -> d) -> (a, c) -> (b, d) {-# ARITY applyToPair = 2 #-}{-# STRICTNESS applyToPair = "0&1,F" ST #-} +applyToFst :: (a -> b) -> (a, c) -> (b, c) {-# ARITY applyToFst = 2 #-}{-# STRICTNESS applyToFst = "1,F" ST #-} +applyToSnd :: (a -> b) -> (c, a) -> (c, b) {-# ARITY applyToSnd = 2 #-}{-# STRICTNESS applyToSnd = "1,F" ST #-} +foldPair :: (a -> a -> a, b -> b -> b) -> (a, b) -> [(a, b)] -> (a, b) {-# ARITY foldPair = 3 #-}{-# STRICTNESS foldPair = "(0|1)&2,F" ST #-} +clookup :: (Eq a) => [a] -> [b] -> a -> b {-# ARITY clookup = 1 #-}{-# STRICTNESS clookup = "T,F" ST #-} +clookupElse :: (Eq b) => a -> [b] -> [a] -> b -> a {-# ARITY clookupElse = 5 #-}{-# STRICTNESS clookupElse = "2,F" ST #-} +clookrepl :: (Eq a) => [a] -> [b] -> a -> (b -> b) -> [b] {-# ARITY clookrepl = 5 #-}{-# STRICTNESS clookrepl = "1,F" ST #-} +forall :: (a -> Bool) -> [a] -> Bool {-# ARITY forall = 2 #-}{-# STRICTNESS forall = "1,F" ST #-} +exists :: (a -> Bool) -> [a] -> Bool {-# ARITY exists = 2 #-}{-# STRICTNESS exists = "1,F" ST #-} +elemIndex :: (Eq a) => [a] -> a -> Int {-# ARITY elemIndex = 3 #-}{-# STRICTNESS elemIndex = "1,F" ST #-} +(\\\) :: (Eq a) => [a] -> [a] -> [a] {-# ARITY (\\\) = 1 #-}{-# STRICTNESS (\\\) = "T,F" ST #-} +nOfThem :: Int -> a -> [a] {-# ARITY nOfThem = 2 #-}{-# STRICTNESS nOfThem = "T,F" ST #-} +panic :: [Char] -> a {-# ARITY panic = 1 #-}{-# STRICTNESS panic = "T,F" ST #-} +pprPanic :: (Int -> Bool -> PrettyRep) -> a {-# ARITY pprPanic = 1 #-}{-# STRICTNESS pprPanic = "T,F" ST #-} +quicksort :: (a -> a -> Bool) -> [a] -> [a] {-# ARITY quicksort = 2 #-}{-# STRICTNESS quicksort = "1,F" ST #-} +runs :: (a -> a -> Bool) -> [a] -> [[a]] {-# ARITY runs = 2 #-}{-# STRICTNESS runs = "1,F" ST #-} +intLength :: [a] -> Int {-# ARITY intLength = 1 #-}{-# STRICTNESS intLength = "0,F" ST #-} +lengthExceeds :: [a] -> Int -> Bool {-# ARITY lengthExceeds = 2 #-}{-# STRICTNESS lengthExceeds = "0&1,F" ST #-} + +data Labda a +data PrettyRep diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc001.hs b/ghc/compiler/tests/typecheck/should_succeed/tc001.hs new file mode 100644 index 0000000..c3b0a78 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc001.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +a x = y+2 where y = x+3 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc001.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc001.stderr new file mode 100644 index 0000000..80519a2 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc001.stderr @@ -0,0 +1,19 @@ +Typechecked: +AbsBinds [tt12] [d.Num.t16] [(a.t1, ShouldSucceed.a)] + (fromInt.t15, fromInt tt12 d.Num.t16) + (lit.t8, fromInt.t15 (MkInt 3#)) + (d.Num.t17, d.Num.t16) + (+.t6, (+) tt12 d.Num.t17) + (fromInt.t18, fromInt.t15) + (lit.t13, fromInt.t18 (MkInt 2#)) + (+.t11, (+.t6)) + {- nonrec -} + a.t1 :: tt12 -> tt12 + a.t1 x.r54 = y.r55 +.t11 lit.t13 + where + AbsBinds [] [] [(y.t4, y.r55)] + {- nonrec -} + y.t4 :: tt12 + y.t4 = x.r54 +.t6 lit.t8 + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc002.hs b/ghc/compiler/tests/typecheck/should_succeed/tc002.hs new file mode 100644 index 0000000..fbe2cd5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc002.hs @@ -0,0 +1 @@ +b = if True then 1 else 2 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc002.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc002.stderr new file mode 100644 index 0000000..75f416d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc002.stderr @@ -0,0 +1,11 @@ +Typechecked: +d.Num.t7 = dfun.Num.Integer +fromInt.t6 = fromInt tt4 d.Num.t7 +lit.t5 = fromInt.t6 (MkInt 2#) +fromInt.t8 = fromInt.t6 +lit.t3 = fromInt.t8 (MkInt 1#) +AbsBinds [] [] [(b.t1, Main.b)] + {- nonrec -} + b.t1 :: tt4 + b.t1 = if True then lit.t3 else lit.t5 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc003.hs b/ghc/compiler/tests/typecheck/should_succeed/tc003.hs new file mode 100644 index 0000000..70459c3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc003.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +-- This is a somewhat surprising program. +-- It shows up the monomorphism restriction, *and* ambiguity resolution! +-- The binding is a pattern binding without a signature, so it is monomorphic. +-- Hence the types of c,d,e are not universally quantified. But then +-- their type variables are ambiguous, so the ambiguity resolution leaps +-- into action, and resolves them to Integer. + +-- That's why we check the interface file in the test suite. + +(c@(d,e)) = if True then (1,2) else (1,3) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc003.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc003.stderr new file mode 100644 index 0000000..9bdced1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc003.stderr @@ -0,0 +1,25 @@ +Typechecked: +d.Num.t19 = dfun.Num.Integer +d.Num.t17 = dfun.Num.Integer +fromInt.t16 = fromInt tt14 d.Num.t17 +lit.t15 = fromInt.t16 (MkInt 3#) +fromInt.t18 = fromInt tt12 d.Num.t19 +lit.t13 = fromInt.t18 (MkInt 1#) +fromInt.t20 = fromInt.t16 +lit.t11 = fromInt.t20 (MkInt 2#) +lit.t9 = lit.t13 +AbsBinds +[] +[] +[(c.t3, ShouldSucceed.c), (d.t4, ShouldSucceed.d), (e.t5, ShouldSucceed.e)] + {- nonrec -} + (c.t3@(d.t4, e.t5)) :: (tt12, tt14) + (c.t3@(d.t4, e.t5)) = if True then (lit.t9, lit.t11) else (lit.t13, lit.t15) + +=-=-=-=-=INTERFACE STARTS HERE=-=-=-=-= ShouldSucceed +interface ShouldSucceed where +c :: (tt12, tt14) {-# ARITY _ = 0 #-} +d :: tt12 {-# ARITY _ = 0 #-} +e :: tt14 {-# ARITY _ = 0 #-} +=-=-=-=-=INTERFACE STOPS HERE=-=-=-=-= + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc004.hs b/ghc/compiler/tests/typecheck/should_succeed/tc004.hs new file mode 100644 index 0000000..a062730 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc004.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +f x = case x of + True -> True + False -> x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc004.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc004.stderr new file mode 100644 index 0000000..2caff64 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc004.stderr @@ -0,0 +1,8 @@ +Typechecked: +AbsBinds [] [] [(f.t1, ShouldSucceed.f)] + {- nonrec -} + f.t1 :: Bool -> Bool + f.t1 x.r54 = case x.r54 of + True -> True + False -> x.r54 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc005.hs b/ghc/compiler/tests/typecheck/should_succeed/tc005.hs new file mode 100644 index 0000000..9d39da8 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc005.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +g ((x:z),y) = x +g (x,y) = 2 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc005.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc005.stderr new file mode 100644 index 0000000..13046bc --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc005.stderr @@ -0,0 +1,11 @@ +Typechecked: +AbsBinds [tt11, tt12] [d.Num.t15] [(g.t1, ShouldSucceed.g)] + (fromInt.t14, fromInt tt12 d.Num.t15) + (lit.t13, fromInt.t14 (MkInt 2#)) + {- nonrec -} + g.t1 :: ([tt12], tt11) -> tt12 + g.t1 ((x.r54 : z.r56), y.r55) + = x.r54 + g.t1 (x.r57, y.r58) + = lit.t13 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc006.hs b/ghc/compiler/tests/typecheck/should_succeed/tc006.hs new file mode 100644 index 0000000..2a22688 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc006.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +h = 1:h diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc006.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc006.stderr new file mode 100644 index 0000000..97ba6d7 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc006.stderr @@ -0,0 +1,9 @@ +Typechecked: +d.Num.t7 = dfun.Num.Integer +fromInt.t6 = fromInt tt3 d.Num.t7 +lit.t4 = fromInt.t6 (MkInt 1#) +AbsBinds [] [] [(h.t1, ShouldSucceed.h)] + {- rec -} + h.t1 :: [tt3] + h.t1 = ((:) tt3) lit.t4 h.t1 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc007.hs b/ghc/compiler/tests/typecheck/should_succeed/tc007.hs new file mode 100644 index 0000000..c654585 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc007.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +j = 2 + +k = 1:j:l + +l = 0:k + +m = j+j diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc007.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc007.stderr new file mode 100644 index 0000000..4563532 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc007.stderr @@ -0,0 +1,26 @@ +Typechecked: +d.Num.t24 = dfun.Num.Integer +d.Num.t26 = dfun.Num.Integer +fromInt.t23 = fromInt tt2 d.Num.t24 +lit.t3 = fromInt.t23 (MkInt 2#) +fromInt.t25 = fromInt tt15 d.Num.t26 +lit.t10 = fromInt.t25 (MkInt 1#) +fromInt.t27 = fromInt.t25 +lit.t16 = fromInt.t27 (MkInt 0#) +d.Num.t28 = d.Num.t24 +(+.t21) = (+) tt2 d.Num.t28 +AbsBinds [] [] [(j.t1, ShouldSucceed.j)] + {- nonrec -} + j.t1 :: tt2 + j.t1 = lit.t3 +AbsBinds [] [] [(k.t6, ShouldSucceed.k), (l.t7, ShouldSucceed.l)] + {- rec -} + k.t6 :: [tt15] + k.t6 = ((:) tt15) lit.t10 (((:) tt15) ShouldSucceed.j l.t7) + l.t7 :: [tt15] + l.t7 = ((:) tt15) lit.t16 k.t6 +AbsBinds [] [] [(m.t19, ShouldSucceed.m)] + {- nonrec -} + m.t19 :: tt2 + m.t19 = ShouldSucceed.j +.t21 ShouldSucceed.j + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc008.hs b/ghc/compiler/tests/typecheck/should_succeed/tc008.hs new file mode 100644 index 0000000..236b575 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc008.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +n True = 1 +n False = 0 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc008.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc008.stderr new file mode 100644 index 0000000..a70264d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc008.stderr @@ -0,0 +1,11 @@ +Typechecked: +AbsBinds [tt4] [d.Num.t7] [(n.t1, ShouldSucceed.n)] + (fromInt.t6, fromInt tt4 d.Num.t7) + (lit.t3, fromInt.t6 (MkInt 1#)) + (fromInt.t8, fromInt.t6) + (lit.t5, fromInt.t8 (MkInt 0#)) + {- nonrec -} + n.t1 :: Bool -> tt4 + n.t1 True = lit.t3 + n.t1 False = lit.t5 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc009.hs b/ghc/compiler/tests/typecheck/should_succeed/tc009.hs new file mode 100644 index 0000000..b682a94 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc009.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +o (True,x) = x +o (False,y) = y+1 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc009.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc009.stderr new file mode 100644 index 0000000..0b70e78 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc009.stderr @@ -0,0 +1,13 @@ +Typechecked: +AbsBinds [tt10] [d.Num.t14] [(o.t1, ShouldSucceed.o)] + (fromInt.t13, fromInt tt10 d.Num.t14) + (lit.t11, fromInt.t13 (MkInt 1#)) + (d.Num.t15, d.Num.t14) + (+.t9, (+) tt10 d.Num.t15) + {- nonrec -} + o.t1 :: (Bool, tt10) -> tt10 + o.t1 (True, x.r54) + = x.r54 + o.t1 (False, y.r55) + = y.r55 +.t9 lit.t11 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc010.hs b/ghc/compiler/tests/typecheck/should_succeed/tc010.hs new file mode 100644 index 0000000..8ec9afd --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc010.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +p = [(y+2,True) | y <- [1,2]] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc010.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc010.stderr new file mode 100644 index 0000000..96d1942 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc010.stderr @@ -0,0 +1,14 @@ +Typechecked: +d.Num.t13 = dfun.Num.Integer +fromInt.t12 = fromInt tt9 d.Num.t13 +lit.t10 = fromInt.t12 (MkInt 2#) +d.Num.t14 = d.Num.t13 +(+.t8) = (+) tt9 d.Num.t14 +lit.t6 = lit.t10 +fromInt.t15 = fromInt.t12 +lit.t4 = fromInt.t15 (MkInt 1#) +AbsBinds [] [] [(p.t1, ShouldSucceed.p)] + {- nonrec -} + p.t1 :: [(tt9, Bool)] + p.t1 = [ (y.r54 +.t8 lit.t10, True) | y.r54 <- [lit.t4, lit.t6] (tt9) ] + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc011.hs b/ghc/compiler/tests/typecheck/should_succeed/tc011.hs new file mode 100644 index 0000000..24c5b3b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc011.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +x@_ = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc011.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc011.stderr new file mode 100644 index 0000000..20dc687 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc011.stderr @@ -0,0 +1,6 @@ +Typechecked: +AbsBinds [tt0] [] [(x.t1, ShouldSucceed.x)] + {- rec -} + (x.t1@_) :: tt0 + (x.t1@_) = x.t1 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc012.hs b/ghc/compiler/tests/typecheck/should_succeed/tc012.hs new file mode 100644 index 0000000..6f5e954 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc012.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +q = \ y -> y diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc012.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc012.stderr new file mode 100644 index 0000000..2839d82 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc012.stderr @@ -0,0 +1,6 @@ +Typechecked: +AbsBinds [ot2] [] [(q.t1, ShouldSucceed.q)] + {- nonrec -} + q.t1 :: ot2 -> ot2 + q.t1 = \ y.r54 -> y.r54 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc013.hs b/ghc/compiler/tests/typecheck/should_succeed/tc013.hs new file mode 100644 index 0000000..f6a08b5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc013.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +(r,s) = (1,'a') diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc013.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc013.stderr new file mode 100644 index 0000000..a6601db --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc013.stderr @@ -0,0 +1,9 @@ +Typechecked: +d.Num.t9 = dfun.Num.Integer +fromInt.t8 = fromInt tt6 d.Num.t9 +lit.t7 = fromInt.t8 (MkInt 1#) +AbsBinds [] [] [(r.t2, ShouldSucceed.r), (s.t3, ShouldSucceed.s)] + {- nonrec -} + (r.t2, s.t3) :: (tt6, Char) + (r.t2, s.t3) = (lit.t7, 'a') + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc014.hs b/ghc/compiler/tests/typecheck/should_succeed/tc014.hs new file mode 100644 index 0000000..97ce375 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc014.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +t = 1+t diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc014.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc014.stderr new file mode 100644 index 0000000..1f09007 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc014.stderr @@ -0,0 +1,11 @@ +Typechecked: +d.Num.t8 = dfun.Num.Integer +fromInt.t7 = fromInt tt0 d.Num.t8 +lit.t5 = fromInt.t7 (MkInt 1#) +d.Num.t9 = d.Num.t8 +(+.t3) = (+) tt0 d.Num.t9 +AbsBinds [] [] [(t.t1, ShouldSucceed.t)] + {- rec -} + t.t1 :: tt0 + t.t1 = lit.t5 +.t3 t.t1 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc015.hs b/ghc/compiler/tests/typecheck/should_succeed/tc015.hs new file mode 100644 index 0000000..41c902b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc015.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +u x = \ (y,z) -> x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc015.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc015.stderr new file mode 100644 index 0000000..ac3d312 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc015.stderr @@ -0,0 +1,7 @@ +Typechecked: +AbsBinds [tt5, tt6, ot2] [] [(u.t1, ShouldSucceed.u)] + {- nonrec -} + u.t1 :: ot2 -> (tt5, tt6) -> ot2 + u.t1 x.r54 = \ (y.r55, z.r56) + -> x.r54 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc016.hs b/ghc/compiler/tests/typecheck/should_succeed/tc016.hs new file mode 100644 index 0000000..5f3c7e5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc016.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +f x@_ y@_ = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc016.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc016.stderr new file mode 100644 index 0000000..6aabab9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc016.stderr @@ -0,0 +1,7 @@ +Typechecked: +AbsBinds [ot5, ot3] [] [(f.t1, ShouldSucceed.f)] + {- nonrec -} + f.t1 :: ot3 -> ot5 -> ot3 + f.t1 (x.r54@_) (y.r55@_) + = x.r54 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc017.hs b/ghc/compiler/tests/typecheck/should_succeed/tc017.hs new file mode 100644 index 0000000..ec51aeb --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc017.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +v | True = v+1 + | False = v diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc017.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc017.stderr new file mode 100644 index 0000000..5bee79e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc017.stderr @@ -0,0 +1,12 @@ +Typechecked: +d.Num.t8 = dfun.Num.Integer +fromInt.t7 = fromInt tt4 d.Num.t8 +lit.t5 = fromInt.t7 (MkInt 1#) +d.Num.t9 = d.Num.t8 +(+.t3) = (+) tt4 d.Num.t9 +AbsBinds [] [] [(v.t1, ShouldSucceed.v)] + {- rec -} + v.t1 :: tt4 + v.t1 | True = v.t1 +.t3 lit.t5 + | False = v.t1 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc018.hs b/ghc/compiler/tests/typecheck/should_succeed/tc018.hs new file mode 100644 index 0000000..7fb398c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc018.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +w = a where a = y + y = 2 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc018.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc018.stderr new file mode 100644 index 0000000..5a7b1b5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc018.stderr @@ -0,0 +1,20 @@ +Typechecked: +d.Num.t9 = dfun.Num.Integer +fromInt.t8 = fromInt tt4 d.Num.t9 +lit.t5 = fromInt.t8 (MkInt 2#) +AbsBinds [] [] [(w.t1, ShouldSucceed.w)] + {- nonrec -} + w.t1 :: tt4 + w.t1 = a.r54 + where + AbsBinds [] [] [(y.t3, y.r55)] + {- nonrec -} + y.t3 :: tt4 + y.t3 = lit.t5 + {- nonrec -} + AbsBinds [] [] [(a.t7, a.r54)] + {- nonrec -} + a.t7 :: tt4 + a.t7 = y.r55 + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc019.hs b/ghc/compiler/tests/typecheck/should_succeed/tc019.hs new file mode 100644 index 0000000..3cfe5ea --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc019.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +(al:am) = [y+1 | (y,z) <- [(1,2)]] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc019.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc019.stderr new file mode 100644 index 0000000..0d4c241 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc019.stderr @@ -0,0 +1,17 @@ +Typechecked: +d.Num.t19 = dfun.Num.Integer +d.Num.t22 = dfun.Num.Integer +fromInt.t18 = fromInt tt4 d.Num.t19 +lit.t16 = fromInt.t18 (MkInt 1#) +d.Num.t20 = d.Num.t19 +(+.t14) = (+) tt4 d.Num.t20 +fromInt.t21 = fromInt tt6 d.Num.t22 +lit.t12 = fromInt.t21 (MkInt 2#) +lit.t10 = lit.t16 +AbsBinds [] [] [(al.t2, ShouldSucceed.al), (am.t3, ShouldSucceed.am)] + {- nonrec -} + (al.t2 : am.t3) :: [tt4] + (al.t2 : am.t3) + = [ y.r55 +.t14 lit.t16 | + (y.r55, z.r56) <- [(lit.t10, lit.t12)] ((tt4, tt6)) ] + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc020.hs b/ghc/compiler/tests/typecheck/should_succeed/tc020.hs new file mode 100644 index 0000000..a0ef679 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc020.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +f x = a where a = x:a diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc020.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc020.stderr new file mode 100644 index 0000000..07140e3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc020.stderr @@ -0,0 +1,12 @@ +Typechecked: +AbsBinds [tt5] [] [(f.t1, ShouldSucceed.f)] + {- nonrec -} + f.t1 :: tt5 -> [tt5] + f.t1 x.r54 = a.r55 + where + AbsBinds [] [] [(a.t4, a.r55)] + {- rec -} + a.t4 :: [tt5] + a.t4 = ((:) tt5) x.r54 a.t4 + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc021.hs b/ghc/compiler/tests/typecheck/should_succeed/tc021.hs new file mode 100644 index 0000000..418fa38 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc021.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +f x = a + +a = (x,x) + +x = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc021.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc021.stderr new file mode 100644 index 0000000..b17bfdb --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc021.stderr @@ -0,0 +1,14 @@ +Typechecked: +AbsBinds [tt0] [] [(x.t1, ShouldSucceed.x)] + {- rec -} + x.t1 :: tt0 + x.t1 = x.t1 +AbsBinds [tt4, tt5] [] [(a.t3, ShouldSucceed.a)] + {- nonrec -} + a.t3 :: (tt4, tt5) + a.t3 = (ShouldSucceed.x tt4, ShouldSucceed.x tt5) +AbsBinds [ot8, tt9, tt10] [] [(f.t7, ShouldSucceed.f)] + {- nonrec -} + f.t7 :: ot8 -> (tt9, tt10) + f.t7 x.r56 = ShouldSucceed.a [tt9, tt10] + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc022.hs b/ghc/compiler/tests/typecheck/should_succeed/tc022.hs new file mode 100644 index 0000000..1a04d7e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc022.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +main = iD iD + +iD x = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc022.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc022.stderr new file mode 100644 index 0000000..de7d571 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc022.stderr @@ -0,0 +1,11 @@ +Typechecked: +AbsBinds [ot2] [] [(id.t1, ShouldSucceed.id)] + {- nonrec -} + id.t1 :: ot2 -> ot2 + id.t1 + x.r55 = x.r55 +AbsBinds [tt6] [] [(main.t4, ShouldSucceed.main)] + {- nonrec -} + main.t4 :: tt6 -> tt6 + main.t4 = (ShouldSucceed.id (tt6 -> tt6)) (ShouldSucceed.id tt6) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc023.hs b/ghc/compiler/tests/typecheck/should_succeed/tc023.hs new file mode 100644 index 0000000..b996719 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc023.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +main = s k k + +s f g x = f x (g x) + +k x y = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc023.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc023.stderr new file mode 100644 index 0000000..5ca71ff --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc023.stderr @@ -0,0 +1,19 @@ +Typechecked: +AbsBinds [ot6, ot4, ot5] [] [(s.t1, ShouldSucceed.s)] + {- nonrec -} + s.t1 :: (ot4 -> ot6 -> ot5) -> (ot4 -> ot6) -> ot4 -> ot5 + s.t1 f.r56 g.r57 x.r58 + = f.r56 x.r58 (g.r57 x.r58) +AbsBinds [ot10, ot9] [] [(k.t8, ShouldSucceed.k)] + {- nonrec -} + k.t8 :: ot9 -> ot10 -> ot9 + k.t8 x.r59 y.r60 + = x.r59 +AbsBinds [tt19] [] [(main.t12, ShouldSucceed.main)] + {- nonrec -} + main.t12 :: tt19 -> tt19 + main.t12 + = (ShouldSucceed.s [tt18 -> tt19, tt19, tt19]) + (ShouldSucceed.k [tt18 -> tt19, tt19]) + (ShouldSucceed.k [tt18, tt19]) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc024.hs b/ghc/compiler/tests/typecheck/should_succeed/tc024.hs new file mode 100644 index 0000000..e28d1ac --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc024.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +main x = s k k x + +s f g x = f x (g x) + +k x y = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc024.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc024.stderr new file mode 100644 index 0000000..84cf357 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc024.stderr @@ -0,0 +1,20 @@ +Typechecked: +AbsBinds [ot6, ot4, ot5] [] [(s.t1, ShouldSucceed.s)] + {- nonrec -} + s.t1 :: (ot4 -> ot6 -> ot5) -> (ot4 -> ot6) -> ot4 -> ot5 + s.t1 f.r57 g.r58 x.r59 + = f.r57 x.r59 (g.r58 x.r59) +AbsBinds [ot10, ot9] [] [(k.t8, ShouldSucceed.k)] + {- nonrec -} + k.t8 :: ot9 -> ot10 -> ot9 + k.t8 x.r60 y.r61 + = x.r60 +AbsBinds [tt20] [] [(main.t12, ShouldSucceed.main)] + {- nonrec -} + main.t12 :: tt20 -> tt20 + main.t12 + x.r56 = (ShouldSucceed.s [tt19 -> tt20, tt20, tt20]) + (ShouldSucceed.k [tt19 -> tt20, tt20]) + (ShouldSucceed.k [tt19, tt20]) + x.r56 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc025.hs b/ghc/compiler/tests/typecheck/should_succeed/tc025.hs new file mode 100644 index 0000000..e9adf9a --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc025.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +g x = f (f True x) x where f x y = if x then y else (f x y) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc025.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc025.stderr new file mode 100644 index 0000000..0cdf21d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc025.stderr @@ -0,0 +1,13 @@ +Typechecked: +AbsBinds [] [] [(g.t1, ShouldSucceed.g)] + {- nonrec -} + g.t1 :: Bool -> Bool + g.t1 x.r54 = (f.r55 Bool) ((f.r55 Bool) True x.r54) x.r54 + where + AbsBinds [ot7] [] [(f.t4, f.r55)] + {- rec -} + f.t4 :: Bool -> ot7 -> ot7 + f.t4 x.r56 y.r57 + = if x.r56 then y.r57 else f.t4 x.r56 y.r57 + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc026.hs b/ghc/compiler/tests/typecheck/should_succeed/tc026.hs new file mode 100644 index 0000000..3e718a5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc026.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +g x = f (f True x) x +f x y = if x then y else (f x y) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc026.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc026.stderr new file mode 100644 index 0000000..6d04690 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc026.stderr @@ -0,0 +1,12 @@ +Typechecked: +AbsBinds [ot4] [] [(f.t1, ShouldSucceed.f)] + {- rec -} + f.t1 :: Bool -> ot4 -> ot4 + f.t1 x.r56 y.r57 + = if x.r56 then y.r57 else f.t1 x.r56 y.r57 +AbsBinds [] [] [(g.t6, ShouldSucceed.g)] + {- nonrec -} + g.t6 :: Bool -> Bool + g.t6 x.r55 = (ShouldSucceed.f Bool) + ((ShouldSucceed.f Bool) True x.r55) x.r55 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc027.hs b/ghc/compiler/tests/typecheck/should_succeed/tc027.hs new file mode 100644 index 0000000..6edc01b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc027.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +h x = f (f True x) x +f x y = if x then y else (g y x) +g y x = if x then y else (f x y) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc027.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc027.stderr new file mode 100644 index 0000000..d202a07 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc027.stderr @@ -0,0 +1,15 @@ +Typechecked: +AbsBinds [ot9] [] [(f.t2, ShouldSucceed.f), (g.t3, ShouldSucceed.g)] + {- rec -} + f.t2 :: Bool -> ot9 -> ot9 + f.t2 x.r57 y.r58 + = if x.r57 then y.r58 else g.t3 y.r58 x.r57 + g.t3 :: ot9 -> Bool -> ot9 + g.t3 y.r60 x.r59 + = if x.r59 then y.r60 else f.t2 x.r59 y.r60 +AbsBinds [] [] [(h.t11, ShouldSucceed.h)] + {- nonrec -} + h.t11 :: Bool -> Bool + h.t11 + x.r56 = (ShouldSucceed.f Bool) ((ShouldSucceed.f Bool) True x.r56) x.r56 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc028.hs b/ghc/compiler/tests/typecheck/should_succeed/tc028.hs new file mode 100644 index 0000000..49a0835 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc028.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +type H = (Int,Bool) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc028.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc028.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc028.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc029.hs b/ghc/compiler/tests/typecheck/should_succeed/tc029.hs new file mode 100644 index 0000000..c44b78f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc029.hs @@ -0,0 +1,6 @@ +module ShouldSucceed where + +type G = [Int] + +data K = H Bool | M G + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc029.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc029.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc029.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc030.hs b/ghc/compiler/tests/typecheck/should_succeed/tc030.hs new file mode 100644 index 0000000..004bc22 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc030.hs @@ -0,0 +1,5 @@ +module ShouldSucceed where + +type H = [Bool] + +type G = (H,Char) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc030.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc030.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc030.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc031.hs b/ghc/compiler/tests/typecheck/should_succeed/tc031.hs new file mode 100644 index 0000000..c55bf11 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc031.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +data Rec = Node Int Rec diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc031.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc031.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc031.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc032.hs b/ghc/compiler/tests/typecheck/should_succeed/tc032.hs new file mode 100644 index 0000000..9c43bbb --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc032.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +data AList b = Node b [b] | Other (b,Char) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc032.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc032.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc032.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc033.hs b/ghc/compiler/tests/typecheck/should_succeed/tc033.hs new file mode 100644 index 0000000..7111d75 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc033.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +data Twine = Twine2 Twist + +data Twist = Twist2 Twine + +type F = Twine diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc033.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc033.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc033.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc034.hs b/ghc/compiler/tests/typecheck/should_succeed/tc034.hs new file mode 100644 index 0000000..0e7c4a6 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc034.hs @@ -0,0 +1,11 @@ +module ShouldSucceed where + +data AList a = ANull | ANode a (AList a) + +type IntList = AList Int + +g (ANull) = 2 +g (ANode b (ANode c d)) | b = 3 + | True = 4 + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc034.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc034.stderr new file mode 100644 index 0000000..88eac08 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc034.stderr @@ -0,0 +1,16 @@ +Typechecked: +AbsBinds [tt12] [d.Num.t15] [(g.t1, ShouldSucceed.g)] + (fromInt.t14, fromInt tt12 d.Num.t15) + (lit.t4, fromInt.t14 (MkInt 2#)) + (fromInt.t16, fromInt.t14) + (lit.t13, fromInt.t16 (MkInt 4#)) + (fromInt.t17, fromInt.t16) + (lit.t11, fromInt.t17 (MkInt 3#)) + {- nonrec -} + g.t1 :: ShouldSucceed.AList Bool -> tt12 + g.t1 ShouldSucceed.ANull + = lit.t4 + g.t1 (ShouldSucceed.ANode b.r59 (ShouldSucceed.ANode c.r60 d.r61)) + | b.r59 = lit.t11 + | True = lit.t13 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc035.hs b/ghc/compiler/tests/typecheck/should_succeed/tc035.hs new file mode 100644 index 0000000..b8dd554 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc035.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +type AnnExpr a = (a,Expr a) + +data Expr a = Var [Char] + | App (AnnExpr a) (AnnExpr a) + +g (a,(Var name)) = [name] +g (a,(App e1 e2)) = (g e1) ++ (g e2) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc035.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc035.stderr new file mode 100644 index 0000000..677e2a1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc035.stderr @@ -0,0 +1,9 @@ +Typechecked: +AbsBinds [a.t10] [] [(g.t1, ShouldSucceed.g)] + {- rec -} + g.t1 :: ShouldSucceed.AnnExpr a.t10 -> [[Char]] + g.t1 (a.r60, (ShouldSucceed.Var name.r61)) + = [name.r61] ([Char]) + g.t1 (a.r62, (ShouldSucceed.App e1.r63 e2.r64)) + = ((++) [Char]) (g.t1 e1.r63) (g.t1 e2.r64) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc036.hs b/ghc/compiler/tests/typecheck/should_succeed/tc036.hs new file mode 100644 index 0000000..05b8784 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc036.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +class (Eq a) => A a where + op1 :: a -> a diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc036.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc036.stderr new file mode 100644 index 0000000..1cd9d23 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc036.stderr @@ -0,0 +1,12 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.A.op1 = /\ a.t0 -> \{-classdict-} [d.Eq.t2] [op1.t1] -> op1.t1 +sdsel.ShouldSucceed.A.Eq = + /\ a.t0 -> \{-classdict-} [d.Eq.t2] [op1.t1] -> d.Eq.t2 +{- nonrec -} +defm.ShouldSucceed.A.op1 = + /\ a.t3 -> + \{-dict-} d.ShouldSucceed.A.t4 -> + (error (a.t3 -> a.t3)) + "No default method for \"ShouldSucceed.A.defm.ShouldSucceed.A.op1\"\n" + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc037.hi b/ghc/compiler/tests/typecheck/should_succeed/tc037.hi new file mode 100644 index 0000000..026e6c2 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc037.hi @@ -0,0 +1,6 @@ +interface ShouldSucceed where { +class Eq' a where { + deq :: a -> a -> Bool + }; +instance (Eq' a) => Eq' [a] {-# FROMMODULE ShouldSucceed #-} +} diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc037.hs b/ghc/compiler/tests/typecheck/should_succeed/tc037.hs new file mode 100644 index 0000000..8621b27 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc037.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +class Eq' a where + deq :: a -> a -> Bool + +instance (Eq' a) => Eq' [a] where + deq [] [] = True + deq (x:xs) (y:ys) = if (x `deq` y) then (deq xs ys) else False + deq other1 other2 = False diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc037.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc037.stderr new file mode 100644 index 0000000..87167e2 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc037.stderr @@ -0,0 +1,34 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq'.deq = /\ a.t21 -> \{-classdict-} [] [deq.t22] -> deq.t22 +{- nonrec -} +defm.ShouldSucceed.Eq'.deq = + /\ a.t23 -> + \{-dict-} d.ShouldSucceed.Eq'.t24 -> + (error (a.t23 -> a.t23 -> Bool)) + "No default method for \"ShouldSucceed.Eq'.defm.ShouldSucceed.Eq'.deq\"\n" +AbsBinds +[a.t0] +[d.ShouldSucceed.Eq'.t1] +[(d.ShouldSucceed.Eq'.t2, dfun.ShouldSucceed.Eq'.List)] + (d.ShouldSucceed.Eq'.t19, d.ShouldSucceed.Eq'.t2) + (ShouldSucceed.Eq'.deq.t16, + ShouldSucceed.Eq'.deq [a.t0] d.ShouldSucceed.Eq'.t19) + (d.ShouldSucceed.Eq'.t20, d.ShouldSucceed.Eq'.t1) + (ShouldSucceed.Eq'.deq.t13, + ShouldSucceed.Eq'.deq a.t0 d.ShouldSucceed.Eq'.t20) + {- rec -} + d.ShouldSucceed.Eq'.t2 = ({-dict-} [] [deq.t3]) + deq.t3 :: [a.t0] -> [a.t0] -> Bool + deq.t3 + [] [] = True + deq.t3 + (x.r29 : xs.r30) (y.r31 : ys.r32) + = if x.r29 `ShouldSucceed.Eq'.deq.t13` y.r31 then + ShouldSucceed.Eq'.deq.t16 xs.r30 ys.r32 + else + False + deq.t3 + other1.r33 other2.r34 + = False + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc038.hs b/ghc/compiler/tests/typecheck/should_succeed/tc038.hs new file mode 100644 index 0000000..d404ee6 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc038.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +f (x:xs) = if (x == (fromInteger 2)) then xs else [] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc038.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc038.stderr new file mode 100644 index 0000000..1e044f9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc038.stderr @@ -0,0 +1,15 @@ +Typechecked: +fromInt.t16 = int2Integer +lit.t10 = fromInt.t16 (MkInt 2#) +AbsBinds [tt12] [d.Num.t14] [(f.t1, ShouldSucceed.f)] + (d.Eq.t15, sdsel.Num.Eq tt12 d.Num.t14) + (fromInteger.t8, fromInteger tt12 d.Num.t14) + (==.t6, (==) tt12 d.Eq.t15) + {- nonrec -} + f.t1 :: [tt12] -> [tt12] + f.t1 (x.r54 : xs.r55) + = if x.r54 ==.t6 (fromInteger.t8 lit.t10) then + xs.r55 + else + [] (tt12) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc039.hs b/ghc/compiler/tests/typecheck/should_succeed/tc039.hs new file mode 100644 index 0000000..0e5bd95 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc039.hs @@ -0,0 +1,4 @@ +module ShouldSucc where + +class (Eq a) => A a where + op1 :: a -> a diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc039.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc039.stderr new file mode 100644 index 0000000..025c3e9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc039.stderr @@ -0,0 +1,11 @@ +Typechecked: +{- nonrec -} +ShouldSucc.A.op1 = /\ a.t0 -> \{-classdict-} [d.Eq.t2] [op1.t1] -> op1.t1 +sdsel.ShouldSucc.A.Eq = /\ a.t0 -> \{-classdict-} [d.Eq.t2] [op1.t1] -> d.Eq.t2 +{- nonrec -} +defm.ShouldSucc.A.op1 = + /\ a.t3 -> + \{-dict-} d.ShouldSucc.A.t4 -> + (error (a.t3 -> a.t3)) + "No default method for \"ShouldSucc.A.defm.ShouldSucc.A.op1\"\n" + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc040.hi b/ghc/compiler/tests/typecheck/should_succeed/tc040.hi new file mode 100644 index 0000000..41d1ee5 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc040.hi @@ -0,0 +1,4 @@ +interface ShouldSucceed where { +import PreludeCore(Eq) +f :: Eq a => a -> [a] +} diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc040.hs b/ghc/compiler/tests/typecheck/should_succeed/tc040.hs new file mode 100644 index 0000000..33113cc --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc040.hs @@ -0,0 +1,9 @@ +module ShouldSucceed where + +--!!! tests the deduction of contexts. + +f :: (Eq a) => a -> [a] + +f x = g x + where + g y = if (y == x) then [] else [y] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc040.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc040.stderr new file mode 100644 index 0000000..686e842 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc040.stderr @@ -0,0 +1,17 @@ +Typechecked: +AbsBinds [a.t2] [d.Eq.t3] [(f.t1, ShouldSucceed.f)] + (d.Eq.t12, d.Eq.t3) + (==.t9, (==) a.t2 d.Eq.t12) + {- nonrec -} + f.t1 :: a.t2 -> [a.t2] + f.t1 x.r55 = g.r56 x.r55 + where + AbsBinds [] [] [(g.t6, g.r56)] + {- nonrec -} + g.t6 :: a.t2 -> [a.t2] + g.t6 y.r57 = if y.r57 ==.t9 x.r55 then + [] (a.t2) + else + [y.r57] (a.t2) + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc041.hs b/ghc/compiler/tests/typecheck/should_succeed/tc041.hs new file mode 100644 index 0000000..730af9c --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc041.hs @@ -0,0 +1,12 @@ +--!!! a very simple test of class and instance declarations + +module ShouldSucceed where + +class H a where + op1 :: a -> a -> a + +instance H Bool where + op1 x y = y + +f :: Bool -> Int -> Bool +f x y = op1 x x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc041.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc041.stderr new file mode 100644 index 0000000..1087bed --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc041.stderr @@ -0,0 +1,22 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.H.op1 = /\ a.t8 -> \{-classdict-} [] [op1.t9] -> op1.t9 +{- nonrec -} +defm.ShouldSucceed.H.op1 = + /\ a.t10 -> + \{-dict-} d.ShouldSucceed.H.t11 -> + (error (a.t10 -> a.t10 -> a.t10)) + "No default method for \"ShouldSucceed.H.defm.ShouldSucceed.H.op1\"\n" +{- rec -} +dfun.ShouldSucceed.H.Bool = ({-dict-} [] [const.ShouldSucceed.H.Bool.op1]) +const.ShouldSucceed.H.Bool.op1 :: Bool -> Bool -> Bool +const.ShouldSucceed.H.Bool.op1 + x.r29 y.r30 + = y.r30 +AbsBinds [] [] [(f.t1, ShouldSucceed.f)] + (ShouldSucceed.H.op1.t5, const.ShouldSucceed.H.Bool.op1) + {- nonrec -} + f.t1 :: Bool -> Int -> Bool + f.t1 x.r58 y.r59 + = ShouldSucceed.H.op1.t5 x.r58 x.r58 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc042.hs b/ghc/compiler/tests/typecheck/should_succeed/tc042.hs new file mode 100644 index 0000000..708ea26 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc042.hs @@ -0,0 +1,73 @@ +--!!! a file mailed us by Ryzard Kubiak. This provides a good test of the code +--!!! handling type signatures and recursive data types. + +module ShouldSucceed where + +data Boolean = FF | TT +data Pair a b = Mkpair a b +data List alpha = Nil | Cons alpha (List alpha) +data Nat = Zero | Succ Nat +data Tree t = Leaf t | Node (Tree t) (Tree t) + +idb :: Boolean -> Boolean +idb x = x + + +swap :: Pair a b -> Pair b a +swap t = case t of + Mkpair x y -> Mkpair y x + +neg :: Boolean -> Boolean +neg b = case b of + FF -> TT + TT -> FF + +nUll :: List alpha -> Boolean +nUll l = case l of + Nil -> TT + Cons y ys -> FF + +idl :: List a -> List a +idl xs = case xs of + Nil -> Nil + Cons y ys -> Cons y (idl ys) + +add :: Nat -> Nat -> Nat +add a b = case a of + Zero -> b + Succ c -> Succ (add c b) + +app :: List alpha -> List alpha -> List alpha +app xs zs = case xs of + Nil -> zs + Cons y ys -> Cons y (app ys zs) + +lEngth :: List a -> Nat +lEngth xs = case xs of + Nil -> Zero + Cons y ys -> Succ(lEngth ys) + +before :: List Nat -> List Nat +before xs = case xs of + Nil -> Nil + Cons y ys -> case y of + Zero -> Nil + Succ n -> Cons y (before ys) + +rEverse :: List alpha -> List alpha +rEverse rs = case rs of + Nil -> Nil + Cons y ys -> app (rEverse ys) (Cons y Nil) + + +flatten :: Tree alpha -> List alpha +flatten t = case t of + Leaf x -> Cons x Nil + Node l r -> app (flatten l) (flatten r) + +sUm :: Tree Nat -> Nat +sUm t = case t of + Leaf t -> t + Node l r -> add (sUm l) (sUm r) + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc042.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc042.stderr new file mode 100644 index 0000000..ee74e98 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc042.stderr @@ -0,0 +1,125 @@ +Typechecked: +AbsBinds [] [] [(idb.t1, ShouldSucceed.idb)] + {- nonrec -} + idb.t1 :: ShouldSucceed.Boolean -> ShouldSucceed.Boolean + idb.t1 + x.r91 = x.r91 +AbsBinds [a.t12, b.t13] [] [(swap.t4, ShouldSucceed.swap)] + {- nonrec -} + swap.t4 :: ShouldSucceed.Pair b.t13 a.t12 -> ShouldSucceed.Pair a.t12 b.t13 + swap.t4 + t.r92 = case t.r92 of + (ShouldSucceed.Mkpair x.r93 y.r94) + -> (ShouldSucceed.Mkpair [a.t12, b.t13]) y.r94 x.r93 +AbsBinds [] [] [(neg.t16, ShouldSucceed.neg)] + {- nonrec -} + neg.t16 :: ShouldSucceed.Boolean -> ShouldSucceed.Boolean + neg.t16 + b.r95 = case b.r95 of + ShouldSucceed.FF + -> ShouldSucceed.TT + ShouldSucceed.TT + -> ShouldSucceed.FF +AbsBinds [alpha.t26] [] [(null.t20, ShouldSucceed.null)] + {- nonrec -} + null.t20 :: ShouldSucceed.List alpha.t26 -> ShouldSucceed.Boolean + null.t20 + l.r96 = case l.r96 of + ShouldSucceed.Nil + -> ShouldSucceed.TT + (ShouldSucceed.Cons y.r97 ys.r98) + -> ShouldSucceed.FF +AbsBinds [a.t30] [] [(idl.t29, ShouldSucceed.idl)] + {- rec -} + idl.t29 :: ShouldSucceed.List a.t30 -> ShouldSucceed.List a.t30 + idl.t29 + xs.r99 = case xs.r99 of + ShouldSucceed.Nil + -> ShouldSucceed.Nil a.t30 + (ShouldSucceed.Cons y.r100 ys.r101) + -> (ShouldSucceed.Cons a.t30) + y.r100 (idl.t29 ys.r101) +AbsBinds [] [] [(add.t41, ShouldSucceed.add)] + {- rec -} + add.t41 :: ShouldSucceed.Nat -> ShouldSucceed.Nat -> ShouldSucceed.Nat + add.t41 + a.r102 b.r103 + = case a.r102 of + ShouldSucceed.Zero + -> b.r103 + (ShouldSucceed.Succ c.r104) + -> ShouldSucceed.Succ (add.t41 c.r104 b.r103) +AbsBinds [alpha.t49] [] [(app.t48, ShouldSucceed.app)] + {- rec -} + app.t48 :: + ShouldSucceed.List alpha.t49 + -> ShouldSucceed.List alpha.t49 -> ShouldSucceed.List alpha.t49 + app.t48 + xs.r105 zs.r106 + = case xs.r105 of + ShouldSucceed.Nil + -> zs.r106 + (ShouldSucceed.Cons y.r107 ys.r108) + -> (ShouldSucceed.Cons alpha.t49) + y.r107 (app.t48 ys.r108 zs.r106) +AbsBinds [a.t61] [] [(length.t60, ShouldSucceed.length)] + {- rec -} + length.t60 :: ShouldSucceed.List a.t61 -> ShouldSucceed.Nat + length.t60 + xs.r109 = case xs.r109 of + ShouldSucceed.Nil + -> ShouldSucceed.Zero + (ShouldSucceed.Cons y.r110 ys.r111) + -> ShouldSucceed.Succ (length.t60 ys.r111) +AbsBinds [] [] [(before.t70, ShouldSucceed.before)] + {- rec -} + before.t70 :: + ShouldSucceed.List ShouldSucceed.Nat + -> ShouldSucceed.List ShouldSucceed.Nat + before.t70 + xs.r112 = case xs.r112 of + ShouldSucceed.Nil + -> ShouldSucceed.Nil ShouldSucceed.Nat + (ShouldSucceed.Cons y.r113 ys.r114) + -> case y.r113 of + ShouldSucceed.Zero + -> ShouldSucceed.Nil ShouldSucceed.Nat + (ShouldSucceed.Succ n.r115) + -> (ShouldSucceed.Cons + ShouldSucceed.Nat) + y.r113 (before.t70 ys.r114) +AbsBinds [alpha.t95] [] [(reverse.t84, ShouldSucceed.reverse)] + {- rec -} + reverse.t84 :: ShouldSucceed.List alpha.t95 -> ShouldSucceed.List alpha.t95 + reverse.t84 + rs.r116 = case rs.r116 of + ShouldSucceed.Nil + -> ShouldSucceed.Nil alpha.t95 + (ShouldSucceed.Cons y.r117 ys.r118) + -> (ShouldSucceed.app alpha.t95) + (reverse.t84 ys.r118) + ((ShouldSucceed.Cons alpha.t95) + y.r117 (ShouldSucceed.Nil alpha.t95)) +AbsBinds [alpha.t108] [] [(flatten.t98, ShouldSucceed.flatten)] + {- rec -} + flatten.t98 :: + ShouldSucceed.Tree alpha.t108 -> ShouldSucceed.List alpha.t108 + flatten.t98 + t.r119 = case t.r119 of + (ShouldSucceed.Leaf x.r120) + -> (ShouldSucceed.Cons alpha.t108) + x.r120 (ShouldSucceed.Nil alpha.t108) + (ShouldSucceed.Node l.r121 r.r122) + -> (ShouldSucceed.app alpha.t108) + (flatten.t98 l.r121) (flatten.t98 r.r122) +AbsBinds [] [] [(sum.t113, ShouldSucceed.sum)] + {- rec -} + sum.t113 :: ShouldSucceed.Tree ShouldSucceed.Nat -> ShouldSucceed.Nat + sum.t113 + t.r123 = case t.r123 of + (ShouldSucceed.Leaf t.r124) + -> t.r124 + (ShouldSucceed.Node l.r125 r.r126) + -> ShouldSucceed.add + (sum.t113 l.r125) (sum.t113 r.r126) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc043.hs b/ghc/compiler/tests/typecheck/should_succeed/tc043.hs new file mode 100644 index 0000000..727f288 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc043.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +--!!! another simple test of class and instance code. + +class A a where + op1 :: a + +instance A Int where + op1 = 2 + +f x = op1 + +class B b where + op2 :: b -> Int + +instance (B a) => B [a] where + op2 [] = 0 + op2 (x:xs) = 1 + op2 xs diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc043.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc043.stderr new file mode 100644 index 0000000..e6c0b1d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc043.stderr @@ -0,0 +1,44 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.A.op1 = /\ a.t26 -> \{-classdict-} [] [op1.t27] -> op1.t27 +{- nonrec -} +defm.ShouldSucceed.A.op1 = + /\ a.t28 -> + \{-dict-} d.ShouldSucceed.A.t29 -> + (error a.t28) + "No default method for \"ShouldSucceed.A.defm.ShouldSucceed.A.op1\"\n" +{- nonrec -} +ShouldSucceed.B.op2 = /\ b.t30 -> \{-classdict-} [] [op2.t31] -> op2.t31 +{- nonrec -} +defm.ShouldSucceed.B.op2 = + /\ b.t32 -> + \{-dict-} d.ShouldSucceed.B.t33 -> + (error (b.t32 -> Int)) + "No default method for \"ShouldSucceed.B.defm.ShouldSucceed.B.op2\"\n" +{- rec -} +dfun.ShouldSucceed.A.Int = ({-dict-} [] [const.ShouldSucceed.A.Int.op1]) +const.ShouldSucceed.A.Int.op1 :: Int +const.ShouldSucceed.A.Int.op1 = lit.t7 +AbsBinds +[a.t8] +[d.ShouldSucceed.B.t9] +[(d.ShouldSucceed.B.t10, dfun.ShouldSucceed.B.List)] + (d.ShouldSucceed.B.t25, d.ShouldSucceed.B.t10) + (ShouldSucceed.B.op2.t23, ShouldSucceed.B.op2 [a.t8] d.ShouldSucceed.B.t25) + (+.t19, plusInt) + {- rec -} + d.ShouldSucceed.B.t10 = ({-dict-} [] [op2.t11]) + op2.t11 :: [a.t8] -> Int + op2.t11 + [] = lit.t14 + op2.t11 + (x.r14 : xs.r15) + = lit.t21 +.t19 (ShouldSucceed.B.op2.t23 xs.r15) +lit.t7 = MkInt 2# +lit.t14 = MkInt 0# +lit.t21 = MkInt 1# +AbsBinds [ot2, a.t3] [d.ShouldSucceed.A.t5] [(f.t1, ShouldSucceed.f)] + (ShouldSucceed.A.op1.t4, ShouldSucceed.A.op1 a.t3 d.ShouldSucceed.A.t5) + {- nonrec -} + f.t1 :: ot2 -> a.t3 + f.t1 x.r61 = ShouldSucceed.A.op1.t4 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc044.hs b/ghc/compiler/tests/typecheck/should_succeed/tc044.hs new file mode 100644 index 0000000..9f98989 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc044.hs @@ -0,0 +1,6 @@ +-- once produced a bug, here as regression test + +module P where + +f _ | otherwise = () + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc044.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc044.stderr new file mode 100644 index 0000000..ff9d543 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc044.stderr @@ -0,0 +1,6 @@ +Typechecked: +AbsBinds [ot2] [] [(f.t1, P.f)] + {- nonrec -} + f.t1 :: ot2 -> () + f.t1 _ | otherwise = () + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc045.hs b/ghc/compiler/tests/typecheck/should_succeed/tc045.hs new file mode 100644 index 0000000..fc6a72e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc045.hs @@ -0,0 +1,19 @@ +module H where + +class C a where + op1 :: a -> a + +class (C a) => B a where + op2 :: a -> a -> a + +instance (B a) => B [a] where + op2 xs ys = xs + +instance C [a] where + op1 xs = xs + +{- This was passed by the prototype, but failed hard in the new +typechecker with the message + +Fail:No match in theta_class +-} diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc045.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc045.stderr new file mode 100644 index 0000000..b44c2a4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc045.stderr @@ -0,0 +1,32 @@ +Typechecked: +{- nonrec -} +H.B.op2 = /\ a.t11 -> \{-classdict-} [d.H.C.t13] [op2.t12] -> op2.t12 +sdsel.H.B.H.C = /\ a.t11 -> \{-classdict-} [d.H.C.t13] [op2.t12] -> d.H.C.t13 +{- nonrec -} +defm.H.B.op2 = + /\ a.t14 -> + \{-dict-} d.H.B.t15 -> + (error (a.t14 -> a.t14 -> a.t14)) + "No default method for \"H.B.defm.H.B.op2\"\n" +{- nonrec -} +H.C.op1 = /\ a.t16 -> \{-classdict-} [] [op1.t17] -> op1.t17 +{- nonrec -} +defm.H.C.op1 = + /\ a.t18 -> + \{-dict-} d.H.C.t19 -> + (error (a.t18 -> a.t18)) + "No default method for \"H.C.defm.H.C.op1\"\n" +AbsBinds [a.t0] [d.H.B.t2, d.H.C.t1] [(d.H.B.t3, dfun.H.B.List)] + {- rec -} + d.H.B.t3 = ({-dict-} [d.H.C.t1] [op2.t4]) + op2.t4 :: [a.t0] -> [a.t0] -> [a.t0] + op2.t4 + xs.r13 ys.r14 + = xs.r13 +AbsBinds [a.t7] [] [(d.H.C.t8, dfun.H.C.List)] + {- rec -} + d.H.C.t8 = ({-dict-} [] [op1.t9]) + op1.t9 :: [a.t7] -> [a.t7] + op1.t9 + xs.r16 = xs.r16 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc046.hs b/ghc/compiler/tests/typecheck/should_succeed/tc046.hs new file mode 100644 index 0000000..dbbf3a1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc046.hs @@ -0,0 +1,9 @@ +module H where + +class C a where + op1 :: a -> a + +class (C a) => B a where + op2 :: a -> a -> a + +{- Failed hard in new tc with "No match in theta_class" -} diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc046.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc046.stderr new file mode 100644 index 0000000..0626901 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc046.stderr @@ -0,0 +1,19 @@ +Typechecked: +{- nonrec -} +H.B.op2 = /\ a.t0 -> \{-classdict-} [d.H.C.t2] [op2.t1] -> op2.t1 +sdsel.H.B.H.C = /\ a.t0 -> \{-classdict-} [d.H.C.t2] [op2.t1] -> d.H.C.t2 +{- nonrec -} +defm.H.B.op2 = + /\ a.t3 -> + \{-dict-} d.H.B.t4 -> + (error (a.t3 -> a.t3 -> a.t3)) + "No default method for \"H.B.defm.H.B.op2\"\n" +{- nonrec -} +H.C.op1 = /\ a.t5 -> \{-classdict-} [] [op1.t6] -> op1.t6 +{- nonrec -} +defm.H.C.op1 = + /\ a.t7 -> + \{-dict-} d.H.C.t8 -> + (error (a.t7 -> a.t7)) + "No default method for \"H.C.defm.H.C.op1\"\n" + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc047.hs b/ghc/compiler/tests/typecheck/should_succeed/tc047.hs new file mode 100644 index 0000000..b8c197d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc047.hs @@ -0,0 +1,23 @@ +module ShouldSucceed where + +type OL a = [a] + +-- produces the interface: +-- data OL a = MkOL [a] deriving () +-- ranOAL :: (OL (a, a)) -> [a] +-- this interface was produced by BOTH hbc and nhc + +-- the following bogus type sig. was accepted by BOTH hbc and nhc +f x = ranOAL where -- ranOAL :: OL (a,v) -> [a] +--ranOAL :: OL (a,v) -> [v], the right sig. + ranOAL ( xs) = mp sd xs + + +mp f [] = [] +mp f (x:xs) = (f x) : mp f xs + +sd (f,s) = s + + + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc047.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc047.stderr new file mode 100644 index 0000000..1dd0462 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc047.stderr @@ -0,0 +1,29 @@ +Typechecked: +AbsBinds [tt8, tt4] [] [(mp.t1, ShouldSucceed.mp)] + {- rec -} + mp.t1 :: (tt8 -> tt4) -> [tt8] -> [tt4] + mp.t1 + f.r61 [] = [] (tt4) + mp.t1 + f.r62 (x.r63 : xs.r64) + = ((:) tt4) (f.r62 x.r63) (mp.t1 f.r62 xs.r64) +AbsBinds [tt17, tt18] [] [(sd.t14, ShouldSucceed.sd)] + {- nonrec -} + sd.t14 :: (tt17, tt18) -> tt18 + sd.t14 + (f.r65, s.r66) + = s.r66 +AbsBinds [ot21, tt29, tt30] [] [(f.t20, ShouldSucceed.f)] + {- nonrec -} + f.t20 :: ot21 -> [(tt29, tt30)] -> [tt30] + f.t20 + x.r58 = ranOAL.r59 [tt29, tt30] + where + AbsBinds [tt27, tt28] [] [(ranOAL.t23, ranOAL.r59)] + {- nonrec -} + ranOAL.t23 :: [(tt27, tt28)] -> [tt28] + ranOAL.t23 + xs.r60 = (ShouldSucceed.mp [(tt27, tt28), tt28]) + (ShouldSucceed.sd [tt27, tt28]) xs.r60 + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc048.hs b/ghc/compiler/tests/typecheck/should_succeed/tc048.hs new file mode 100644 index 0000000..eea6f10 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc048.hs @@ -0,0 +1,21 @@ +module ShouldSucceed where + +data OL a = MkOL [a] +data FG a b = MkFG (OL (a,b)) +data AFE n a b = MkAFE (OL (n,(FG a b))) + +--ranOAL :: OL (a,v) -> [a] +ranOAL :: OL (a,v) -> [v] +ranOAL (MkOL xs) = mAp sNd xs + +mAp f [] = [] +mAp f (x:xs) = (f x) : mAp f xs + +sNd (f,s) = s + +ranAFE :: AFE n a b -> [FG a b] -- ? +ranAFE (MkAFE nfs) = ranOAL nfs + + + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc048.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc048.stderr new file mode 100644 index 0000000..1640beb --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc048.stderr @@ -0,0 +1,31 @@ +Typechecked: +AbsBinds [tt8, tt4] [] [(map.t1, ShouldSucceed.map)] + {- rec -} + map.t1 :: (tt8 -> tt4) -> [tt8] -> [tt4] + map.t1 + f.r75 [] = [] (tt4) + map.t1 + f.r76 (x.r77 : xs.r78) + = ((:) tt4) (f.r76 x.r77) (map.t1 f.r76 xs.r78) +AbsBinds [tt17, tt18] [] [(snd.t14, ShouldSucceed.snd)] + {- nonrec -} + snd.t14 :: (tt17, tt18) -> tt18 + snd.t14 + (f.r79, s.r80) + = s.r80 +AbsBinds [a.t21, v.t22] [] [(ranOAL.t20, ShouldSucceed.ranOAL)] + {- nonrec -} + ranOAL.t20 :: ShouldSucceed.OL (a.t21, v.t22) -> [v.t22] + ranOAL.t20 + (ShouldSucceed.MkOL xs.r74) + = (ShouldSucceed.map [(a.t21, v.t22), v.t22]) + (ShouldSucceed.snd [a.t21, v.t22]) xs.r74 +AbsBinds [a.t38, a.t36, b.t37] [] [(ranAFE.t30, ShouldSucceed.ranAFE)] + {- nonrec -} + ranAFE.t30 :: + ShouldSucceed.AFE a.t38 a.t36 b.t37 -> [ShouldSucceed.FG a.t36 b.t37] + ranAFE.t30 + (ShouldSucceed.MkAFE nfs.r81) + = (ShouldSucceed.ranOAL [a.t38, ShouldSucceed.FG a.t36 b.t37]) + nfs.r81 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc049.hs b/ghc/compiler/tests/typecheck/should_succeed/tc049.hs new file mode 100644 index 0000000..20be6b7 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc049.hs @@ -0,0 +1,39 @@ +module ShouldSucceed where + +fib n = if n <= 2 then n else fib (n-1) + fib (n-2) + +---------------------------------------- + +mem x [] = False +mem x (y:ys) = (x == y) `oR` mem x ys + +a `oR` b = if a then True else b + +---------------------------------------- + +mem1 x [] = False +mem1 x (y:ys) = (x == y) `oR1` mem2 x ys + +a `oR1` b = if a then True else b + +mem2 x [] = False +mem2 x (y:ys) = (x == y) `oR` mem1 x ys + +--------------------------------------- + +mem3 x [] = False +mem3 x (y:ys) = if [x] == [y] then mem4 x ys else False + +mem4 y (x:xs) = mem3 y xs + +--------------------------------------- + +main1 = [[(1,True)]] == [[(2,False)]] + +--------------------------------------- + +main2 = "Hello" == "Goodbye" + +--------------------------------------- + +main3 = [[1],[2]] == [[3]] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc049.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc049.stderr new file mode 100644 index 0000000..1a5cf45 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc049.stderr @@ -0,0 +1,123 @@ +Typechecked: +d.Num.t125 = dfun.Num.Integer +d.Num.t133 = dfun.Num.Integer +d.Eq.t130 = sdsel.Num.Eq tt105 d.Num.t125 +d.Eq.t138 = sdsel.Num.Eq tt121 d.Num.t133 +fromInt.t124 = fromInt tt105 d.Num.t125 +lit.t106 = fromInt.t124 (MkInt 2#) +fromInt.t126 = fromInt.t124 +lit.t104 = fromInt.t126 (MkInt 1#) +d.Eq.t131 = dfun.Eq.Bool +d.Eq.t129 = dfun.Eq.Tuple2 [tt105, Bool] [d.Eq.t130, d.Eq.t131] +(==.t128) = (==) (tt105, Bool) d.Eq.t129 +(==.t127) = eqList (tt105, Bool) ==.t128 +(==.t102) = eqList [(tt105, Bool)] ==.t127 +(==.t111) = eqString +fromInt.t132 = fromInt tt121 d.Num.t133 +lit.t122 = fromInt.t132 (MkInt 3#) +fromInt.t134 = fromInt.t132 +lit.t120 = fromInt.t134 (MkInt 2#) +fromInt.t135 = fromInt.t134 +lit.t118 = fromInt.t135 (MkInt 1#) +(==.t137) = (==) tt121 d.Eq.t138 +(==.t136) = eqList tt121 ==.t137 +(==.t116) = eqList [tt121] ==.t136 +AbsBinds [tt19] [d.Num.t24, d.Ord.t28] [(fib.t1, ShouldSucceed.fib)] + (fromInt.t23, fromInt tt19 d.Num.t24) + (lit.t20, fromInt.t23 (MkInt 2#)) + (d.Num.t25, d.Num.t24) + (-.t18, (-) tt19 d.Num.t25) + (fromInt.t26, fromInt.t23) + (lit.t14, fromInt.t26 (MkInt 1#)) + (-.t12, (-.t18)) + (d.Num.t27, d.Num.t25) + (+.t9, (+) tt19 d.Num.t27) + (lit.t6, lit.t20) + (<=.t4, (<=) tt19 d.Ord.t28) + {- rec -} + fib.t1 :: tt19 -> tt19 + fib.t1 + n.r64 = if n.r64 <=.t4 lit.t6 then + n.r64 + else + (fib.t1 (n.r64 -.t12 lit.t14)) + +.t9 (fib.t1 (n.r64 -.t18 lit.t20)) +AbsBinds [] [] [(oR.t30, ShouldSucceed.oR)] + {- nonrec -} + oR.t30 :: Bool -> Bool -> Bool + oR.t30 + a.r69 b.r70 + = if a.r69 then True else b.r70 +AbsBinds [tt41] [d.Eq.t46] [(mem.t34, ShouldSucceed.mem)] + (==.t42, (==) tt41 d.Eq.t46) + {- rec -} + mem.t34 :: tt41 -> [tt41] -> Bool + mem.t34 + x.r65 [] = False + mem.t34 + x.r66 (y.r67 : ys.r68) + = (x.r66 ==.t42 y.r67) `ShouldSucceed.oR` (mem.t34 x.r66 ys.r68) +AbsBinds [] [] [(oR1.t48, ShouldSucceed.oR1)] + {- nonrec -} + oR1.t48 :: Bool -> Bool -> Bool + oR1.t48 + a.r75 b.r76 + = if a.r75 then True else b.r76 +AbsBinds +[tt61] +[d.Eq.t77] +[(mem1.t53, ShouldSucceed.mem1), (mem2.t54, ShouldSucceed.mem2)] + (==.t62, (==) tt61 d.Eq.t77) + (==.t73, (==.t62)) + {- rec -} + mem1.t53 :: tt61 -> [tt61] -> Bool + mem1.t53 + x.r71 [] = False + mem1.t53 + x.r72 (y.r73 : ys.r74) + = (x.r72 ==.t62 y.r73) + `ShouldSucceed.oR1` (mem2.t54 x.r72 ys.r74) + mem2.t54 :: tt61 -> [tt61] -> Bool + mem2.t54 + x.r77 [] = False + mem2.t54 + x.r78 (y.r79 : ys.r80) + = (x.r78 ==.t73 y.r79) + `ShouldSucceed.oR` (mem1.t53 x.r78 ys.r80) +AbsBinds +[tt87] +[d.Eq.t98] +[(mem3.t80, ShouldSucceed.mem3), (mem4.t81, ShouldSucceed.mem4)] + (==.t97, (==) tt87 d.Eq.t98) + (==.t89, eqList tt87 ==.t97) + {- rec -} + mem3.t80 :: tt87 -> [tt87] -> Bool + mem3.t80 + x.r81 [] = False + mem3.t80 + x.r82 (y.r83 : ys.r84) + = if ([x.r82] (tt87)) ==.t89 ([y.r83] (tt87)) then + mem4.t81 x.r82 ys.r84 + else + False + mem4.t81 :: tt87 -> [tt87] -> Bool + mem4.t81 + y.r87 (x.r85 : xs.r86) + = mem3.t80 y.r87 xs.r86 +AbsBinds [] [] [(main1.t100, ShouldSucceed.main1)] + {- nonrec -} + main1.t100 :: Bool + main1.t100 + = ([[(lit.t104, True)] ((tt105, Bool))] ([(tt105, Bool)])) + ==.t102 ([[(lit.t106, False)] ((tt105, Bool))] ([(tt105, Bool)])) +AbsBinds [] [] [(main2.t109, ShouldSucceed.main2)] + {- nonrec -} + main2.t109 :: Bool + main2.t109 = "Hello" ==.t111 "Goodbye" +AbsBinds [] [] [(main3.t114, ShouldSucceed.main3)] + {- nonrec -} + main3.t114 :: Bool + main3.t114 + = ([[lit.t118] (tt121), [lit.t120] (tt121)] ([tt121])) + ==.t116 ([[lit.t122] (tt121)] ([tt121])) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc050.hs b/ghc/compiler/tests/typecheck/should_succeed/tc050.hs new file mode 100644 index 0000000..ef03b28 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc050.hs @@ -0,0 +1,23 @@ +module ShouldSucceed where + +class Foo a where + o_and :: a -> a -> a + + +instance Foo Bool where + o_and False x = False + o_and x False = False + o_and True True = True + + +instance Foo Int where + o_and x 0 = 0 + o_and 0 x = 0 + o_and 1 1 = 1 + + +f x y = o_and x False + +g x y = o_and x 1 + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc050.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc050.stderr new file mode 100644 index 0000000..dbe227f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc050.stderr @@ -0,0 +1,60 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Foo.o_and = /\ a.t39 -> \{-classdict-} [] [o_and.t40] -> o_and.t40 +{- nonrec -} +defm.ShouldSucceed.Foo.o_and = + /\ a.t41 -> + \{-dict-} d.ShouldSucceed.Foo.t42 -> + (error (a.t41 -> a.t41 -> a.t41)) + "No default method for \"ShouldSucceed.Foo.defm.ShouldSucceed.Foo.o_and\"\n" +{- rec -} +dfun.ShouldSucceed.Foo.Bool = ({-dict-} [] [const.ShouldSucceed.Foo.Bool.o_and]) +const.ShouldSucceed.Foo.Bool.o_and :: Bool -> Bool -> Bool +const.ShouldSucceed.Foo.Bool.o_and + False x.r30 + = False +const.ShouldSucceed.Foo.Bool.o_and + x.r31 False + = False +const.ShouldSucceed.Foo.Bool.o_and + True True + = True +{- rec -} +dfun.ShouldSucceed.Foo.Int = ({-dict-} [] [const.ShouldSucceed.Foo.Int.o_and]) +const.ShouldSucceed.Foo.Int.o_and :: Int -> Int -> Int +const.ShouldSucceed.Foo.Int.o_and + x.r32 0 = lit.t24 +const.ShouldSucceed.Foo.Int.o_and + 0 x.r33 = lit.t30 +const.ShouldSucceed.Foo.Int.o_and + 1 1 = lit.t38 +lit.t21 = MkInt 0# +(==.t22) = eqInt +lit.t24 = lit.t21 +lit.t26 = lit.t21 +(==.t27) = (==.t22) +lit.t30 = lit.t21 +lit.t32 = MkInt 1# +(==.t33) = (==.t22) +lit.t35 = lit.t32 +(==.t36) = (==.t22) +lit.t38 = lit.t32 +AbsBinds [ot3] [] [(f.t1, ShouldSucceed.f)] + (ShouldSucceed.Foo.o_and.t5, const.ShouldSucceed.Foo.Bool.o_and) + {- nonrec -} + f.t1 :: Bool -> ot3 -> Bool + f.t1 x.r61 y.r62 + = ShouldSucceed.Foo.o_and.t5 x.r61 False +AbsBinds +[ot9, a.t10] +[d.Num.t15, d.ShouldSucceed.Foo.t16] +[(g.t7, ShouldSucceed.g)] + (fromInt.t14, fromInt a.t10 d.Num.t15) + (lit.t13, fromInt.t14 (MkInt 1#)) + (ShouldSucceed.Foo.o_and.t11, + ShouldSucceed.Foo.o_and a.t10 d.ShouldSucceed.Foo.t16) + {- nonrec -} + g.t7 :: a.t10 -> ot9 -> a.t10 + g.t7 x.r63 y.r64 + = ShouldSucceed.Foo.o_and.t11 x.r63 lit.t13 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc051.hs b/ghc/compiler/tests/typecheck/should_succeed/tc051.hs new file mode 100644 index 0000000..7f14282 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc051.hs @@ -0,0 +1,30 @@ +module ShouldSucceed where + +class Eq' a where + doubleeq :: a -> a -> Bool + +class (Eq' a) => Ord' a where + lt :: a -> a -> Bool + +instance Eq' Int where + doubleeq x y = True + +instance (Eq' a) => Eq' [a] where + doubleeq x y = True + +instance Ord' Int where + lt x y = True + +{- +class (Ord a) => Ix a where + range :: (a,a) -> [a] + +instance Ix Int where + range (x,y) = [x,y] +-} + + + + + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc051.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc051.stderr new file mode 100644 index 0000000..7c9c45e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc051.stderr @@ -0,0 +1,49 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq'.doubleeq = + /\ a.t11 -> \{-classdict-} [] [doubleeq.t12] -> doubleeq.t12 +{- nonrec -} +defm.ShouldSucceed.Eq'.doubleeq = + /\ a.t13 -> + \{-dict-} d.ShouldSucceed.Eq'.t14 -> + (error (a.t13 -> a.t13 -> Bool)) + "No default method for \"ShouldSucceed.Eq'.defm.ShouldSucceed.Eq'.doubleeq\"\n" +{- nonrec -} +ShouldSucceed.Ord'.lt = + /\ a.t15 -> \{-classdict-} [d.ShouldSucceed.Eq'.t17] [lt.t16] -> lt.t16 +sdsel.ShouldSucceed.Ord'.ShouldSucceed.Eq' = + /\ a.t15 -> + \{-classdict-} [d.ShouldSucceed.Eq'.t17] [lt.t16] -> + d.ShouldSucceed.Eq'.t17 +{- nonrec -} +defm.ShouldSucceed.Ord'.lt = + /\ a.t18 -> + \{-dict-} d.ShouldSucceed.Ord'.t19 -> + (error (a.t18 -> a.t18 -> Bool)) + "No default method for \"ShouldSucceed.Ord'.defm.ShouldSucceed.Ord'.lt\"\n" +{- rec -} +dfun.ShouldSucceed.Eq'.Int = + ({-dict-} [] [const.ShouldSucceed.Eq'.Int.doubleeq]) +const.ShouldSucceed.Eq'.Int.doubleeq :: Int -> Int -> Bool +const.ShouldSucceed.Eq'.Int.doubleeq + x.r21 y.r22 + = True +AbsBinds +[a.t2] +[d.ShouldSucceed.Eq'.t3] +[(d.ShouldSucceed.Eq'.t4, dfun.ShouldSucceed.Eq'.List)] + {- rec -} + d.ShouldSucceed.Eq'.t4 = ({-dict-} [] [doubleeq.t5]) + doubleeq.t5 :: [a.t2] -> [a.t2] -> Bool + doubleeq.t5 + x.r24 y.r25 + = True +{- rec -} +dfun.ShouldSucceed.Ord'.Int = + ({-dict-} [d.ShouldSucceed.Eq'.t8] [const.ShouldSucceed.Ord'.Int.lt]) +const.ShouldSucceed.Ord'.Int.lt :: Int -> Int -> Bool +const.ShouldSucceed.Ord'.Int.lt + x.r53 y.r54 + = True +d.ShouldSucceed.Eq'.t8 = dfun.ShouldSucceed.Eq'.Int + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc052.hs b/ghc/compiler/tests/typecheck/should_succeed/tc052.hs new file mode 100644 index 0000000..108ef12 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc052.hs @@ -0,0 +1,8 @@ +module ShouldSucceed where + +type A a = B a + +type B c = C + +type C = Int + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc052.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc052.stderr new file mode 100644 index 0000000..72c2f6f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc052.stderr @@ -0,0 +1,3 @@ +Typechecked: + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc053.hs b/ghc/compiler/tests/typecheck/should_succeed/tc053.hs new file mode 100644 index 0000000..865211d --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc053.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +class Eq' a where + deq :: a -> a -> Bool + +instance Eq' Int where + deq x y = True + +instance (Eq' a) => Eq' [a] where + deq (a:as) (b:bs) = if (deq a b) then (deq as bs) else False + +f x = deq x [1] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc053.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc053.stderr new file mode 100644 index 0000000..7b1e699 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc053.stderr @@ -0,0 +1,45 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq'.deq = /\ a.t29 -> \{-classdict-} [] [deq.t30] -> deq.t30 +{- nonrec -} +defm.ShouldSucceed.Eq'.deq = + /\ a.t31 -> + \{-dict-} d.ShouldSucceed.Eq'.t32 -> + (error (a.t31 -> a.t31 -> Bool)) + "No default method for \"ShouldSucceed.Eq'.defm.ShouldSucceed.Eq'.deq\"\n" +{- rec -} +dfun.ShouldSucceed.Eq'.Int = ({-dict-} [] [const.ShouldSucceed.Eq'.Int.deq]) +const.ShouldSucceed.Eq'.Int.deq :: Int -> Int -> Bool +const.ShouldSucceed.Eq'.Int.deq + x.r29 y.r30 + = True +AbsBinds +[a.t13] +[d.ShouldSucceed.Eq'.t14] +[(d.ShouldSucceed.Eq'.t15, dfun.ShouldSucceed.Eq'.List)] + (d.ShouldSucceed.Eq'.t27, d.ShouldSucceed.Eq'.t15) + (ShouldSucceed.Eq'.deq.t26, + ShouldSucceed.Eq'.deq [a.t13] d.ShouldSucceed.Eq'.t27) + (d.ShouldSucceed.Eq'.t28, d.ShouldSucceed.Eq'.t14) + (ShouldSucceed.Eq'.deq.t24, + ShouldSucceed.Eq'.deq a.t13 d.ShouldSucceed.Eq'.t28) + {- rec -} + d.ShouldSucceed.Eq'.t15 = ({-dict-} [] [deq.t16]) + deq.t16 :: [a.t13] -> [a.t13] -> Bool + deq.t16 + (a.r32 : as.r33) (b.r34 : bs.r35) + = if ShouldSucceed.Eq'.deq.t24 a.r32 b.r34 then + ShouldSucceed.Eq'.deq.t26 as.r33 bs.r35 + else + False +AbsBinds [tt5] [d.Num.t8, d.ShouldSucceed.Eq'.t10] [(f.t1, ShouldSucceed.f)] + (fromInt.t7, fromInt tt5 d.Num.t8) + (lit.t6, fromInt.t7 (MkInt 1#)) + (d.ShouldSucceed.Eq'.t9, + dfun.ShouldSucceed.Eq'.List tt5 d.ShouldSucceed.Eq'.t10) + (ShouldSucceed.Eq'.deq.t4, + ShouldSucceed.Eq'.deq [tt5] d.ShouldSucceed.Eq'.t9) + {- nonrec -} + f.t1 :: [tt5] -> Bool + f.t1 x.r63 = ShouldSucceed.Eq'.deq.t4 x.r63 ([lit.t6] (tt5)) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc054.hs b/ghc/compiler/tests/typecheck/should_succeed/tc054.hs new file mode 100644 index 0000000..df9deb0 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc054.hs @@ -0,0 +1,16 @@ +module ShouldSucceed where + +class Eq' a where + doubleeq :: a -> a -> Bool + +class (Eq' a) => Ord' a where + lt :: a -> a -> Bool + +instance Eq' Int where + doubleeq x y = True + +instance Ord' Int where + lt x y = True + +f x y | lt x 1 = True + | otherwise = False diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc054.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc054.stderr new file mode 100644 index 0000000..72d4f4f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc054.stderr @@ -0,0 +1,52 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq'.doubleeq = + /\ a.t16 -> \{-classdict-} [] [doubleeq.t17] -> doubleeq.t17 +{- nonrec -} +defm.ShouldSucceed.Eq'.doubleeq = + /\ a.t18 -> + \{-dict-} d.ShouldSucceed.Eq'.t19 -> + (error (a.t18 -> a.t18 -> Bool)) + "No default method for \"ShouldSucceed.Eq'.defm.ShouldSucceed.Eq'.doubleeq\"\n" +{- nonrec -} +ShouldSucceed.Ord'.lt = + /\ a.t20 -> \{-classdict-} [d.ShouldSucceed.Eq'.t22] [lt.t21] -> lt.t21 +sdsel.ShouldSucceed.Ord'.ShouldSucceed.Eq' = + /\ a.t20 -> + \{-classdict-} [d.ShouldSucceed.Eq'.t22] [lt.t21] -> + d.ShouldSucceed.Eq'.t22 +{- nonrec -} +defm.ShouldSucceed.Ord'.lt = + /\ a.t23 -> + \{-dict-} d.ShouldSucceed.Ord'.t24 -> + (error (a.t23 -> a.t23 -> Bool)) + "No default method for \"ShouldSucceed.Ord'.defm.ShouldSucceed.Ord'.lt\"\n" +{- rec -} +dfun.ShouldSucceed.Eq'.Int = + ({-dict-} [] [const.ShouldSucceed.Eq'.Int.doubleeq]) +const.ShouldSucceed.Eq'.Int.doubleeq :: Int -> Int -> Bool +const.ShouldSucceed.Eq'.Int.doubleeq + x.r22 y.r23 + = True +{- rec -} +dfun.ShouldSucceed.Ord'.Int = + ({-dict-} [d.ShouldSucceed.Eq'.t13] [const.ShouldSucceed.Ord'.Int.lt]) +const.ShouldSucceed.Ord'.Int.lt :: Int -> Int -> Bool +const.ShouldSucceed.Ord'.Int.lt + x.r51 y.r52 + = True +d.ShouldSucceed.Eq'.t13 = dfun.ShouldSucceed.Eq'.Int +AbsBinds +[a.t4, ot3] +[d.Num.t9, d.ShouldSucceed.Ord'.t10] +[(f.t1, ShouldSucceed.f)] + (fromInt.t8, fromInt a.t4 d.Num.t9) + (lit.t7, fromInt.t8 (MkInt 1#)) + (ShouldSucceed.Ord'.lt.t5, + ShouldSucceed.Ord'.lt a.t4 d.ShouldSucceed.Ord'.t10) + {- nonrec -} + f.t1 :: a.t4 -> ot3 -> Bool + f.t1 x.r62 y.r63 + | ShouldSucceed.Ord'.lt.t5 x.r62 lit.t7 = True + | otherwise = False + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc055.hs b/ghc/compiler/tests/typecheck/should_succeed/tc055.hs new file mode 100644 index 0000000..cdbb8f4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc055.hs @@ -0,0 +1,3 @@ +module ShouldSucceed where + +(x,y) = (\p -> p,\q -> q) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc055.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc055.stderr new file mode 100644 index 0000000..ba7f37f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc055.stderr @@ -0,0 +1,8 @@ +Typechecked: +AbsBinds [ot6, ot7] [] [(x.t2, ShouldSucceed.x), (y.t3, ShouldSucceed.y)] + {- nonrec -} + (x.t2, y.t3) :: (ot6 -> ot6, ot7 -> ot7) + (x.t2, y.t3) + = (\ p.r55 -> p.r55, + \ q.r56 -> q.r56) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc056.hs b/ghc/compiler/tests/typecheck/should_succeed/tc056.hs new file mode 100644 index 0000000..f5198f2 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc056.hs @@ -0,0 +1,15 @@ +module ShouldSucceed where + +class Eq' a where + doubleeq :: a -> a -> Bool + +class (Eq' a) => Ord' a where + lt :: a -> a -> Bool + +instance Eq' Int where + doubleeq x y = True + +instance (Eq' a,Eq' a) => Eq' [a] where + doubleeq x y = True + +f x y = doubleeq x [1] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc056.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc056.stderr new file mode 100644 index 0000000..d075a89 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc056.stderr @@ -0,0 +1,57 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq'.doubleeq = + /\ a.t22 -> \{-classdict-} [] [doubleeq.t23] -> doubleeq.t23 +{- nonrec -} +defm.ShouldSucceed.Eq'.doubleeq = + /\ a.t24 -> + \{-dict-} d.ShouldSucceed.Eq'.t25 -> + (error (a.t24 -> a.t24 -> Bool)) + "No default method for \"ShouldSucceed.Eq'.defm.ShouldSucceed.Eq'.doubleeq\"\n" +{- nonrec -} +ShouldSucceed.Ord'.lt = + /\ a.t26 -> \{-classdict-} [d.ShouldSucceed.Eq'.t28] [lt.t27] -> lt.t27 +sdsel.ShouldSucceed.Ord'.ShouldSucceed.Eq' = + /\ a.t26 -> + \{-classdict-} [d.ShouldSucceed.Eq'.t28] [lt.t27] -> + d.ShouldSucceed.Eq'.t28 +{- nonrec -} +defm.ShouldSucceed.Ord'.lt = + /\ a.t29 -> + \{-dict-} d.ShouldSucceed.Ord'.t30 -> + (error (a.t29 -> a.t29 -> Bool)) + "No default method for \"ShouldSucceed.Ord'.defm.ShouldSucceed.Ord'.lt\"\n" +{- rec -} +dfun.ShouldSucceed.Eq'.Int = + ({-dict-} [] [const.ShouldSucceed.Eq'.Int.doubleeq]) +const.ShouldSucceed.Eq'.Int.doubleeq :: Int -> Int -> Bool +const.ShouldSucceed.Eq'.Int.doubleeq + x.r31 y.r32 + = True +AbsBinds +[a.t15] +[d.ShouldSucceed.Eq'.t16, d.ShouldSucceed.Eq'.t17] +[(d.ShouldSucceed.Eq'.t18, dfun.ShouldSucceed.Eq'.List)] + {- rec -} + d.ShouldSucceed.Eq'.t18 = ({-dict-} [] [doubleeq.t19]) + doubleeq.t19 :: [a.t15] -> [a.t15] -> Bool + doubleeq.t19 + x.r34 y.r35 + = True +AbsBinds +[tt6, ot3] +[d.Num.t9, d.ShouldSucceed.Eq'.t11] +[(f.t1, ShouldSucceed.f)] + (fromInt.t8, fromInt tt6 d.Num.t9) + (lit.t7, fromInt.t8 (MkInt 1#)) + (d.ShouldSucceed.Eq'.t12, d.ShouldSucceed.Eq'.t11) + (d.ShouldSucceed.Eq'.t10, + dfun.ShouldSucceed.Eq'.List tt6 + [d.ShouldSucceed.Eq'.t11, d.ShouldSucceed.Eq'.t12]) + (ShouldSucceed.Eq'.doubleeq.t5, + ShouldSucceed.Eq'.doubleeq [tt6] d.ShouldSucceed.Eq'.t10) + {- nonrec -} + f.t1 :: [tt6] -> ot3 -> Bool + f.t1 x.r63 y.r64 + = ShouldSucceed.Eq'.doubleeq.t5 x.r63 ([lit.t7] (tt6)) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc057.hi b/ghc/compiler/tests/typecheck/should_succeed/tc057.hi new file mode 100644 index 0000000..3613dfa --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc057.hi @@ -0,0 +1,7 @@ +interface ShouldSucceed where { +class Eq' a where { deq } +instance +instance Eq' a => +dand :: Bool -> Bool -> Bool +f :: Eq' t93 => t93 -> t93 -> Bool +} diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc057.hs b/ghc/compiler/tests/typecheck/should_succeed/tc057.hs new file mode 100644 index 0000000..cc561b9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc057.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +-- See also tcfail060.hs + +class Eq' a where + deq :: a -> a -> Bool + +instance Eq' Int where + deq x y = True + +instance (Eq' a) => Eq' [a] where + deq (a:as) (b:bs) = dand (f a b) (f as bs) + +dand True True = True +dand x y = False + +f :: Eq' a => a -> a -> Bool +f p q = dand (deq p q) (deq [1::Int] [2::Int]) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc057.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc057.stderr new file mode 100644 index 0000000..accfaee --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc057.stderr @@ -0,0 +1,58 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq'.deq = /\ a.t38 -> \{-classdict-} [] [deq.t39] -> deq.t39 +{- nonrec -} +defm.ShouldSucceed.Eq'.deq = + /\ a.t40 -> + \{-dict-} d.ShouldSucceed.Eq'.t41 -> + (error (a.t40 -> a.t40 -> Bool)) + "No default method for \"ShouldSucceed.Eq'.defm.ShouldSucceed.Eq'.deq\"\n" +{- rec -} +dfun.ShouldSucceed.Eq'.Int = ({-dict-} [] [const.ShouldSucceed.Eq'.Int.deq]) +const.ShouldSucceed.Eq'.Int.deq :: Int -> Int -> Bool +const.ShouldSucceed.Eq'.Int.deq + x.r30 y.r31 + = True +AbsBinds +[a.t22] +[d.ShouldSucceed.Eq'.t23] +[(d.ShouldSucceed.Eq'.t24, dfun.ShouldSucceed.Eq'.List)] + (d.ShouldSucceed.Eq'.t36, d.ShouldSucceed.Eq'.t24) + (ShouldSucceed.f.t35, ShouldSucceed.f [a.t22] d.ShouldSucceed.Eq'.t36) + (d.ShouldSucceed.Eq'.t37, d.ShouldSucceed.Eq'.t23) + (ShouldSucceed.f.t33, ShouldSucceed.f a.t22 d.ShouldSucceed.Eq'.t37) + {- rec -} + d.ShouldSucceed.Eq'.t24 = ({-dict-} [] [deq.t25]) + deq.t25 :: [a.t22] -> [a.t22] -> Bool + deq.t25 + (a.r33 : as.r34) (b.r35 : bs.r36) + = ShouldSucceed.dand + (ShouldSucceed.f.t33 a.r33 b.r35) + (ShouldSucceed.f.t35 as.r34 bs.r36) +lit.t17 = MkInt 2# +lit.t15 = MkInt 1# +d.ShouldSucceed.Eq'.t43 = dfun.ShouldSucceed.Eq'.Int +d.ShouldSucceed.Eq'.t42 = + dfun.ShouldSucceed.Eq'.List Int d.ShouldSucceed.Eq'.t43 +ShouldSucceed.Eq'.deq.t13 = ShouldSucceed.Eq'.deq [Int] d.ShouldSucceed.Eq'.t42 +AbsBinds [] [] [(dand.t1, ShouldSucceed.dand)] + {- nonrec -} + dand.t1 :: Bool -> Bool -> Bool + dand.t1 + True True + = True + dand.t1 + x.r65 y.r66 + = False +AbsBinds [a.t10] [d.ShouldSucceed.Eq'.t7] [(f.t5, ShouldSucceed.f)] + (d.ShouldSucceed.Eq'.t19, d.ShouldSucceed.Eq'.t7) + (ShouldSucceed.Eq'.deq.t11, + ShouldSucceed.Eq'.deq a.t10 d.ShouldSucceed.Eq'.t19) + {- nonrec -} + f.t5 :: a.t10 -> a.t10 -> Bool + f.t5 p.r67 q.r68 + = ShouldSucceed.dand + (ShouldSucceed.Eq'.deq.t11 p.r67 q.r68) + (ShouldSucceed.Eq'.deq.t13 + ([lit.t15] (Int)) ([lit.t17] (Int))) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc058.hs b/ghc/compiler/tests/typecheck/should_succeed/tc058.hs new file mode 100644 index 0000000..7df1f3b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc058.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +class Eq2 a where + doubleeq :: a -> a -> Bool + +class (Eq2 a) => Ord2 a where + lt :: a -> a -> Bool + +instance Eq2 Int where + doubleeq x y = True + +instance Ord2 Int where + lt x y = True + +instance (Eq2 a,Ord2 a) => Eq2 [a] where + doubleeq xs ys = True + +f x y = doubleeq x [1] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc058.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc058.stderr new file mode 100644 index 0000000..a60f7a4 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc058.stderr @@ -0,0 +1,66 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq2.doubleeq = + /\ a.t25 -> \{-classdict-} [] [doubleeq.t26] -> doubleeq.t26 +{- nonrec -} +defm.ShouldSucceed.Eq2.doubleeq = + /\ a.t27 -> + \{-dict-} d.ShouldSucceed.Eq2.t28 -> + (error (a.t27 -> a.t27 -> Bool)) + "No default method for \"ShouldSucceed.Eq2.defm.ShouldSucceed.Eq2.doubleeq\"\n" +{- nonrec -} +ShouldSucceed.Ord2.lt = + /\ a.t29 -> \{-classdict-} [d.ShouldSucceed.Eq2.t31] [lt.t30] -> lt.t30 +sdsel.ShouldSucceed.Ord2.ShouldSucceed.Eq2 = + /\ a.t29 -> + \{-classdict-} [d.ShouldSucceed.Eq2.t31] [lt.t30] -> + d.ShouldSucceed.Eq2.t31 +{- nonrec -} +defm.ShouldSucceed.Ord2.lt = + /\ a.t32 -> + \{-dict-} d.ShouldSucceed.Ord2.t33 -> + (error (a.t32 -> a.t32 -> Bool)) + "No default method for \"ShouldSucceed.Ord2.defm.ShouldSucceed.Ord2.lt\"\n" +{- rec -} +dfun.ShouldSucceed.Eq2.Int = + ({-dict-} [] [const.ShouldSucceed.Eq2.Int.doubleeq]) +const.ShouldSucceed.Eq2.Int.doubleeq :: Int -> Int -> Bool +const.ShouldSucceed.Eq2.Int.doubleeq + x.r31 y.r32 + = True +AbsBinds +[a.t15] +[d.ShouldSucceed.Eq2.t16, d.ShouldSucceed.Ord2.t17] +[(d.ShouldSucceed.Eq2.t18, dfun.ShouldSucceed.Eq2.List)] + {- rec -} + d.ShouldSucceed.Eq2.t18 = ({-dict-} [] [doubleeq.t19]) + doubleeq.t19 :: [a.t15] -> [a.t15] -> Bool + doubleeq.t19 + xs.r34 ys.r35 + = True +{- rec -} +dfun.ShouldSucceed.Ord2.Int = + ({-dict-} [d.ShouldSucceed.Eq2.t22] [const.ShouldSucceed.Ord2.Int.lt]) +const.ShouldSucceed.Ord2.Int.lt :: Int -> Int -> Bool +const.ShouldSucceed.Ord2.Int.lt + x.r54 y.r55 + = True +d.ShouldSucceed.Eq2.t22 = dfun.ShouldSucceed.Eq2.Int +AbsBinds +[tt6, ot3] +[d.Num.t9, d.ShouldSucceed.Ord2.t12] +[(f.t1, ShouldSucceed.f)] + (d.ShouldSucceed.Eq2.t11, + sdsel.ShouldSucceed.Ord2.ShouldSucceed.Eq2 tt6 d.ShouldSucceed.Ord2.t12) + (fromInt.t8, fromInt tt6 d.Num.t9) + (lit.t7, fromInt.t8 (MkInt 1#)) + (d.ShouldSucceed.Eq2.t10, + dfun.ShouldSucceed.Eq2.List tt6 + [d.ShouldSucceed.Eq2.t11, d.ShouldSucceed.Ord2.t12]) + (ShouldSucceed.Eq2.doubleeq.t5, + ShouldSucceed.Eq2.doubleeq [tt6] d.ShouldSucceed.Eq2.t10) + {- nonrec -} + f.t1 :: [tt6] -> ot3 -> Bool + f.t1 x.r65 y.r66 + = ShouldSucceed.Eq2.doubleeq.t5 x.r65 ([lit.t7] (tt6)) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc059.hs b/ghc/compiler/tests/typecheck/should_succeed/tc059.hs new file mode 100644 index 0000000..f0faac8 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc059.hs @@ -0,0 +1,15 @@ +module ShouldSucceed where + +class Eq2 a where + deq :: a -> a -> Bool + foo :: a -> a + +instance Eq2 Int where + deq x y = True + foo x = x + +instance (Eq2 a) => Eq2 [a] where + deq (a:as) (b:bs) = if (deq a (foo b)) then (deq as (foo bs)) else False + foo x = x + +f x = deq x [1] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc059.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc059.stderr new file mode 100644 index 0000000..14098b6 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc059.stderr @@ -0,0 +1,70 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq2.deq = + /\ a.t38 -> \{-classdict-} [] [deq.t39 foo.t40] -> deq.t39 +ShouldSucceed.Eq2.foo = + /\ a.t38 -> \{-classdict-} [] [deq.t39 foo.t40] -> foo.t40 +{- nonrec -} +defm.ShouldSucceed.Eq2.deq = + /\ a.t41 -> + \{-dict-} d.ShouldSucceed.Eq2.t42 -> + (error (a.t41 -> a.t41 -> Bool)) + "No default method for \"ShouldSucceed.Eq2.defm.ShouldSucceed.Eq2.deq\"\n" +defm.ShouldSucceed.Eq2.foo = + /\ a.t43 -> + \{-dict-} d.ShouldSucceed.Eq2.t44 -> + (error (a.t43 -> a.t43)) + "No default method for \"ShouldSucceed.Eq2.defm.ShouldSucceed.Eq2.foo\"\n" +{- rec -} +dfun.ShouldSucceed.Eq2.Int = + ({-dict-} + [] + [const.ShouldSucceed.Eq2.Int.deq, const.ShouldSucceed.Eq2.Int.foo]) +const.ShouldSucceed.Eq2.Int.deq :: Int -> Int -> Bool +const.ShouldSucceed.Eq2.Int.deq + x.r29 y.r30 + = True +const.ShouldSucceed.Eq2.Int.foo :: Int -> Int +const.ShouldSucceed.Eq2.Int.foo + x.r31 = x.r31 +AbsBinds +[a.t14] +[d.ShouldSucceed.Eq2.t15] +[(d.ShouldSucceed.Eq2.t16, dfun.ShouldSucceed.Eq2.List)] + (d.ShouldSucceed.Eq2.t34, d.ShouldSucceed.Eq2.t16) + (ShouldSucceed.Eq2.foo.t32, + ShouldSucceed.Eq2.foo [a.t14] d.ShouldSucceed.Eq2.t34) + (d.ShouldSucceed.Eq2.t35, d.ShouldSucceed.Eq2.t34) + (ShouldSucceed.Eq2.deq.t30, + ShouldSucceed.Eq2.deq [a.t14] d.ShouldSucceed.Eq2.t35) + (d.ShouldSucceed.Eq2.t36, d.ShouldSucceed.Eq2.t15) + (ShouldSucceed.Eq2.foo.t28, + ShouldSucceed.Eq2.foo a.t14 d.ShouldSucceed.Eq2.t36) + (d.ShouldSucceed.Eq2.t37, d.ShouldSucceed.Eq2.t36) + (ShouldSucceed.Eq2.deq.t26, + ShouldSucceed.Eq2.deq a.t14 d.ShouldSucceed.Eq2.t37) + {- rec -} + d.ShouldSucceed.Eq2.t16 = ({-dict-} [] [deq.t17, foo.t18]) + deq.t17 :: [a.t14] -> [a.t14] -> Bool + deq.t17 + (a.r33 : as.r34) (b.r35 : bs.r36) + = if ShouldSucceed.Eq2.deq.t26 + a.r33 (ShouldSucceed.Eq2.foo.t28 b.r35) then + ShouldSucceed.Eq2.deq.t30 + as.r34 (ShouldSucceed.Eq2.foo.t32 bs.r36) + else + False + foo.t18 :: [a.t14] -> [a.t14] + foo.t18 + x.r37 = x.r37 +AbsBinds [tt5] [d.Num.t8, d.ShouldSucceed.Eq2.t10] [(f.t1, ShouldSucceed.f)] + (fromInt.t7, fromInt tt5 d.Num.t8) + (lit.t6, fromInt.t7 (MkInt 1#)) + (d.ShouldSucceed.Eq2.t9, + dfun.ShouldSucceed.Eq2.List tt5 d.ShouldSucceed.Eq2.t10) + (ShouldSucceed.Eq2.deq.t4, + ShouldSucceed.Eq2.deq [tt5] d.ShouldSucceed.Eq2.t9) + {- nonrec -} + f.t1 :: [tt5] -> Bool + f.t1 x.r65 = ShouldSucceed.Eq2.deq.t4 x.r65 ([lit.t6] (tt5)) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc060.hs b/ghc/compiler/tests/typecheck/should_succeed/tc060.hs new file mode 100644 index 0000000..6ae0ca9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc060.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +class Eq2 a where + deq :: a -> a -> Bool + +instance (Eq2 a) => Eq2 [a] where + deq (a:as) (b:bs) = if (deq a b) then (deq as bs) else False + + +instance Eq2 Int where + deq x y = True + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc060.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc060.stderr new file mode 100644 index 0000000..8027cbe --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc060.stderr @@ -0,0 +1,35 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq2.deq = /\ a.t18 -> \{-classdict-} [] [deq.t19] -> deq.t19 +{- nonrec -} +defm.ShouldSucceed.Eq2.deq = + /\ a.t20 -> + \{-dict-} d.ShouldSucceed.Eq2.t21 -> + (error (a.t20 -> a.t20 -> Bool)) + "No default method for \"ShouldSucceed.Eq2.defm.ShouldSucceed.Eq2.deq\"\n" +{- rec -} +dfun.ShouldSucceed.Eq2.Int = ({-dict-} [] [const.ShouldSucceed.Eq2.Int.deq]) +const.ShouldSucceed.Eq2.Int.deq :: Int -> Int -> Bool +const.ShouldSucceed.Eq2.Int.deq + x.r28 y.r29 + = True +AbsBinds +[a.t2] +[d.ShouldSucceed.Eq2.t3] +[(d.ShouldSucceed.Eq2.t4, dfun.ShouldSucceed.Eq2.List)] + (d.ShouldSucceed.Eq2.t16, d.ShouldSucceed.Eq2.t4) + (ShouldSucceed.Eq2.deq.t15, + ShouldSucceed.Eq2.deq [a.t2] d.ShouldSucceed.Eq2.t16) + (d.ShouldSucceed.Eq2.t17, d.ShouldSucceed.Eq2.t3) + (ShouldSucceed.Eq2.deq.t13, + ShouldSucceed.Eq2.deq a.t2 d.ShouldSucceed.Eq2.t17) + {- rec -} + d.ShouldSucceed.Eq2.t4 = ({-dict-} [] [deq.t5]) + deq.t5 :: [a.t2] -> [a.t2] -> Bool + deq.t5 + (a.r31 : as.r32) (b.r33 : bs.r34) + = if ShouldSucceed.Eq2.deq.t13 a.r31 b.r33 then + ShouldSucceed.Eq2.deq.t15 as.r32 bs.r34 + else + False + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc061.hs b/ghc/compiler/tests/typecheck/should_succeed/tc061.hs new file mode 100644 index 0000000..25a8b65 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc061.hs @@ -0,0 +1,11 @@ +module ShouldSucceed where + +class Eq1 a where + deq :: a -> a -> Bool + +instance (Eq1 a) => Eq1 [a] where + deq (a:as) (b:bs) = deq a b + +instance Eq1 Int where + deq x y = True + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc061.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc061.stderr new file mode 100644 index 0000000..90eb6c1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc061.stderr @@ -0,0 +1,29 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq1.deq = /\ a.t15 -> \{-classdict-} [] [deq.t16] -> deq.t16 +{- nonrec -} +defm.ShouldSucceed.Eq1.deq = + /\ a.t17 -> + \{-dict-} d.ShouldSucceed.Eq1.t18 -> + (error (a.t17 -> a.t17 -> Bool)) + "No default method for \"ShouldSucceed.Eq1.defm.ShouldSucceed.Eq1.deq\"\n" +{- rec -} +dfun.ShouldSucceed.Eq1.Int = ({-dict-} [] [const.ShouldSucceed.Eq1.Int.deq]) +const.ShouldSucceed.Eq1.Int.deq :: Int -> Int -> Bool +const.ShouldSucceed.Eq1.Int.deq + x.r28 y.r29 + = True +AbsBinds +[a.t2] +[d.ShouldSucceed.Eq1.t3] +[(d.ShouldSucceed.Eq1.t4, dfun.ShouldSucceed.Eq1.List)] + (d.ShouldSucceed.Eq1.t14, d.ShouldSucceed.Eq1.t3) + (ShouldSucceed.Eq1.deq.t13, + ShouldSucceed.Eq1.deq a.t2 d.ShouldSucceed.Eq1.t14) + {- rec -} + d.ShouldSucceed.Eq1.t4 = ({-dict-} [] [deq.t5]) + deq.t5 :: [a.t2] -> [a.t2] -> Bool + deq.t5 + (a.r31 : as.r32) (b.r33 : bs.r34) + = ShouldSucceed.Eq1.deq.t13 a.r31 b.r33 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc062.hs b/ghc/compiler/tests/typecheck/should_succeed/tc062.hs new file mode 100644 index 0000000..fde6c4b --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc062.hs @@ -0,0 +1,12 @@ +module ShouldSucceed where + +class Eq1 a where + deq :: a -> a -> Bool + +instance Eq1 Int where + deq x y = True + +instance (Eq1 a) => Eq1 [a] where + deq (a:as) (b:bs) = if (deq a b) then (deq as bs) else False + +f x (y:ys) = deq x ys diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc062.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc062.stderr new file mode 100644 index 0000000..59cd449 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc062.stderr @@ -0,0 +1,44 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Eq1.deq = /\ a.t28 -> \{-classdict-} [] [deq.t29] -> deq.t29 +{- nonrec -} +defm.ShouldSucceed.Eq1.deq = + /\ a.t30 -> + \{-dict-} d.ShouldSucceed.Eq1.t31 -> + (error (a.t30 -> a.t30 -> Bool)) + "No default method for \"ShouldSucceed.Eq1.defm.ShouldSucceed.Eq1.deq\"\n" +{- rec -} +dfun.ShouldSucceed.Eq1.Int = ({-dict-} [] [const.ShouldSucceed.Eq1.Int.deq]) +const.ShouldSucceed.Eq1.Int.deq :: Int -> Int -> Bool +const.ShouldSucceed.Eq1.Int.deq + x.r29 y.r30 + = True +AbsBinds +[a.t12] +[d.ShouldSucceed.Eq1.t13] +[(d.ShouldSucceed.Eq1.t14, dfun.ShouldSucceed.Eq1.List)] + (d.ShouldSucceed.Eq1.t26, d.ShouldSucceed.Eq1.t14) + (ShouldSucceed.Eq1.deq.t25, + ShouldSucceed.Eq1.deq [a.t12] d.ShouldSucceed.Eq1.t26) + (d.ShouldSucceed.Eq1.t27, d.ShouldSucceed.Eq1.t13) + (ShouldSucceed.Eq1.deq.t23, + ShouldSucceed.Eq1.deq a.t12 d.ShouldSucceed.Eq1.t27) + {- rec -} + d.ShouldSucceed.Eq1.t14 = ({-dict-} [] [deq.t15]) + deq.t15 :: [a.t12] -> [a.t12] -> Bool + deq.t15 + (a.r32 : as.r33) (b.r34 : bs.r35) + = if ShouldSucceed.Eq1.deq.t23 a.r32 b.r34 then + ShouldSucceed.Eq1.deq.t25 as.r33 bs.r35 + else + False +AbsBinds [tt5] [d.ShouldSucceed.Eq1.t9] [(f.t1, ShouldSucceed.f)] + (d.ShouldSucceed.Eq1.t8, + dfun.ShouldSucceed.Eq1.List tt5 d.ShouldSucceed.Eq1.t9) + (ShouldSucceed.Eq1.deq.t7, + ShouldSucceed.Eq1.deq [tt5] d.ShouldSucceed.Eq1.t8) + {- nonrec -} + f.t1 :: [tt5] -> [tt5] -> Bool + f.t1 x.r63 (y.r64 : ys.r65) + = ShouldSucceed.Eq1.deq.t7 x.r63 ys.r65 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc063.hs b/ghc/compiler/tests/typecheck/should_succeed/tc063.hs new file mode 100644 index 0000000..36affbf --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc063.hs @@ -0,0 +1,18 @@ +module ShouldSucceed where + +data X a = Tag a + +class Reps r where + f :: r -> r -> r + +instance Reps (X q) where +-- f (Tag x) (Tag y) = Tag y + f x y = y + +instance Reps Bool where + f True True = True + f x y = False + +g x = f x x + + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc063.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc063.stderr new file mode 100644 index 0000000..24354a9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc063.stderr @@ -0,0 +1,35 @@ +Typechecked: +{- nonrec -} +ShouldSucceed.Reps.f = /\ r.t13 -> \{-classdict-} [] [f.t14] -> f.t14 +{- nonrec -} +defm.ShouldSucceed.Reps.f = + /\ r.t15 -> + \{-dict-} d.ShouldSucceed.Reps.t16 -> + (error (r.t15 -> r.t15 -> r.t15)) + "No default method for \"ShouldSucceed.Reps.defm.ShouldSucceed.Reps.f\"\n" +{- rec -} +dfun.ShouldSucceed.Reps.Bool = ({-dict-} [] [const.ShouldSucceed.Reps.Bool.f]) +const.ShouldSucceed.Reps.Bool.f :: Bool -> Bool -> Bool +const.ShouldSucceed.Reps.Bool.f + True True + = True +const.ShouldSucceed.Reps.Bool.f + x.r50 y.r51 + = False +AbsBinds +[q.t8] +[] +[(d.ShouldSucceed.Reps.t9, dfun.ShouldSucceed.Reps.ShouldSucceed.X)] + {- rec -} + d.ShouldSucceed.Reps.t9 = ({-dict-} [] [f.t10]) + f.t10 :: + ShouldSucceed.X q.t8 -> ShouldSucceed.X q.t8 -> ShouldSucceed.X q.t8 + f.t10 + x.r53 y.r54 + = y.r54 +AbsBinds [r.t3] [d.ShouldSucceed.Reps.t5] [(g.t1, ShouldSucceed.g)] + (ShouldSucceed.Reps.f.t4, ShouldSucceed.Reps.f r.t3 d.ShouldSucceed.Reps.t5) + {- nonrec -} + g.t1 :: r.t3 -> r.t3 + g.t1 x.r64 = ShouldSucceed.Reps.f.t4 x.r64 x.r64 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc064.hs b/ghc/compiler/tests/typecheck/should_succeed/tc064.hs new file mode 100644 index 0000000..18aecb0 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc064.hs @@ -0,0 +1,7 @@ +module ShouldSucceed where + +data Boolean = FF | TT + +idb :: Boolean -> Boolean +idb x = x + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc064.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc064.stderr new file mode 100644 index 0000000..1e0adaf --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc064.stderr @@ -0,0 +1,7 @@ +Typechecked: +AbsBinds [] [] [(idb.t1, ShouldSucceed.idb)] + {- nonrec -} + idb.t1 :: ShouldSucceed.Boolean -> ShouldSucceed.Boolean + idb.t1 + x.r57 = x.r57 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc065.hs b/ghc/compiler/tests/typecheck/should_succeed/tc065.hs new file mode 100644 index 0000000..96eb441 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc065.hs @@ -0,0 +1,105 @@ +module Digraphs where + +import TheUtils + +data Digraph vertex = MkDigraph [vertex] + +type Edge vertex = (vertex, vertex) +type Cycle vertex = [vertex] + +mkDigraph = MkDigraph + +stronglyConnComp :: Eq vertex => [Edge vertex] -> [vertex] -> [[vertex]] +stronglyConnComp es vs + = snd (span_tree (new_range reversed_edges) + ([],[]) + ( snd (dfs (new_range es) ([],[]) vs) ) + ) + where + reversed_edges = map swap es + + swap :: Edge v -> Edge v + swap (x,y) = (y, x) + + new_range [] w = [] + new_range ((x,y):xys) w + = if x==w + then (y : (new_range xys w)) + else (new_range xys w) + + span_tree r (vs,ns) [] = (vs,ns) + span_tree r (vs,ns) (x:xs) + | x `elem` vs = span_tree r (vs,ns) xs + | otherwise = span_tree r (vs',(x:ns'):ns) xs + where + (vs',ns') = dfs r (x:vs,[]) (r x) + +dfs r (vs,ns) [] = (vs,ns) +dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs + | otherwise = dfs r (vs',(x:ns')++ns) xs + where + (vs',ns') = dfs r (x:vs,[]) (r x) + + +isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool +isCyclic edges [v] = (v,v) `elem` edges +isCyclic edges vs = True + + +topSort :: (Eq vertex) => [Edge vertex] -> [vertex] + -> MaybeErr [vertex] [[vertex]] + + +topSort edges vertices + = case cycles of + [] -> Succeeded [v | [v] <- singletons] + _ -> Failed cycles + where + sccs = stronglyConnComp edges vertices + (cycles, singletons) = partition (isCyclic edges) sccs + + +type FlattenedDependencyInfo vertex name code + = [(vertex, Set name, Set name, code)] + +mkVertices :: FlattenedDependencyInfo vertex name code -> [vertex] +mkVertices info = [ vertex | (vertex,_,_,_) <- info] + +mkEdges :: (Eq vertex, Ord name) => + [vertex] + -> FlattenedDependencyInfo vertex name code + -> [Edge vertex] + +mkEdges vertices flat_info + = [ (source_vertex, target_vertex) + | (source_vertex, _, used_names, _) <- flat_info, + target_name <- setToList used_names, + target_vertex <- vertices_defining target_name flat_info + ] + where + vertices_defining name flat_info + = [ vertex | (vertex, names_defined, _, _) <- flat_info, + name `elementOf` names_defined + ] + +lookupVertex :: (Eq vertex, Ord name) => + FlattenedDependencyInfo vertex name code + -> vertex + -> code + +lookupVertex flat_info vertex + = head code_list + where + code_list = [ code | (vertex',_,_,code) <- flat_info, vertex == vertex'] + + +isRecursiveCycle :: (Eq vertex) => Cycle vertex -> [Edge vertex] -> Bool +isRecursiveCycle [vertex] edges = (vertex, vertex) `elem` edges +isRecursiveCycle cycle edges = True + + + +-- may go to TheUtils + +data MaybeErr a b = Succeeded a | Failed b + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc065.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc065.stderr new file mode 100644 index 0000000..10c73c1 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc065.stderr @@ -0,0 +1,4 @@ +"tc065.hs", line 5: import directory list is: + .:/users/fp/grasp/ghc/imports:/users/fp/grasp/ghc/./driver/.././lib/prelude:/users/fp/grasp/ghc/./driver/.././runtimes/standard + Can't find .hi file for module `TheUtils'; on input: \n +ghc2: execution of the Haskell parser had trouble diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc066.hs b/ghc/compiler/tests/typecheck/should_succeed/tc066.hs new file mode 100644 index 0000000..7c92951 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc066.hs @@ -0,0 +1,4 @@ +module ShouldSucceed where + +data Pair a b = MkPair a b +f x = [ a | (MkPair c a) <- x ] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc066.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc066.stderr new file mode 100644 index 0000000..4400cdf --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc066.stderr @@ -0,0 +1,6 @@ +Typechecked: +AbsBinds [a.t5, b.t6] [] [(f.t1, ShouldSucceed.f)] + {- nonrec -} + f.t1 :: [ShouldSucceed.Pair a.t5 b.t6] -> [b.t6] + f.t1 x.r58 = [ a.r59 | (ShouldSucceed.MkPair c.r60 a.r59) <- x.r58 ] + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc067.hs b/ghc/compiler/tests/typecheck/should_succeed/tc067.hs new file mode 100644 index 0000000..59df103 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc067.hs @@ -0,0 +1,4 @@ +module ShouldSucc where + +f [] = [] +f (x:xs) = x : (f xs) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc067.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc067.stderr new file mode 100644 index 0000000..8922b32 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc067.stderr @@ -0,0 +1,8 @@ +Typechecked: +AbsBinds [tt3] [] [(f.t1, ShouldSucc.f)] + {- rec -} + f.t1 :: [tt3] -> [tt3] + f.t1 [] = [] (tt3) + f.t1 (x.r54 : xs.r55) + = ((:) tt3) x.r54 (f.t1 xs.r55) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc068.hs b/ghc/compiler/tests/typecheck/should_succeed/tc068.hs new file mode 100644 index 0000000..01f2d87 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc068.hs @@ -0,0 +1,18 @@ +module ShouldSucc where + +data T a = D (B a) | C +data B b = X | Y b + +instance (Eq a) => Eq (T a) where + (D x) == (D y) = x == y + C == C = True + a == b = False + + a /= b = not (a == b) + +instance (Eq b) => Eq (B b) where + X == X = True + (Y a) == (Y b) = a == b + a == b = False + + a /= b = not (a == b) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc068.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc068.stderr new file mode 100644 index 0000000..eb4c9c9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc068.stderr @@ -0,0 +1,45 @@ +Typechecked: +AbsBinds [b.t0] [d.Eq.t1] [(d.Eq.t2, dfun.Eq.ShouldSucc.B)] + (d.Eq.t21, d.Eq.t1) + (==.t12, (==) b.t0 d.Eq.t21) + (d.Eq.t22, d.Eq.t2) + (==.t19, (==) (ShouldSucc.B b.t0) d.Eq.t22) + {- rec -} + d.Eq.t2 = ({-dict-} [] [==.t3, /=.t4]) + (==.t3) :: ShouldSucc.B b.t0 -> ShouldSucc.B b.t0 -> Bool + (==.t3) + ShouldSucc.X ShouldSucc.X + = True + (==.t3) + (ShouldSucc.Y a.r17) (ShouldSucc.Y b.r18) + = a.r17 ==.t12 b.r18 + (==.t3) + a.r19 b.r20 + = False + (/=.t4) :: ShouldSucc.B b.t0 -> ShouldSucc.B b.t0 -> Bool + (/=.t4) + a.r21 b.r22 + = not (a.r21 ==.t19 b.r22) +AbsBinds [a.t23] [d.Eq.t24] [(d.Eq.t25, dfun.Eq.ShouldSucc.T)] + (d.Eq.t45, d.Eq.t24) + (d.Eq.t44, dfun.Eq.ShouldSucc.B a.t23 d.Eq.t45) + (==.t33, (==) (ShouldSucc.B a.t23) d.Eq.t44) + (d.Eq.t46, d.Eq.t25) + (==.t42, (==) (ShouldSucc.T a.t23) d.Eq.t46) + {- rec -} + d.Eq.t25 = ({-dict-} [] [==.t26, /=.t27]) + (==.t26) :: ShouldSucc.T a.t23 -> ShouldSucc.T a.t23 -> Bool + (==.t26) + (ShouldSucc.D x.r24) (ShouldSucc.D y.r25) + = x.r24 ==.t33 y.r25 + (==.t26) + ShouldSucc.C ShouldSucc.C + = True + (==.t26) + a.r26 b.r27 + = False + (/=.t27) :: ShouldSucc.T a.t23 -> ShouldSucc.T a.t23 -> Bool + (/=.t27) + a.r28 b.r29 + = not (a.r28 ==.t42 b.r29) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc069.hs b/ghc/compiler/tests/typecheck/should_succeed/tc069.hs new file mode 100644 index 0000000..115af27 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc069.hs @@ -0,0 +1,4 @@ + + +x = 'a' +(y:ys) = ['a','b','c'] where p = x diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc069.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc069.stderr new file mode 100644 index 0000000..df629a9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc069.stderr @@ -0,0 +1,16 @@ +Typechecked: +AbsBinds [] [] [(x.t1, Main.x)] + {- nonrec -} + x.t1 :: Char + x.t1 = 'a' +AbsBinds [] [] [(y.t4, Main.y), (ys.t5, Main.ys)] + {- nonrec -} + (y.t4 : ys.t5) :: [Char] + (y.t4 : ys.t5) = ['a', 'b', 'c'] (Char) + where + AbsBinds [] [] [(p.t8, p.r56)] + {- nonrec -} + p.t8 :: Char + p.t8 = Main.x + {- nonrec -} + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc070.hs b/ghc/compiler/tests/typecheck/should_succeed/tc070.hs new file mode 100644 index 0000000..3ef920f --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc070.hs @@ -0,0 +1,7 @@ + +data Boolean = FF | TT + + +idb :: Boolean -> Boolean +idb x = x + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc070.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc070.stderr new file mode 100644 index 0000000..16a0ba9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc070.stderr @@ -0,0 +1,7 @@ +Typechecked: +AbsBinds [] [] [(idb.t1, Main.idb)] + {- nonrec -} + idb.t1 :: Main.Boolean -> Main.Boolean + idb.t1 + x.r57 = x.r57 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc073.hs b/ghc/compiler/tests/typecheck/should_succeed/tc073.hs new file mode 100644 index 0000000..ea4cb74 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc073.hs @@ -0,0 +1,5 @@ + +module ShouldSucc where + +f [] = [] +f (x:xs) = x : (f xs) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc073.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc073.stderr new file mode 100644 index 0000000..8922b32 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc073.stderr @@ -0,0 +1,8 @@ +Typechecked: +AbsBinds [tt3] [] [(f.t1, ShouldSucc.f)] + {- rec -} + f.t1 :: [tt3] -> [tt3] + f.t1 [] = [] (tt3) + f.t1 (x.r54 : xs.r55) + = ((:) tt3) x.r54 (f.t1 xs.r55) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc074.hs b/ghc/compiler/tests/typecheck/should_succeed/tc074.hs new file mode 100644 index 0000000..01f2d87 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc074.hs @@ -0,0 +1,18 @@ +module ShouldSucc where + +data T a = D (B a) | C +data B b = X | Y b + +instance (Eq a) => Eq (T a) where + (D x) == (D y) = x == y + C == C = True + a == b = False + + a /= b = not (a == b) + +instance (Eq b) => Eq (B b) where + X == X = True + (Y a) == (Y b) = a == b + a == b = False + + a /= b = not (a == b) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc074.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc074.stderr new file mode 100644 index 0000000..eb4c9c9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc074.stderr @@ -0,0 +1,45 @@ +Typechecked: +AbsBinds [b.t0] [d.Eq.t1] [(d.Eq.t2, dfun.Eq.ShouldSucc.B)] + (d.Eq.t21, d.Eq.t1) + (==.t12, (==) b.t0 d.Eq.t21) + (d.Eq.t22, d.Eq.t2) + (==.t19, (==) (ShouldSucc.B b.t0) d.Eq.t22) + {- rec -} + d.Eq.t2 = ({-dict-} [] [==.t3, /=.t4]) + (==.t3) :: ShouldSucc.B b.t0 -> ShouldSucc.B b.t0 -> Bool + (==.t3) + ShouldSucc.X ShouldSucc.X + = True + (==.t3) + (ShouldSucc.Y a.r17) (ShouldSucc.Y b.r18) + = a.r17 ==.t12 b.r18 + (==.t3) + a.r19 b.r20 + = False + (/=.t4) :: ShouldSucc.B b.t0 -> ShouldSucc.B b.t0 -> Bool + (/=.t4) + a.r21 b.r22 + = not (a.r21 ==.t19 b.r22) +AbsBinds [a.t23] [d.Eq.t24] [(d.Eq.t25, dfun.Eq.ShouldSucc.T)] + (d.Eq.t45, d.Eq.t24) + (d.Eq.t44, dfun.Eq.ShouldSucc.B a.t23 d.Eq.t45) + (==.t33, (==) (ShouldSucc.B a.t23) d.Eq.t44) + (d.Eq.t46, d.Eq.t25) + (==.t42, (==) (ShouldSucc.T a.t23) d.Eq.t46) + {- rec -} + d.Eq.t25 = ({-dict-} [] [==.t26, /=.t27]) + (==.t26) :: ShouldSucc.T a.t23 -> ShouldSucc.T a.t23 -> Bool + (==.t26) + (ShouldSucc.D x.r24) (ShouldSucc.D y.r25) + = x.r24 ==.t33 y.r25 + (==.t26) + ShouldSucc.C ShouldSucc.C + = True + (==.t26) + a.r26 b.r27 + = False + (/=.t27) :: ShouldSucc.T a.t23 -> ShouldSucc.T a.t23 -> Bool + (/=.t27) + a.r28 b.r29 + = not (a.r28 ==.t42 b.r29) + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc075.hs b/ghc/compiler/tests/typecheck/should_succeed/tc075.hs new file mode 100644 index 0000000..f7c31d8 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc075.hs @@ -0,0 +1,8 @@ +module ShouldSucceed where + +--!!! giving methods in a pattern binding (for no v good reason...) + +data Foo = MkFoo Int + +instance Eq Foo where + ((==), (/=)) = (\x -> \y -> True, \x -> \y -> False) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc075.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc075.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc076.hs b/ghc/compiler/tests/typecheck/should_succeed/tc076.hs new file mode 100644 index 0000000..5bf422e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc076.hs @@ -0,0 +1,8 @@ +--!!! scoping in list comprehensions right way 'round? +-- a bug reported by Jon Hill +-- +module ShouldSucceed where + +x = [[True]] +xs :: [Bool] +xs = [x | x <- x, x <- x] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc076.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc076.stderr new file mode 100644 index 0000000..dd887a2 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc076.stderr @@ -0,0 +1,10 @@ +Typechecked: +AbsBinds [] [] [(x.t1, ShouldSucceed.x)] + {- nonrec -} + x.t1 :: [[Bool]] + x.t1 = [[True] (Bool)] ([Bool]) +AbsBinds [] [] [(xs.t3, ShouldSucceed.xs)] + {- nonrec -} + xs.t3 :: [Bool] + xs.t3 = [ x.r56 | x.r55 <- ShouldSucceed.x, x.r56 <- x.r55 ] + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc077.hs b/ghc/compiler/tests/typecheck/should_succeed/tc077.hs new file mode 100644 index 0000000..45ef892 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc077.hs @@ -0,0 +1,9 @@ +--!!! make sure context of EQ is minimised in interface file. +-- +module M where + +data NUM = ONE | TWO +class (Num a) => ORD a + +class (ORD a, Text a) => EQ a where + (===) :: a -> a -> Bool diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc077.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc077.stderr new file mode 100644 index 0000000..cf45bb0 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc077.stderr @@ -0,0 +1,25 @@ +Typechecked: +{- nonrec -} +(M.EQ.===) = + /\ a.t0 -> \{-classdict-} [d.M.ORD.t2 d.Text.t3] [===.t1] -> (===.t1) +sdsel.M.EQ.M.ORD = + /\ a.t0 -> \{-classdict-} [d.M.ORD.t2 d.Text.t3] [===.t1] -> d.M.ORD.t2 +sdsel.M.EQ.Text = + /\ a.t0 -> \{-classdict-} [d.M.ORD.t2 d.Text.t3] [===.t1] -> d.Text.t3 +{- nonrec -} +defm.M.EQ.=== = + /\ a.t4 -> + \{-dict-} d.M.EQ.t5 -> + (error (a.t4 -> a.t4 -> Bool)) + "No default method for \"M.EQ.defm.M.EQ.===\"\n" +{- nonrec -} +sdsel.M.ORD.Num = /\ a.t6 -> \{-classdict-} [d.Num.t7] [] -> d.Num.t7 +{- nonrec -} + +=-=-=-=-=INTERFACE STARTS HERE=-=-=-=-= M +interface M where +class (ORD a, Text a) => EQ a where (===) :: a -> a -> Bool +class (Num a) => ORD a +data NUM = ONE | TWO +=-=-=-=-=INTERFACE STOPS HERE=-=-=-=-= + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc078.hs b/ghc/compiler/tests/typecheck/should_succeed/tc078.hs new file mode 100644 index 0000000..a35afef --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc078.hs @@ -0,0 +1,8 @@ +--!!! instance decls with no binds +-- +module M where + +data Bar a = MkBar Int a + +instance Eq a => Eq (Bar a) +instance Ord a => Ord (Bar a) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc078.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc078.stderr new file mode 100644 index 0000000..93d41fb --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc078.stderr @@ -0,0 +1,27 @@ +Typechecked: +AbsBinds [a.t0] [d.Eq.t1] [(d.Eq.t2, dfun.Eq.M.Bar)] + {- rec -} + d.Eq.t2 = ({-dict-} [] [==.t3, /=.t4]) + (==.t3) = defm.== (M.Bar a.t0) d.Eq.t2 + (/=.t4) = defm./= (M.Bar a.t0) d.Eq.t2 +AbsBinds [a.t5] [d.Ord.t7, d.Eq.t6] [(d.Ord.t8, dfun.Ord.M.Bar)] + {- rec -} + d.Ord.t8 = + ({-dict-} + [d.Eq.t6] + [<.t9, <=.t10, >=.t11, >.t12, max.t13, min.t14, cmp3.t15]) + (<.t9) = defm.< (M.Bar a.t5) d.Ord.t8 + (<=.t10) = defm.<= (M.Bar a.t5) d.Ord.t8 + (>=.t11) = defm.>= (M.Bar a.t5) d.Ord.t8 + (>.t12) = defm.> (M.Bar a.t5) d.Ord.t8 + max.t13 = defm.max (M.Bar a.t5) d.Ord.t8 + min.t14 = defm.min (M.Bar a.t5) d.Ord.t8 + cmp3.t15 = /\ tt16 -> defm.cmp3 [M.Bar a.t5, tt16] d.Ord.t8 + +=-=-=-=-=INTERFACE STARTS HERE=-=-=-=-= M +interface M where +data Bar a = MkBar Int a +instance Eq a => Eq (Bar a) +instance Ord a => Ord (Bar a) +=-=-=-=-=INTERFACE STOPS HERE=-=-=-=-= + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc079.hs b/ghc/compiler/tests/typecheck/should_succeed/tc079.hs new file mode 100644 index 0000000..c0845f7 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc079.hs @@ -0,0 +1,14 @@ +--!!! small class decl with local polymorphism; +--!!! "easy" to check default methods and such... +--!!! (this is the example given in TcClassDcl) +-- +class Foo a where + op1 :: a -> Bool + op2 :: Ord b => a -> b -> b -> b + + op1 x = True + op2 x y z = if (op1 x) && (y < z) then y else z + +instance Foo Int where {} + +instance Foo a => Foo [a] where {} diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc079.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc079.stderr new file mode 100644 index 0000000..908c3dc --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc079.stderr @@ -0,0 +1,42 @@ +Typechecked: +{- nonrec -} +Main.Foo.op1 = /\ a.t7 -> \{-classdict-} [] [op1.t8 op2.t9] -> op1.t8 +Main.Foo.op2 = + /\ a.t7 b.t10 -> \{-classdict-} [] [op1.t8 op2.t9] -> op2.t9 b.t10 +{- nonrec -} +defm.Main.Foo.op1 = + let + AbsBinds [a.t11] [d.Main.Foo.t12] [(op1.t13, op1.t14)] + {- nonrec -} + op1.t13 :: a.t11 -> Bool + op1.t13 + x.r11 = True + in op1.t14 +defm.Main.Foo.op2 = + let + AbsBinds [a.t16, b.t17] [d.Main.Foo.t18, d.Ord.t19] [(op2.t20, op2.t21)] + (d.Ord.t31, d.Ord.t19) + (<.t28, (<) b.t17 d.Ord.t31) + (d.Main.Foo.t32, d.Main.Foo.t18) + (Main.Foo.op1.t26, Main.Foo.op1 a.t16 d.Main.Foo.t32) + {- nonrec -} + op2.t20 :: a.t16 -> b.t17 -> b.t17 -> b.t17 + op2.t20 + x.r12 y.r13 z.r14 + = if (Main.Foo.op1.t26 x.r12) && (y.r13 <.t28 z.r14) then + y.r13 + else + z.r14 + in op2.t21 +{- rec -} +dfun.Main.Foo.Int = + ({-dict-} [] [const.Main.Foo.Int.op1, const.Main.Foo.Int.op2]) +const.Main.Foo.Int.op1 = defm.Main.Foo.op1 Int dfun.Main.Foo.Int +const.Main.Foo.Int.op2 = + /\ b.t0 -> defm.Main.Foo.op2 [Int, b.t0] dfun.Main.Foo.Int +AbsBinds [a.t1] [d.Main.Foo.t2] [(d.Main.Foo.t3, dfun.Main.Foo.List)] + {- rec -} + d.Main.Foo.t3 = ({-dict-} [] [op1.t4, op2.t5]) + op1.t4 = defm.Main.Foo.op1 [a.t1] d.Main.Foo.t3 + op2.t5 = /\ b.t6 -> defm.Main.Foo.op2 [[a.t1], b.t6] d.Main.Foo.t3 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc080.hs b/ghc/compiler/tests/typecheck/should_succeed/tc080.hs new file mode 100644 index 0000000..d9ad6e9 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc080.hs @@ -0,0 +1,53 @@ +--module Parse(Parse(..),whiteSpace,seperatedBy) where +--import StdLib +class Parse a where + parseFile :: String -> [a] + parseFile string | all forced x = x + where x = map parseLine (lines' string) + parseLine :: String -> a + parseLine = pl.parse where pl (a,_) = a + parse :: String -> (a,String) + parse = parseType.whiteSpace + parseType :: String -> (a,String) + forced :: a -> Bool + forced x = True + +instance Parse Int where + parseType str = pl (span' isDigit str) + where pl (l,r) = (strToInt l,r) + forced n | n>=0 = True + +instance Parse Char where + parseType (ch:str) = (ch,str) + forced n = True + +instance (Parse a) => Parse [a] where + parseType more = (map parseLine (seperatedBy ',' (l++",")),out) + where (l,']':out) = span' (\x->x/=']') (tail more) + forced = all forced + +seperatedBy :: Char -> String -> [String] +seperatedBy ch [] = [] +seperatedBy ch xs = twaddle ch (span' (\x->x/=ch) xs) + where twaddle ch (l,_:r) = l:seperatedBy ch r + +whiteSpace :: String -> String +whiteSpace = dropWhile isSpace + +span' :: (a->Bool) -> [a] -> ([a],[a]) +span' p [] = ([],[]) +span' p (x:xs') | p x = fixLeak x (span' p xs') where fixLeak x (xs,ys) = (x:xs,ys) +span' _ xs = ([],xs) + +lines' :: [Char] -> [[Char]] +lines' "" = [] +lines' s = plumb (span' ((/=) '\n') s) + where plumb (l,s') = l:if null s' then [] else lines' (tail s') + +strToInt :: String -> Int +strToInt x = strToInt' (length x-1) x + where strToInt' _ [] = 0 + strToInt' x (a:l) = (charToInt a)*(10^x) + (strToInt' (x-1) l) + +charToInt :: Char -> Int +charToInt x = (ord x - ord '0') diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc080.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc080.stderr new file mode 100644 index 0000000..1818071 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc080.stderr @@ -0,0 +1,303 @@ +Typechecked: +{- nonrec -} +Main.Parse.parseFile = + /\ a.t177 -> + \{-classdict-} [] [parseFile.t178 + parseLine.t179 + parse.t180 + parseType.t181 + forced.t182] -> parseFile.t178 +Main.Parse.parseLine = + /\ a.t177 -> + \{-classdict-} [] [parseFile.t178 + parseLine.t179 + parse.t180 + parseType.t181 + forced.t182] -> parseLine.t179 +Main.Parse.parse = + /\ a.t177 -> + \{-classdict-} [] [parseFile.t178 + parseLine.t179 + parse.t180 + parseType.t181 + forced.t182] -> parse.t180 +Main.Parse.parseType = + /\ a.t177 -> + \{-classdict-} [] [parseFile.t178 + parseLine.t179 + parse.t180 + parseType.t181 + forced.t182] -> parseType.t181 +Main.Parse.forced = + /\ a.t177 -> + \{-classdict-} [] [parseFile.t178 + parseLine.t179 + parse.t180 + parseType.t181 + forced.t182] -> forced.t182 +{- nonrec -} +defm.Main.Parse.parseFile = + let + AbsBinds [a.t183] [d.Main.Parse.t184] [(parseFile.t185, parseFile.t186)] + (d.Main.Parse.t197, d.Main.Parse.t184) + (Main.Parse.parseLine.t193, + Main.Parse.parseLine a.t183 d.Main.Parse.t197) + (d.Main.Parse.t198, d.Main.Parse.t197) + (Main.Parse.forced.t196, Main.Parse.forced a.t183 d.Main.Parse.t198) + {- nonrec -} + parseFile.t185 :: String -> [a.t183] + parseFile.t185 + string.r23 + | (all a.t183) Main.Parse.forced.t196 x.r24 = x.r24 + where + AbsBinds [] [] [(x.t189, x.r24)] + {- nonrec -} + x.t189 :: [a.t183] + x.t189 + = (map [String, a.t183]) + Main.Parse.parseLine.t193 + (Main.lines' string.r23) + {- nonrec -} + in parseFile.t186 +defm.Main.Parse.parseLine = + let + AbsBinds [a.t199] [d.Main.Parse.t200] [(parseLine.t201, parseLine.t202)] + (d.Main.Parse.t217, d.Main.Parse.t200) + (Main.Parse.parse.t215, Main.Parse.parse a.t199 d.Main.Parse.t217) + {- nonrec -} + parseLine.t201 :: String -> a.t199 + parseLine.t201 + = ((.) [String, (a.t199, String), a.t199]) + (pl.r25 [String, a.t199]) Main.Parse.parse.t215 + where + AbsBinds [tt208, tt207] [] [(pl.t204, pl.r25)] + {- nonrec -} + pl.t204 :: (tt207, tt208) -> tt207 + pl.t204 + (a.r26, _) + = a.r26 + {- nonrec -} + in parseLine.t202 +defm.Main.Parse.parse = + let + AbsBinds [a.t218] [d.Main.Parse.t219] [(parse.t220, parse.t221)] + (d.Main.Parse.t228, d.Main.Parse.t219) + (Main.Parse.parseType.t226, + Main.Parse.parseType a.t218 d.Main.Parse.t228) + {- nonrec -} + parse.t220 :: String -> (a.t218, String) + parse.t220 + = ((.) [String, String, (a.t218, String)]) + Main.Parse.parseType.t226 Main.whiteSpace + in parse.t221 +defm.Main.Parse.forced = + let + AbsBinds [a.t229] [d.Main.Parse.t230] [(forced.t231, forced.t232)] + {- nonrec -} + forced.t231 :: a.t229 -> Bool + forced.t231 + x.r27 = True + in forced.t232 +defm.Main.Parse.parseType = + /\ a.t234 -> + \{-dict-} d.Main.Parse.t235 -> + (error (String -> (a.t234, String))) + "No default method for \"Main.Parse.defm.Main.Parse.parseType\"\n" +{- rec -} +dfun.Main.Parse.Char = + ({-dict-} + [] + [const.Main.Parse.Char.parseFile, + const.Main.Parse.Char.parseLine, + const.Main.Parse.Char.parse, + const.Main.Parse.Char.parseType, + const.Main.Parse.Char.forced]) +const.Main.Parse.Char.parseType :: String -> (Char, String) +const.Main.Parse.Char.parseType + (ch.r64 : str.r65) + = (ch.r64, str.r65) +const.Main.Parse.Char.forced :: Char -> Bool +const.Main.Parse.Char.forced + n.r66 = True +const.Main.Parse.Char.parseFile = + defm.Main.Parse.parseFile Char dfun.Main.Parse.Char +const.Main.Parse.Char.parseLine = + defm.Main.Parse.parseLine Char dfun.Main.Parse.Char +const.Main.Parse.Char.parse = defm.Main.Parse.parse Char dfun.Main.Parse.Char +{- rec -} +dfun.Main.Parse.Int = + ({-dict-} + [] + [const.Main.Parse.Int.parseFile, + const.Main.Parse.Int.parseLine, + const.Main.Parse.Int.parse, + const.Main.Parse.Int.parseType, + const.Main.Parse.Int.forced]) +const.Main.Parse.Int.parseType :: String -> (Int, String) +const.Main.Parse.Int.parseType + str.r67 = (pl.r68 [Char]) ((Main.span' Char) isDigit str.r67) + where + AbsBinds [tt135] [] [(pl.t131, pl.r68)] + {- nonrec -} + pl.t131 :: (String, tt135) -> (Int, tt135) + pl.t131 + (l.r69, r.r70) + = (Main.strToInt l.r69, r.r70) + {- nonrec -} +const.Main.Parse.Int.forced :: Int -> Bool +const.Main.Parse.Int.forced + n.r71 | n.r71 >=.t140 lit.t142 = True +const.Main.Parse.Int.parseFile = + defm.Main.Parse.parseFile Int dfun.Main.Parse.Int +const.Main.Parse.Int.parseLine = + defm.Main.Parse.parseLine Int dfun.Main.Parse.Int +const.Main.Parse.Int.parse = defm.Main.Parse.parse Int dfun.Main.Parse.Int +AbsBinds +[a.t173] +[d.Main.Parse.t145] +[(d.Main.Parse.t146, dfun.Main.Parse.List)] + (/=.t163, neChar) + (d.Main.Parse.t175, d.Main.Parse.t145) + (Main.Parse.parseLine.t169, Main.Parse.parseLine a.t173 d.Main.Parse.t175) + (d.Main.Parse.t176, d.Main.Parse.t175) + (Main.Parse.forced.t174, Main.Parse.forced a.t173 d.Main.Parse.t176) + {- rec -} + d.Main.Parse.t146 = + ({-dict-} + [] + [parseFile.t147, parseLine.t148, parse.t149, parseType.t150, forced.t151]) + parseType.t150 :: String -> ([a.t173], String) + parseType.t150 + more.r73 = ((map [String, a.t173]) + Main.Parse.parseLine.t169 + (Main.seperatedBy ',' (((++) Char) l.r74 ",")), + out.r75) + where + AbsBinds [] [] [(l.t155, l.r74), (out.t156, out.r75)] + {- nonrec -} + (l.t155, (']' : out.t156)) :: ([Char], [Char]) + (l.t155, (']' : out.t156)) + = (Main.span' Char) + (\ x.r76 -> x.r76 /=.t163 ']') + ((tail Char) more.r73) + {- nonrec -} + forced.t151 :: [a.t173] -> Bool + forced.t151 = (all a.t173) Main.Parse.forced.t174 + parseFile.t147 = defm.Main.Parse.parseFile [a.t173] d.Main.Parse.t146 + parseLine.t148 = defm.Main.Parse.parseLine [a.t173] d.Main.Parse.t146 + parse.t149 = defm.Main.Parse.parse [a.t173] d.Main.Parse.t146 +lit.t87 = MkInt 0# +lit.t100 = MkInt 10# +lit.t122 = MkInt 1# +lit.t142 = lit.t87 +(>=.t140) = geInt +AbsBinds [a.t2] [] [(span'.t1, Main.span')] + {- rec -} + span'.t1 :: (a.t2 -> Bool) -> [a.t2] -> ([a.t2], [a.t2]) + span'.t1 + p.r95 [] = ([] (a.t2), [] (a.t2)) + span'.t1 + p.r96 (x.r97 : xs'.r98) + | p.r96 x.r97 = + (fixLeak.r99 [a.t2, [a.t2]]) x.r97 (span'.t1 p.r96 xs'.r98) + where + AbsBinds [tt18, tt17] [] [(fixLeak.t12, fixLeak.r99)] + {- nonrec -} + fixLeak.t12 :: tt18 -> ([tt18], tt17) -> ([tt18], tt17) + fixLeak.t12 + x.r100 (xs.r101, ys.r102) + = (((:) tt18) x.r100 xs.r101, ys.r102) + {- nonrec -} + span'.t1 + _ xs.r103 + = ([] (a.t2), xs.r103) +AbsBinds [] [] [(seperatedBy.t28, Main.seperatedBy)] + (/=.t49, neChar) + {- rec -} + seperatedBy.t28 :: Char -> String -> [String] + seperatedBy.t28 + ch.r87 [] + = [] (String) + seperatedBy.t28 + ch.r88 xs.r89 + = twaddle.r90 + ch.r88 + ((Main.span' Char) + (\ x.r94 -> x.r94 /=.t49 ch.r88) + xs.r89) + where + AbsBinds [] [] [(twaddle.t35, twaddle.r90)] + {- nonrec -} + twaddle.t35 :: Char -> (String, [Char]) -> [String] + twaddle.t35 + ch.r91 (l.r92, (_ : r.r93)) + = ((:) String) + l.r92 (seperatedBy.t28 ch.r91 r.r93) + {- nonrec -} +AbsBinds [] [] [(whiteSpace.t52, Main.whiteSpace)] + {- nonrec -} + whiteSpace.t52 :: String -> String + whiteSpace.t52 = (dropWhile Char) isSpace +AbsBinds [] [] [(lines'.t55, Main.lines')] + (/=.t72, neChar) + {- rec -} + lines'.t55 :: [Char] -> [[Char]] + lines'.t55 + "" = [] ([Char]) + lines'.t55 + s.r104 = plumb.r105 ((Main.span' Char) ((/=.t72) '\n') s.r104) + where + AbsBinds [] [] [(plumb.t59, plumb.r105)] + {- nonrec -} + plumb.t59 :: ([Char], [Char]) -> [[Char]] + plumb.t59 + (l.r106, s'.r107) + = ((:) [Char]) + l.r106 + (if (null Char) s'.r107 then + [] ([Char]) + else + lines'.t55 ((tail Char) s'.r107)) + {- nonrec -} +AbsBinds [] [] [(charToInt.t74, Main.charToInt)] + (-.t77, minusInt) + {- nonrec -} + charToInt.t74 :: Char -> Int + charToInt.t74 + x.r113 = (ord x.r113) -.t77 (ord '0') +AbsBinds [] [] [(strToInt.t80, Main.strToInt)] + (-.t119, minusInt) + (d.Integral.t124, dfun.Integral.Int) + {- nonrec -} + strToInt.t80 :: String -> Int + strToInt.t80 + x.r108 = strToInt'.r109.t117 + (((length Char) x.r108) -.t119 lit.t122) x.r108 + where + AbsBinds + [a.t96] + [d.Integral.t114] + [(strToInt'.t83, strToInt'.r109)] + (d.Real.t115, sdsel.Integral.Real a.t96 d.Integral.t114) + (d.Num.t111, sdsel.Real.Num a.t96 d.Real.t115) + (fromInt.t110, fromInt a.t96 d.Num.t111) + (lit.t107, fromInt.t110 (MkInt 1#)) + (d.Num.t112, d.Num.t111) + (-.t105, (-) a.t96 d.Num.t112) + (d.Num.t113, dfun.Num.Int) + (^.t98, (^) [a.t96, Int] [d.Num.t113, d.Integral.t114]) + (*.t95, timesInt) + (+.t93, plusInt) + {- rec -} + strToInt'.t83 :: a.t96 -> [Char] -> Int + strToInt'.t83 + _ [] = lit.t87 + strToInt'.t83 + x.r112 (a.r110 : l.r111) + = ((Main.charToInt a.r110) + *.t95 (lit.t100 ^.t98 x.r112)) + +.t93 (strToInt'.t83 + (x.r112 -.t105 lit.t107) l.r111) + {- nonrec -} + strToInt'.r109.t117 = strToInt'.r109 Int d.Integral.t124 + diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc081.hs b/ghc/compiler/tests/typecheck/should_succeed/tc081.hs new file mode 100644 index 0000000..27c2932 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc081.hs @@ -0,0 +1,27 @@ +--!!! an example Simon made up +-- + +f x = (x+1, x<3, g True, g 'c') + where + g y = if x>2 then [] else [y] +{- +Here the type-check of g will yield an LIE with an Ord dict +for x. g still has type forall a. a -> [a]. The dictionary is +free, bound by the x. + +It should be ok to add the signature: +-} + +f2 x = (x+1, x<3, g2 True, g2 'c') + where + -- NB: this sig: + g2 :: a -> [a] + g2 y = if x>2 then [] else [y] +{- +or to write: +-} + +f3 x = (x+1, x<3, g3 True, g3 'c') + where + -- NB: this line: + g3 = (\ y -> if x>2 then [] else [y])::(a -> [a]) diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc081.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc081.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc082.hs b/ghc/compiler/tests/typecheck/should_succeed/tc082.hs new file mode 100644 index 0000000..f2ccb36 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc082.hs @@ -0,0 +1,12 @@ +--!!! tc082: an instance for functions +-- +module N where + +class Normal a + where + normal :: a -> Bool + +instance Normal ( a -> b ) where + normal _ = True + +f x = normal id diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc082.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc082.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc083.hs b/ghc/compiler/tests/typecheck/should_succeed/tc083.hs new file mode 100644 index 0000000..1c5321e --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc083.hs @@ -0,0 +1,10 @@ +--!!! instances with no binds; +--!!! be sure we get a legit .hi file +-- +module Bar where + +import ClassFoo + +instance Foo Int + +instance Foo a => Foo [a] diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc083.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc083.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc084.hs b/ghc/compiler/tests/typecheck/should_succeed/tc084.hs new file mode 100644 index 0000000..572bbe3 --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc084.hs @@ -0,0 +1,23 @@ +{- This program shows up a bug in the handling of + the monomorphism restriction in an earlier version of + ghc. With ghc 0.18 and before, f gets a type with + an unbound type variable, which shows up in the + interface file. Reason: it was being monomorphised. + + Simon PJ +-} + +module Foo where + + +g :: Num a => Bool -> a -> b -> a +g b x y = if b then x+x else x-x + +-- Everything is ok if this signature is put in +-- but the program should be perfectly legal without it. +-- f :: Num a => a -> b -> a +f = g True + +h y x = f (x::Int) y + -- This use of f binds the overloaded monomorphic + -- type to Int diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc084.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc084.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc085.hs b/ghc/compiler/tests/typecheck/should_succeed/tc085.hs new file mode 100644 index 0000000..fcdf1af --- /dev/null +++ b/ghc/compiler/tests/typecheck/should_succeed/tc085.hs @@ -0,0 +1,9 @@ +--! From a bug report from Satnam. +--! To do with re-exporting importees from PreludeGla* modules. +module Foo ( PreludePrimIO.., {-PreludeGlaIO..,-} Foo..) where + +--OLD: import PreludeGlaIO +import PreludePrimIO + +type FooType = Int +data FooData = FooData diff --git a/ghc/compiler/tests/typecheck/should_succeed/tc085.stderr b/ghc/compiler/tests/typecheck/should_succeed/tc085.stderr new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/tests/typecheck/stress/tcstress001.hs b/ghc/compiler/tests/typecheck/stress/tcstress001.hs new file mode 100644 index 0000000..7024aad --- /dev/null +++ b/ghc/compiler/tests/typecheck/stress/tcstress001.hs @@ -0,0 +1,71 @@ + +module Prims where + +one = one + +head (x:xs) = x + +bottom = head + +absIf a b c = a + +absAnd a b = head [a,b] + +fac_rec fac0 n a + = (absIf (absAnd (s_3_0 n) one) + (s_2_0 a) + (fac0 (absAnd (s_3_2 n) one) (absAnd (s_3_1 n) (s_2_1 a)))) + +f_rec f0 a + = (f0 (s_1_0 a)) + +g_rec g0 g1 x y z p + = (absIf (absAnd (s_3_0 p) one) + (absAnd (s_1_0 x) (s_3_0 z)) + (absAnd + (g0 (s_1_0 y) one one (absAnd (s_3_1 p) one)) + (g1 (s_3_2 z) (s_3_1 z) one (absAnd (s_3_2 p) one)))) + +s_2_0 (v0,v1) = v0 +s_2_1 (v0,v1) = v1 +s_1_0 v0 = v0 +s_3_0 (v0,v1,v2) = v0 +s_3_1 (v0,v1,v2) = v1 +s_3_2 (v0,v1,v2) = v2 + +fac n a + = (fac_rec fac_rec4 n a) + +fac_rec4 n a = (fac_rec fac_rec3 n a) +fac_rec3 n a = (fac_rec fac_rec2 n a) +fac_rec2 n a = (fac_rec fac_rec1 n a) +fac_rec1 n a = (fac_rec fac_rec0 n a) +fac_rec0 n a = (bottom [n,a]) + +f a + = (f_rec f_rec2 a) + +f_rec2 a = (f_rec f_rec1 a) +f_rec1 a = (f_rec f_rec0 a) +f_rec0 a = (bottom [a]) + +g x y z p + = (g_rec g_rec16 g_rec16 x y z p) + +g_rec16 x y z p = (g_rec g_rec15 g_rec15 x y z p) +g_rec15 x y z p = (g_rec g_rec14 g_rec14 x y z p) +g_rec14 x y z p = (g_rec g_rec13 g_rec13 x y z p) +g_rec13 x y z p = (g_rec g_rec12 g_rec12 x y z p) +g_rec12 x y z p = (g_rec g_rec11 g_rec11 x y z p) +g_rec11 x y z p = (g_rec g_rec10 g_rec10 x y z p) +g_rec10 x y z p = (g_rec g_rec9 g_rec9 x y z p) +g_rec9 x y z p = (g_rec g_rec8 g_rec8 x y z p) +g_rec8 x y z p = (g_rec g_rec7 g_rec7 x y z p) +g_rec7 x y z p = (g_rec g_rec6 g_rec6 x y z p) +g_rec6 x y z p = (g_rec g_rec5 g_rec5 x y z p) +g_rec5 x y z p = (g_rec g_rec4 g_rec4 x y z p) +g_rec4 x y z p = (g_rec g_rec3 g_rec3 x y z p) +g_rec3 x y z p = (g_rec g_rec2 g_rec2 x y z p) +g_rec2 x y z p = (g_rec g_rec1 g_rec1 x y z p) +g_rec1 x y z p = (g_rec g_rec0 g_rec0 x y z p) +g_rec0 x y z p = (bottom [x,y,z,p]) diff --git a/ghc/compiler/tests/validation-misc/Echo.hs b/ghc/compiler/tests/validation-misc/Echo.hs new file mode 100644 index 0000000..8711420 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/Echo.hs @@ -0,0 +1,8 @@ +import MiniPrel + +main = (ccall getchar) `thenU` ( \ ch -> + case ch of + -1# -> (ccall exit 0#) + _ -> (ccall putchar ch) `thenU` ( \ _ -> + main ) + ) diff --git a/ghc/compiler/tests/validation-misc/Jmakefile b/ghc/compiler/tests/validation-misc/Jmakefile new file mode 100644 index 0000000..cdc330e --- /dev/null +++ b/ghc/compiler/tests/validation-misc/Jmakefile @@ -0,0 +1,11 @@ +all:: /* so we do not fall into runtests by default */ + @echo "making all in $(CURRENT_DIR) done" + +TESTGHC=$(GHC) + +runtests:: + @echo '###############################################################' + @echo '# The stuff that was here has been moved to ../*/ #' + @echo '###############################################################' + +ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) ) diff --git a/ghc/compiler/tests/validation-misc/dotests b/ghc/compiler/tests/validation-misc/dotests new file mode 100644 index 0000000..5e2e80b --- /dev/null +++ b/ghc/compiler/tests/validation-misc/dotests @@ -0,0 +1,27 @@ +#! /usr/local/bin/perl +# +@Make_args = (); +@Range_args = (); + +while ($_ = $ARGV[0]) { + shift; + if (/^-/ || /^[A-Z_]+=/) { + push(@Make_args, $_); + } else { + push(@Range_args,$_); + } +} + +if ($#Range_args != 1) { + print STDERR "usage: dotest [make-args] from-test to-test\n"; + exit(1); +} +$test = $Range_args[0]; +$last_test = $Range_args[1]; +if ($test gt $last_test) { + print STDERR "_from_ test $test _to_ test $last_test?\n"; +} +while ($test le $last_test) { + system("make @Make_args runtest_$test"); + $test++; # string incr +} diff --git a/ghc/compiler/tests/validation-misc/naming001.hs b/ghc/compiler/tests/validation-misc/naming001.hs new file mode 100644 index 0000000..2d23bdc --- /dev/null +++ b/ghc/compiler/tests/validation-misc/naming001.hs @@ -0,0 +1 @@ +Prelude = 42 diff --git a/ghc/compiler/tests/validation-misc/naming002.hs b/ghc/compiler/tests/validation-misc/naming002.hs new file mode 100644 index 0000000..2cd8b3d --- /dev/null +++ b/ghc/compiler/tests/validation-misc/naming002.hs @@ -0,0 +1 @@ +(+) x y = x diff --git a/ghc/compiler/tests/validation-misc/naming003.hs b/ghc/compiler/tests/validation-misc/naming003.hs new file mode 100644 index 0000000..052d8c8 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/naming003.hs @@ -0,0 +1 @@ +x = [1..10] where enumFromTo x y = x diff --git a/ghc/compiler/tests/validation-misc/naming004.hs b/ghc/compiler/tests/validation-misc/naming004.hs new file mode 100644 index 0000000..aa4710e --- /dev/null +++ b/ghc/compiler/tests/validation-misc/naming004.hs @@ -0,0 +1,2 @@ +data Bogus = True | False +True = (3 == 3) diff --git a/ghc/compiler/tests/validation-misc/naming005.hs b/ghc/compiler/tests/validation-misc/naming005.hs new file mode 100644 index 0000000..a005e60 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/naming005.hs @@ -0,0 +1 @@ +x x = x diff --git a/ghc/compiler/tests/validation-misc/testexpr.hs b/ghc/compiler/tests/validation-misc/testexpr.hs new file mode 100644 index 0000000..bcaef3f --- /dev/null +++ b/ghc/compiler/tests/validation-misc/testexpr.hs @@ -0,0 +1,103 @@ +-- literal +----- + +x = 'a' -- 1 + +----- + +x = "123" -- 2 + +----- + +x = 1 -- 3 + +----- + +x = 1.2 + +----- + +-- exprs + +----- + +x = x -- 5 + +----- + +x = True -- 6 + +----- + +x = () -- 7 + +----- + +(x:y) = [1,2] -- 8 + +----- + +(x:y) = [1,'a'] -- 9 + +----- + +(x,y) = (1,'a') -- 10 + +----- + +(x,y) = (1,2,3) -- 11 + +----- + +(x:y) = (1,'a') -- 12 + +----- + +x = 1+x -- 13 + +----- + +x = 1+2 -- 14 + +----- + +f x = y where y = 2 -- 15 + +----- + + +f x = y+2 where y = x+3 + +----- + +f x = a where a = x:a + +----- + +(x:y) = case (if True then True else False) of -- 18 + True -> (True,1) + False -> (1,True) + +----- + +f x = \ (y,z) -> x -- 19 + +----- + +(x:y) = [y+1 | (y,z) <- [(1,2)]] -- 20 + +----- + +x = if True then 1 else 2 + +----- + +(z@(q,w)) = if True then (1,2) else (1,3) + +----- + +x = [1..2] + +----- + + diff --git a/ghc/compiler/tests/validation-misc/testgrhss.hs b/ghc/compiler/tests/validation-misc/testgrhss.hs new file mode 100644 index 0000000..73f1901 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/testgrhss.hs @@ -0,0 +1,16 @@ +-- grhss +----- + +f x | True = x+1 -- 1 + | False = True + +----- + +x | True = x+1 -- 2 + | False = x + +----- + + + + diff --git a/ghc/compiler/tests/validation-misc/testmatches.hs b/ghc/compiler/tests/validation-misc/testmatches.hs new file mode 100644 index 0000000..eb10ad9 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/testmatches.hs @@ -0,0 +1,12 @@ +-- matches +----- +f x = case x of + True -> True + False -> x + +----- + +f ((x:a),y) = x +f (a,b) = 2 + +----- diff --git a/ghc/compiler/tests/validation-misc/testmonobinds.hs b/ghc/compiler/tests/validation-misc/testmonobinds.hs new file mode 100644 index 0000000..d6dd814 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/testmonobinds.hs @@ -0,0 +1,45 @@ +-- monobinds +----- + +a = 1:a + +----- + +a = 2 + +b = 1:a:c + +c = 0:b + +----- + +a = 1 + +b = a+a + +----- + +f = \ y -> y + +g x = x + +----- + +f True = 1 + +f False = 0 + +----- + +f (x:y) = x + +f z = z + +----- + +f (True,x) = x + +f (False,y) = y+1 + +----- + diff --git a/ghc/compiler/tests/validation-misc/testmrule.hs b/ghc/compiler/tests/validation-misc/testmrule.hs new file mode 100644 index 0000000..9d617a0 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/testmrule.hs @@ -0,0 +1,7 @@ +-- mrule +----- + +x = \ (y:z) -> z+2 + +----- + diff --git a/ghc/compiler/tests/validation-misc/testpats.hs b/ghc/compiler/tests/validation-misc/testpats.hs new file mode 100644 index 0000000..ba09f21 --- /dev/null +++ b/ghc/compiler/tests/validation-misc/testpats.hs @@ -0,0 +1,26 @@ +-- pats +----- + +_ = 2 -- + +----- + +x = 2 -- + +----- + +(z@(x:y)) = z -- + +----- + +~(x,y) = x -- + +----- + +f True = 1 + +f False = 0 + +----- + + diff --git a/ghc/compiler/tests/wdp-array.hs b/ghc/compiler/tests/wdp-array.hs new file mode 100644 index 0000000..f3432c2 --- /dev/null +++ b/ghc/compiler/tests/wdp-array.hs @@ -0,0 +1,4 @@ +import MiniPrel + +a :: Array Int Int +a = array (1,100) ((1 := 1) : [i := i * a!(i-1) | i <- [2..100]]) diff --git a/ghc/compiler/tests/wdp-otherwise.hs b/ghc/compiler/tests/wdp-otherwise.hs new file mode 100644 index 0000000..c59b949 --- /dev/null +++ b/ghc/compiler/tests/wdp-otherwise.hs @@ -0,0 +1,11 @@ +-- this is legal, I think (WDP) + +module Confused where + +import Prelude hiding (otherwise) + +otherwise = False + +f x | otherwise = 1 + +g otherwise | otherwise = 2 diff --git a/ghc/compiler/tests/wdp-ppr.hs b/ghc/compiler/tests/wdp-ppr.hs new file mode 100644 index 0000000..563e752 --- /dev/null +++ b/ghc/compiler/tests/wdp-ppr.hs @@ -0,0 +1,13 @@ +{- +From: Kubiak Ryszard +To: partain +Subject: You may test the new pretty-printer on the following text: +Date: Wed, 2 Oct 91 18:06:05 BST +-} + +data LList alpha = Nill | Conss alpha (LList alpha) + +append :: LList a -> LList a -> LList a +append xs ys = case xs of + Nill -> ys + (Conss z zs) -> Conss z (append zs ys) diff --git a/ghc/compiler/tests/wdp-prel-insts.hs b/ghc/compiler/tests/wdp-prel-insts.hs new file mode 100644 index 0000000..00a06cb --- /dev/null +++ b/ghc/compiler/tests/wdp-prel-insts.hs @@ -0,0 +1,8 @@ +-- what error do you get if you redefined PreludeCore instances? + +module Test where + +f x@(a,b) y@(c,d) = x == y + +instance Eq (a,b) where + (m,n) == (o,p) = m == o diff --git a/ghc/compiler/typecheck/BackSubst.hi b/ghc/compiler/typecheck/BackSubst.hi new file mode 100644 index 0000000..85802bc --- /dev/null +++ b/ghc/compiler/typecheck/BackSubst.hi @@ -0,0 +1,29 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface BackSubst where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsExpr(Expr) +import HsLit(Literal) +import HsMatches(GRHSsAndBinds, Match) +import HsPat(TypecheckedPat) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Inst(Inst) +import Maybes(Labda) +import PreludeGlaST(_MutableArray) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique) +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-} +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +applyTcSubstToBinds :: Binds Id TypecheckedPat -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Binds Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/BackSubst.lhs b/ghc/compiler/typecheck/BackSubst.lhs new file mode 100644 index 0000000..b42877b --- /dev/null +++ b/ghc/compiler/typecheck/BackSubst.lhs @@ -0,0 +1,451 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[BackSubst]{Back substitution functions} + +This module applies a typechecker substitution over the whole abstract +syntax. + +\begin{code} +#include "HsVersions.h" + +module BackSubst ( + applyTcSubstToBinds, + + -- and to make the interface self-sufficient... + Subst, Binds, MonoBinds, Id, TypecheckedPat + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import AbsSyn +import AbsUniType ( getTyVar ) +import TcMonad +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Binds]{Running a substitution over @Binds@} +%* * +%************************************************************************ + +\begin{code} +applyTcSubstToBinds :: TypecheckedBinds -> NF_TcM TypecheckedBinds + +applyTcSubstToBinds EmptyBinds = returnNF_Tc EmptyBinds + +applyTcSubstToBinds (ThenBinds binds1 binds2) + = applyTcSubstToBinds binds1 `thenNF_Tc` \ new_binds1 -> + applyTcSubstToBinds binds2 `thenNF_Tc` \ new_binds2 -> + returnNF_Tc (ThenBinds new_binds1 new_binds2) + +applyTcSubstToBinds (SingleBind bind) + = substBind bind `thenNF_Tc` \ new_bind -> + returnNF_Tc (SingleBind new_bind) + +applyTcSubstToBinds (AbsBinds tyvars dicts locprs dict_binds val_bind) + = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars -> + mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs -> + mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds -> + substBind val_bind `thenNF_Tc` \ new_val_bind -> + returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind) + where + subst_pair (l, g) + = applyTcSubstToId l `thenNF_Tc` \ new_l -> + applyTcSubstToId g `thenNF_Tc` \ new_g -> + returnNF_Tc (new_l, new_g) + + subst_bind (v, e) + = applyTcSubstToInst v `thenNF_Tc` \ new_v -> + substExpr e `thenNF_Tc` \ new_e -> + returnNF_Tc (new_v, new_e) +\end{code} + +\begin{code} +------------------------------------------------------------------------- +substBind :: TypecheckedBind -> NF_TcM TypecheckedBind + +substBind (NonRecBind mbinds) + = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> + returnNF_Tc (NonRecBind new_mbinds) + +substBind (RecBind mbinds) + = applyTcSubstToMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> + returnNF_Tc (RecBind new_mbinds) + +substBind other = returnNF_Tc other + +------------------------------------------------------------------------- +applyTcSubstToMonoBinds :: TypecheckedMonoBinds -> NF_TcM TypecheckedMonoBinds + +applyTcSubstToMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds + +applyTcSubstToMonoBinds (AndMonoBinds mbinds1 mbinds2) + = applyTcSubstToMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 -> + applyTcSubstToMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 -> + returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2) + +applyTcSubstToMonoBinds (PatMonoBind pat grhss_w_binds locn) + = substPat pat `thenNF_Tc` \ new_pat -> + substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> + returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn) + +applyTcSubstToMonoBinds (VarMonoBind var expr) + = applyTcSubstToId var `thenNF_Tc` \ new_var -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (VarMonoBind new_var new_expr) + +applyTcSubstToMonoBinds (FunMonoBind name ms locn) + = applyTcSubstToId name `thenNF_Tc` \ new_name -> + mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (FunMonoBind new_name new_ms locn) +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds} +%* * +%************************************************************************ + +\begin{code} +substMatch :: TypecheckedMatch -> NF_TcM TypecheckedMatch + +substMatch (PatMatch pat match) + = substPat pat `thenNF_Tc` \ new_pat -> + substMatch match `thenNF_Tc` \ new_match -> + returnNF_Tc (PatMatch new_pat new_match) + +substMatch (GRHSMatch grhss_w_binds) + = substGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> + returnNF_Tc (GRHSMatch new_grhss_w_binds) + +------------------------------------------------------------------------- +substGRHSsAndBinds :: TypecheckedGRHSsAndBinds + -> NF_TcM TypecheckedGRHSsAndBinds + +substGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) + = mapNF_Tc subst_grhs grhss `thenNF_Tc` \ new_grhss -> + applyTcSubstToBinds binds `thenNF_Tc` \ new_binds -> + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) + where + subst_grhs (GRHS guard expr locn) + = substExpr guard `thenNF_Tc` \ new_guard -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (GRHS new_guard new_expr locn) + + subst_grhs (OtherwiseGRHS expr locn) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (OtherwiseGRHS new_expr locn) +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Expr]{Running a substitution over a TypeCheckedExpr} +%* * +%************************************************************************ + +ToDo: panic on things that can't be in @TypecheckedExpr@. + +\begin{code} +substExpr :: TypecheckedExpr -> NF_TcM TypecheckedExpr + +substExpr (Var name) + = applyTcSubstToId name `thenNF_Tc` \ new_name -> + returnNF_Tc (Var new_name) + +substExpr (Lit (LitLitLit s ty)) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (Lit (LitLitLit s new_ty)) + +substExpr other_lit@(Lit lit) = returnNF_Tc other_lit + +substExpr (Lam match) + = substMatch match `thenNF_Tc` \ new_match -> + returnNF_Tc (Lam new_match) + +substExpr (App e1 e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (App new_e1 new_e2) + +substExpr (OpApp e1 op e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr op `thenNF_Tc` \ new_op -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (OpApp new_e1 new_op new_e2) + +substExpr (SectionL expr op) + = substExpr expr `thenNF_Tc` \ new_expr -> + substExpr op `thenNF_Tc` \ new_op -> + returnNF_Tc (SectionL new_expr new_op) + +substExpr (SectionR op expr) + = substExpr op `thenNF_Tc` \ new_op -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (SectionR new_op new_expr) + +substExpr (CCall fun args may_gc is_casm result_ty) + = mapNF_Tc substExpr args `thenNF_Tc` \ new_args -> + applyTcSubstToTy result_ty `thenNF_Tc` \ new_result_ty -> + returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) + +substExpr (SCC label expr) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (SCC label new_expr) + +substExpr (Case expr ms) + = substExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc substMatch ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (Case new_expr new_ms) + +substExpr (ListComp expr quals) + = substExpr expr `thenNF_Tc` \ new_expr -> + substQuals quals `thenNF_Tc` \ new_quals -> + returnNF_Tc (ListComp new_expr new_quals) + +substExpr (Let binds expr) + = applyTcSubstToBinds binds `thenNF_Tc` \ new_binds -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (Let new_binds new_expr) + +--ExplicitList: not in typechecked exprs + +substExpr (ExplicitListOut ty exprs) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitListOut new_ty new_exprs) + +substExpr (ExplicitTuple exprs) + = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitTuple new_exprs) + +substExpr (If e1 e2 e3) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + substExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (If new_e1 new_e2 new_e3) + +substExpr (ArithSeqOut expr info) + = substExpr expr `thenNF_Tc` \ new_expr -> + substArithSeq info `thenNF_Tc` \ new_info -> + returnNF_Tc (ArithSeqOut new_expr new_info) + +substExpr (TyLam tyvars expr) + = subst_tyvars tyvars `thenNF_Tc` \ new_tyvars -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (TyLam new_tyvars new_expr) + +substExpr (TyApp expr tys) + = substExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc (applyTcSubstToTy) tys `thenNF_Tc` \ new_tys -> + returnNF_Tc (TyApp new_expr new_tys) + +substExpr (DictLam dicts expr) + = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (DictLam new_dicts new_expr) + +substExpr (DictApp expr dicts) + = substExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + returnNF_Tc (DictApp new_expr new_dicts) + +substExpr (ClassDictLam dicts methods expr) + = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) + +substExpr (Dictionary dicts methods) + = mapNF_Tc applyTcSubstToId dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc applyTcSubstToId methods `thenNF_Tc` \ new_methods -> + returnNF_Tc (Dictionary new_dicts new_methods) + +substExpr (SingleDict name) + = applyTcSubstToId name `thenNF_Tc` \ new_name -> + returnNF_Tc (SingleDict new_name) + +#ifdef DPH + +substExpr (ParallelZF expr quals) + = substExpr expr `thenNF_Tc` \ new_expr -> + substParQuals quals `thenNF_Tc` \ new_quals -> + returnNF_Tc (ParallelZF new_expr new_quals) + +--substExpr (ExplicitPodIn exprs) :: not in typechecked + +substExpr (ExplicitPodOut ty exprs) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitPodOut new_ty new_exprs) + +substExpr (ExplicitProcessor exprs expr) + = mapNF_Tc substExpr exprs `thenNF_Tc` \ new_exprs -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (ExplicitProcessor new_exprs new_expr) + +#endif {- Data Parallel Haskell -} + +------------------------------------------------------------------------- +substArithSeq :: TypecheckedArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo + +substArithSeq (From e) + = substExpr e `thenNF_Tc` \ new_e -> + returnNF_Tc (From new_e) + +substArithSeq (FromThen e1 e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (FromThen new_e1 new_e2) + +substArithSeq (FromTo e1 e2) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (FromTo new_e1 new_e2) + +substArithSeq (FromThenTo e1 e2 e3) + = substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + substExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) + +------------------------------------------------------------------------- +substQuals :: [TypecheckedQual] -> NF_TcM [TypecheckedQual] + +substQuals quals + = mapNF_Tc subst_qual quals + where + subst_qual (GeneratorQual pat expr) + = substPat pat `thenNF_Tc` \ new_pat -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (GeneratorQual new_pat new_expr) + + subst_qual (FilterQual expr) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (FilterQual new_expr) + +------------------------------------------------------------------------- +#ifdef DPH +substParQuals :: TypecheckedParQuals -> NF_TcM TypecheckedParQuals + +substParQuals (AndParQuals quals1 quals2) + = substParQuals quals1 `thenNF_Tc` \ new_quals1 -> + substParQuals quals2 `thenNF_Tc` \ new_quals2 -> + returnNF_Tc (AndParQuals new_quals1 new_quals2) + +--substParQuals (DrawnGenIn pats pat expr) :: not in typechecked + +substParQuals (DrawnGenOut pats convs pat expr) + = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs -> + substPat pat `thenNF_Tc` \ new_pat -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (DrawnGenOut new_pats new_convs new_pat new_expr) + +substParQuals (IndexGen pats pat expr) + = mapNF_Tc substExpr pats `thenNF_Tc` \ new_pats -> + substPat pat `thenNF_Tc` \ new_pat -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (IndexGen new_pats new_pat new_expr) + +substParQuals (ParFilter expr) + = substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (ParFilter new_expr) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-Pats]{Patterns} +%* * +%************************************************************************ + +\begin{code} +substPat :: TypecheckedPat -> NF_TcM TypecheckedPat + +substPat (WildPat ty) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (WildPat new_ty) + +substPat (VarPat v) + = applyTcSubstToId v `thenNF_Tc` \ new_v -> + returnNF_Tc (VarPat new_v) + +substPat (LazyPat pat) + = substPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (LazyPat new_pat) + +substPat (AsPat n pat) + = applyTcSubstToId n `thenNF_Tc` \ new_n -> + substPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (AsPat new_n new_pat) + +substPat (ConPat n ty pats) + = applyTcSubstToId n `thenNF_Tc` \ new_n -> + -- ToDo: "n"'s global, so omit? + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + returnNF_Tc (ConPat new_n new_ty new_pats) + +substPat (ConOpPat pat1 op pat2 ty) + = substPat pat1 `thenNF_Tc` \ new_pat1 -> + applyTcSubstToId op `thenNF_Tc` \ new_op -> + substPat pat2 `thenNF_Tc` \ new_pat2 -> + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (ConOpPat new_pat1 new_op new_pat2 new_ty) + +substPat (ListPat ty pats) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + returnNF_Tc (ListPat new_ty new_pats) + +substPat (TuplePat pats) + = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + returnNF_Tc (TuplePat new_pats) + +substPat (LitPat lit ty) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (LitPat lit new_ty) + +substPat (NPat lit ty expr) + = applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + substExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (NPat lit new_ty new_expr) + +substPat (NPlusKPat n k ty e1 e2 e3) + = applyTcSubstToId n `thenNF_Tc` \ new_n -> + applyTcSubstToTy ty `thenNF_Tc` \ new_ty -> + substExpr e1 `thenNF_Tc` \ new_e1 -> + substExpr e2 `thenNF_Tc` \ new_e2 -> + substExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2 new_e3) + +#ifdef DPH +substPat (ProcessorPat pats convs pat) + = mapNF_Tc substPat pats `thenNF_Tc` \ new_pats -> + mapNF_Tc substExpr convs `thenNF_Tc` \ new_convs -> + substPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (ProcessorPat new_pats new_convs new_pat) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[BackSubst-TyVar]{Running a substitution over type variables} +%* * +%************************************************************************ + +The type variables in an @AbsBinds@ or @TyLam@ may have a binding in the +substitution as a result of a @matchTy@ call. So we should subsitute for +them too. The result should certainly be a type variable. + +\begin{code} +subst_tyvars tyvars + = mapNF_Tc applyTcSubstToTyVar tyvars `thenNF_Tc` \ new_tyvar_tys -> + returnNF_Tc (map (getTyVar "subst_tyvars") new_tyvar_tys) +\end{code} diff --git a/ghc/compiler/typecheck/Disambig.hi b/ghc/compiler/typecheck/Disambig.hi new file mode 100644 index 0000000..bf1fdf4 --- /dev/null +++ b/ghc/compiler/typecheck/Disambig.hi @@ -0,0 +1,32 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Disambig where +import Bag(Bag) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import Id(Id) +import Inst(Inst, InstOrigin, OverloadedLit) +import Maybes(Labda) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +import Unique(Unique, UniqueSupply) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +disambiguateDicts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/Disambig.lhs b/ghc/compiler/typecheck/Disambig.lhs new file mode 100644 index 0000000..be33671 --- /dev/null +++ b/ghc/compiler/typecheck/Disambig.lhs @@ -0,0 +1,162 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +%************************************************************************ +%* * +\section[Disambig]{Disambiguation of overloading} +%* * +%************************************************************************ + +\begin{code} +#include "HsVersions.h" + +module Disambig ( + disambiguateDicts, + + -- and for self-sufficiency... + Inst, Subst, UniqueSupply, Bag, Error(..), SrcLoc, + TcResult, Pretty(..), PprStyle, PrettyRep + ) where + +import TcMonad +import AbsSyn + +import AbsPrel ( intTyCon, intTy, {-ToDo:?voidTy,-} doubleTyCon ) +import AbsUniType ( applyTyCon, getTyVar, cmpTyVar, getClassKey, + isNumericClass, isStandardClass + ) +import Errors ( ambigErr, defaultErr, Error(..), UnifyErrContext(..) ) +import Id ( Id, DictVar(..) ) +import Inst --( Inst(..), InstOrigin(..), OverloadedLit ) +import InstEnv ( lookupClassInstAtSimpleType ) +import Maybes ( Maybe(..), firstJust ) +import SrcLoc ( mkUnknownSrcLoc ) +import TcSimplify ( tcSimplifyCheckThetas ) +import Unique ( cReturnableClassKey ) +import Util +\end{code} + +If a dictionary constrains a type variable which is +\begin{itemize} +\item +not mentioned in the environment +\item +and not mentioned in the type of the expression +\end{itemize} +then it is ambiguous. No further information will arise to instantiate +the type variable; nor will it be generalised and turned into an extra +parameter to a function. + +It is an error for this to occur, except that Haskell provided for +certain rules to be applied in the special case of numeric types. + +Specifically, if +\begin{itemize} +\item +at least one of its classes is a numeric class, and +\item +all of its classes are numeric or standard +\end{itemize} +then the type variable can be defaulted to the first type in the +default-type list which is an instance of all the offending classes. + +So here is the function which does the work. It takes the ambiguous +dictionaries and either resolves them (producing bindings) or +complains. It works by splitting the dictionary list by type +variable, and using @disambigOne@ to do the real business. + +IMPORTANT: @disambiguate@ assumes that its argument dictionaries +constrain only a simple type variable. + +\begin{code} +type SimpleDictInfo = (Inst, Class, TyVar) + +disambiguateDicts :: [Inst] -> TcM () + +disambiguateDicts insts + = mapTc disambigOne inst_infos `thenTc` \ binds_lists -> + returnTc () + where + inst_infos = equivClasses cmp_tyvars (map mk_inst_info insts) + (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmpTyVar` tv2 + + mk_inst_info dict@(Dict _ clas ty _) + = (dict, clas, getTyVar "disambiguateDicts" ty) +\end{code} + +@disambigOne@ assumes that its arguments dictionaries constrain all +the same type variable. + +ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to +@()@ instead of @Int@. I reckon this is the Right Thing to do since +the most common use of defaulting is code like: +\begin{verbatim} + _ccall_ foo `seqPrimIO` bar +\end{verbatim} +Since we're not using the result of @foo@, the result if (presumably) +@void@. +WDP Comment: no such thing as voidTy; so not quite in yet (94/07). + +\begin{code} +disambigOne :: [SimpleDictInfo] -> TcM () + +disambigOne dict_infos + | isCReturnable dict_infos + -- C-returnable; just default to Void + = extendSubstTc tyvar intTy{-ToDo:voidTy-} (AmbigDictCtxt dicts) + + | not (isStandardNumericDefaultable dict_infos) + = failTc (ambigErr dicts) -- no default + + | otherwise -- isStandardNumericDefaultable dict_infos + = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT + -- SO, TRY DEFAULT TYPES IN ORDER + + -- Failure here is caused by there being no type in the + -- default list which can satisfy all the ambiguous classes. + -- For example, if Real a is reqd, but the only type in the + -- default list is Int. + getDefaultingTys `thenNF_Tc` \ default_tys -> + + mapNF_Tc try_default default_tys `thenNF_Tc` \ maybe_tys -> + + checkMaybeTc (firstJust maybe_tys) + (defaultErr dicts default_tys) + `thenTc` \ chosen_default_ty -> + + -- SUCCESS; COMBINE TO A BINDS, AND EXTEND SUBSTITUTION + extendSubstTc tyvar chosen_default_ty (AmbigDictCtxt dicts) + + where + (_,_,tyvar) = head dict_infos -- Should be non-empty + dicts = [dict | (dict,_,_) <- dict_infos] + + try_default :: UniType -> NF_TcM (Maybe UniType) + + try_default default_ty + = let + thetas = [(clas, default_ty) | (_,clas,_) <- dict_infos] + in + recoverQuietlyTc Nothing ( -- if tcSimplify hates us, we get the Nothing + + tcSimplifyCheckThetas (DefaultDeclOrigin mkUnknownSrcLoc) thetas `thenTc` \ _ -> + returnTc (Just default_ty) + ) +\end{code} + +@isStandardNumericDefaultable@ sees whether the dicts have the +property required for defaulting; namely at least one is numeric, and +all are standard. + +\begin{code} +isCReturnable, isStandardNumericDefaultable :: [SimpleDictInfo] -> Bool + +isStandardNumericDefaultable dict_infos + = (any (\ (_,c,_) -> isNumericClass c) dict_infos) + && (all (\ (_,c,_) -> isStandardClass c) dict_infos) + +isCReturnable [(_,c,_)] = getClassKey c == cReturnableClassKey +isCReturnable _ = False -- duplicates will have been removed, + -- so we don't have to worry about + -- multiple copies of cReturnableClassKey... +\end{code} diff --git a/ghc/compiler/typecheck/GenSpecEtc.hi b/ghc/compiler/typecheck/GenSpecEtc.hi new file mode 100644 index 0000000..ce21175 --- /dev/null +++ b/ghc/compiler/typecheck/GenSpecEtc.hi @@ -0,0 +1,58 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface GenSpecEtc where +import Bag(Bag) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import E(E) +import ErrUtils(Error(..)) +import ErrsTc(UnifyErrContext) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsExpr(Expr) +import HsLit(Literal) +import HsPat(TypecheckedPat) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import LIE(LIE) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import SimplEnv(UnfoldingGuidance) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique, UniqueSupply) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data Bind a b {-# GHC_PRAGMA EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data LIE {-# GHC_PRAGMA MkLIE [Inst] #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data SignatureInfo = TySigInfo Id [TyVar] [Inst] UniType SrcLoc | ValSpecInfo Name UniType (Labda Name) SrcLoc | ValInlineInfo Name UnfoldingGuidance SrcLoc | ValDeforestInfo Name SrcLoc | ValMagicUnfoldingInfo Name _PackedString SrcLoc +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +checkSigTyVars :: [TyVar] -> [TyVar] -> UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [TyVar] + {-# GHC_PRAGMA _A_ 11 _U_ 22222222122 _N_ _S_ "LSLSLLLLU(AAS)LL" _N_ _N_ #-} +genBinds :: Bool -> E -> Bind Id TypecheckedPat -> LIE -> [(Name, Id)] -> [SignatureInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Binds Id TypecheckedPat, LIE, [(Name, Id)]) + {-# GHC_PRAGMA _A_ 12 _U_ 212112222122 _N_ _S_ "LU(AASA)LLLSLLLU(AAS)LL" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs new file mode 100644 index 0000000..c607157 --- /dev/null +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -0,0 +1,506 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[GenSpecEtc]{Code for GEN, SPEC, PRED, and REL} + +\begin{code} +#include "HsVersions.h" + +module GenSpecEtc ( + genBinds, SignatureInfo(..), + checkSigTyVars, + + -- and to make the interface self-sufficient... + Bag, E, Bind, Binds, TypecheckedPat, Id, Inst, + LIE, TcResult, Name, SrcLoc, Subst, TyVar, UniType, + UniqueSupply, Error(..), Pretty(..), PprStyle, + PrettyRep + ) where + +import TcMonad -- typechecker monadery +import TcMonadFns ( applyTcSubstAndCollectTyVars, + mkIdsWithGivenTys + ) +import AbsSyn + +import AbsUniType +import E ( tvOfE, E, LVE(..), TCE(..), UniqFM, CE(..) ) + -- TCE and CE for pragmas only +import Errors +import Id ( getIdUniType, mkInstId, Id, DictVar(..) ) +import IdInfo +import Inst +import LIE ( mkLIE, unMkLIE, LIE ) +import ListSetOps ( minusList, unionLists, intersectLists ) +import Maybes ( assocMaybe, Maybe(..) ) +import Name ( Name(..) ) -- ToDo: a HACK +import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) +import Util + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty -- +\end{code} + +%************************************************************************ +%* * +\subsection[Gen-SignatureInfo]{The @SignatureInfo@ type} +%* * +%************************************************************************ + +A type signature (or user-pragma) is typechecked to produce a +@SignatureInfo@. + +\begin{code} +data SignatureInfo + = TySigInfo Id -- for this value... + [TyVar] [Inst] TauType + SrcLoc + + | ValSpecInfo Name -- we'd rather have the Name than Id... + UniType + (Maybe Name) + SrcLoc + + | ValInlineInfo Name + UnfoldingGuidance + SrcLoc + + | ValDeforestInfo Name + SrcLoc + + | ValMagicUnfoldingInfo + Name + FAST_STRING + SrcLoc + + -- ToDo: perhaps add more (for other user pragmas) +\end{code} + + +%************************************************************************ +%* * +\subsection[Gen-GEN]{Generalising bindings} +%* * +%************************************************************************ + +\begin{code} +genBinds :: Bool -- True <=> top level + -> E + -> TypecheckedBind + -> LIE -- LIE from typecheck of binds + -> LVE -- Local types + -> [SignatureInfo] -- Signatures, if any + -> TcM (TypecheckedBinds, LIE, LVE) -- Generalised binds, reduced LIE, + -- polymorphic LVE + -- The LVE and LIE are fixed points + -- of the substitution +\end{code} + +In the call $(@genBinds@~env~bind~lie~lve)$, $(bind,lie,lve)$ +is the result of typechecking a @Bind@. @genBinds@ implements the BIND-GEN +and BIND-PRED rules. +$lie$ and $lve$ may or may not be +fixed points of the current substitution. + +It returns +\begin{itemize} +\item +An @AbsBind@ which wraps up $bind$ in a suitable abstraction. +\item +an LIE, which is the part of the input LIE which isn't discharged by +the AbsBind. This means the parts which predicate type variables +free in $env$. +\item +An LVE whose domain is identical to that passed in. +Its range is a new set of locals to that passed in, +because they have been gen'd. +\end{itemize} + +@genBinds@ takes the +following steps: +\begin{itemize} +\item +find $constrained$, the free variables of $env$. +First we must apply the current substitution to the environment, so that the +correct set of constrained type vars are extracted! +\item +find $free$, the free variables of $lve$ which are not in $constrained$. +We need to apply the current subsitution to $lve$ first, of course. +\item +minimise $lie$ to give $lie'$; all the constraints in $lie'$ are on +single type variables. +\item +split $lie'$ into three: those predicating type variables in $constrained$, +those on type variables in $free$, and the rest. +\item +complain about ``the rest'' part of $lie'$. These type variables are +ambiguous. +\item +generate new locals for each member of the domain of $lve$, with appropriately +gen'd types. +\item +generate a suitable AbsBinds to enclose the bindings. +\end{itemize} + +\begin{code} +genBinds top_level e bind lie lve sigs + = getSrcLocTc `thenNF_Tc` \ locn -> + + -- GET TYPE VARIABLES FREE IN ENV + applyTcSubstAndCollectTyVars (tvOfE e) `thenNF_Tc` \ free_tyvars -> + + -- CHECK THAT THE SIGNATURES MATCH + -- Doesn't affect substitution + mapTc (checkSigMatch free_tyvars) sigs `thenTc_` + + -- UNPACK THE LVE + let + (bound_var_names, bound_var_locals) = unzip lve + bound_var_types = map getIdUniType bound_var_locals + in + applyTcSubstToTys bound_var_types `thenNF_Tc` \ bound_var_types' -> + let + mentioned_tyvars' = extractTyVarsFromTys bound_var_types' + + -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen + tyvars_to_gen = mentioned_tyvars' `minusList` free_tyvars + + -- UNSCRAMBLE "sigs" INTO VARIOUS FLAVOURS + -- AND SNAFFLE ANY "IdInfos" FOR VARS HERE + + (ty_sigs, upragmas) = partition is_tysig_info sigs + inline_sigs = filter is_inline_info upragmas + deforest_sigs = filter is_deforest_info upragmas + magic_uf_sigs = filter is_magic_uf_info upragmas + spec_sigs = filter is_spec_info upragmas + + unfold_me_fn n + = case [ x | x@(ValInlineInfo v _ _) <- inline_sigs, v == n ] of + (ValInlineInfo _ guide _ :_) -> iWantToBeINLINEd guide + [] -> + case [ x | x@(ValMagicUnfoldingInfo v _ _) <- magic_uf_sigs, v == n ] of + (ValMagicUnfoldingInfo _ str _:_) -> mkMagicUnfolding str + [] -> noInfo_UF + + deforest_me_fn n + = case [ x | x@(ValDeforestInfo v _) <- deforest_sigs, v == n ] of + (ValDeforestInfo _ _ : _) -> DoDeforest + [] -> Don'tDeforest + + id_info_for n + = noIdInfo + `addInfo_UF` (unfold_me_fn n) + `addInfo` (deforest_me_fn n) + + id_infos = [ id_info_for n | n <- bound_var_names ] + in + resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs + `thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) -> + + -- BUILD THE NEW LOCALS + let + dict_tys = map getInstUniType dicts_bound + + envs_and_new_locals_types + = map (quantifyTy reduced_tyvars_to_gen . glueTyArgs dict_tys) bound_var_types' + + (_, new_locals_types) = unzip envs_and_new_locals_types + in + -- The new_locals function is passed into genBinds + -- so it can generate top-level or non-top-level locals + let + lve_of_new_ids = mkIdsWithGivenTys bound_var_names new_locals_types id_infos + new_ids = map snd lve_of_new_ids + in + -- BUILD RESULTS + returnTc ( +-- pprTrace "Gen: " (ppSep [ppr PprDebug new_ids, +-- ppStr "; to gen ", ppr PprDebug tyvars_to_gen, +-- ppStr "; reduced ", ppr PprDebug reduced_tyvars_to_gen +-- ]) $ + AbsBinds reduced_tyvars_to_gen (map mkInstId dicts_bound) + (bound_var_locals `zip` new_ids) + dict_binds bind, + lie', + lve_of_new_ids + ) + where + is_tysig_info (TySigInfo _ _ _ _ _) = True + is_tysig_info _ = False + + is_inline_info (ValInlineInfo _ _ _) = True + is_inline_info _ = False + + is_deforest_info (ValDeforestInfo _ _) = True + is_deforest_info _ = False + + is_magic_uf_info (ValMagicUnfoldingInfo _ _ _) = True + is_magic_uf_info _ = False + + is_spec_info (ValSpecInfo _ _ _ _) = True + is_spec_info _ = False +\end{code} + + +\begin{code} +resolveOverloading + :: Bool -- True <=> top level + -> E + -> [TyVar] -- Tyvars free in E + -> [TyVar] -- Tyvars over which we are going to generalise + -> LIE -- The LIE to deal with + -> TypecheckedBind -- The binding group + -> [SignatureInfo] -- And its real type-signature information + -> TcM (LIE, -- LIE to pass up the way; a fixed point of + -- the current substitution + [TyVar], -- Revised tyvars to generalise + [(Inst, TypecheckedExpr)],-- Dict bindings + [Inst]) -- List of dicts to bind here + +resolveOverloading top_level e free_tyvars tyvars_to_gen lie bind ty_sigs + = let + dicts = unMkLIE lie + in + -- DEAL WITH MONOMORPHISM RESTRICTION + if (not (isUnRestrictedGroup tysig_vars bind)) then + + -- Restricted group, so bind no dictionaries, and + -- remove from tyvars_to_gen any constrained type variables + + -- *Don't* simplify dicts at this point, because we aren't going + -- to generalise over these dicts. By the time we do simplify them + -- we may well know more. For example (this actually came up) + -- f :: Array Int Int + -- f x = array ... xs where xs = [1,2,3,4,5] + -- We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) + -- stuff. If we simplify only at the f-binding (not the xs-binding) + -- we'll know that the literals are all Ints, and we can just produce + -- Int literals! + + -- Find all the type variables involved in overloading + -- These are the ones we *aren't* going to generalise. + -- We must be careful about doing this: + -- (a) If we fail to generalise a tyvar which is not actually + -- constrained, then it will never, ever get bound, and lands + -- up printed out in interface files! Notorious example: + -- instance Eq a => Eq (Foo a b) where .. + -- Here, b is not constrained, even though it looks as if it is. + -- Another, more common, example is when there's a Method inst in + -- the LIE, whose type might very well involve non-overloaded + -- type variables. + -- (b) On the other hand, we mustn't generalise tyvars which are constrained, + -- because we are going to pass on out the unmodified LIE, with those + -- tyvars in it. They won't be in scope if we've generalised them. + -- + -- So we are careful, and do a complete simplification just to find the + -- constrained tyvars. We don't use any of the results, except to + -- find which tyvars are constrained. + + tcSimplify top_level free_tyvars tyvars_to_gen dicts + `thenTc` \ (_, _, dicts_sig) -> + +-- ASSERT: tcSimplify has already applied subst to its results +-- (WDP/SLPJ 95/07) +-- applyTcSubstToInsts dicts_sig `thenNF_Tc` \ dicts_sig' -> + let + constrained_tyvars + = foldr (unionLists . extractTyVarsFromInst) [] dicts_sig + + reduced_tyvars_to_gen = tyvars_to_gen `minusList` constrained_tyvars + + increased_free_tyvars = free_tyvars `unionLists` constrained_tyvars + in + + -- Do it again, but with increased_free_tyvars/reduced_tyvars_to_gen: + + tcSimplify top_level increased_free_tyvars reduced_tyvars_to_gen dicts + `thenTc` \ (dicts_free, dicts_binds, dicts_sig2) -> +--NB: still no applyTcSubstToInsts + +-- pprTrace "resolve:" (ppCat [ppr PprDebug free_tyvars, ppr PprDebug tyvars_to_gen, ppr PprDebug constrained_tyvars, ppr PprDebug reduced_tyvars_to_gen, ppr PprDebug bind]) $ + returnTc (mkLIE (dicts_free++dicts_sig2), -- All these are left unbound + reduced_tyvars_to_gen, + dicts_binds, -- Local dict binds + []) -- No lambda-bound dicts + + -- The returned LIE should be a fixed point of the substitution + + else -- Unrestricted group + case ty_sigs of + [] -> -- NO TYPE SIGNATURES + + tcSimplify top_level free_tyvars tyvars_to_gen dicts + `thenTc` \ (dicts_free, dict_binds, dicts_sig) -> + returnTc (mkLIE dicts_free, tyvars_to_gen, dict_binds, dicts_sig) + + other -> -- TYPE SIGNATURES PRESENT! + + -- Check that all the signature contexts are identical + -- "tysig_dicts_s" is a list (one for each id declared + -- in this group) of lists of dicts (the list + -- corresponds to the context in the sig). + -- "dicts_sig" is just the first such list; we match + -- it against all the others. + + mapNF_Tc applyTcSubstToInsts tysig_dicts_s + `thenNF_Tc` \ (dicts_sig : other_dicts_s) -> + + checkTc (not (all (same_dicts dicts_sig) other_dicts_s)) + -- The type signatures on a mutually-recursive group of definitions + -- must all have the same context (or none). See Errors.lhs. + (sigContextsErr ty_sigs) `thenTc_` + + -- Check that the needed dicts can be expressed in + -- terms of the signature ones + tcSimplifyAndCheck + top_level + free_tyvars -- Vars free in the environment + tyvars_to_gen -- Type vars over which we will quantify + dicts_sig -- Available dicts + dicts -- Want bindings for these dicts + (BindSigCtxt tysig_vars) + + `thenTc` \ (dicts_free, dict_binds) -> + + returnTc (mkLIE dicts_free, tyvars_to_gen, dict_binds, dicts_sig) + where + tysig_dicts_s = [dicts | (TySigInfo _ _ dicts _ _) <- ty_sigs] + tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs] + + -- same_dicts checks that (post substitution) all the type signatures + -- constrain the same type variables in the same way + same_dicts [] [] = True + same_dicts [] _ = False + same_dicts _ [] = False + same_dicts (d1:d1s) (d2:d2s) = matchesInst d1 d2 && same_dicts d1s d2s + + -- don't use the old version, because zipWith will truncate + -- the longer one! + --OLD: same_dicts dicts1 dicts2 = and (zipWith matchesInst dicts1 dicts2) +\end{code} + +@checkSigMatch@ does the next step in checking signature matching. +The tau-type part has already been unified. What we do here is to +check that this unification has not over-constrained the (polymorphic) +type variables of the original signature type. + +The error message here is somewhat unsatisfactory, but it'll do for +now (ToDo). + +\begin{code} +checkSigMatch :: [TyVar] -- Free in environment + -> SignatureInfo + -> TcM [TyVar] + +checkSigMatch env_tyvars (TySigInfo name sig_tyvars _ tau_ty src_loc) + = let + inferred_ty = getIdUniType name + in + addSrcLocTc src_loc ( + checkSigTyVars env_tyvars sig_tyvars tau_ty inferred_ty + (SigCtxt name tau_ty) + ) + +checkSigMatch _ other_not_really_a_sig = returnTc [] +\end{code} + + +%************************************************************************ +%* * +\subsection[GenEtc-monomorphism]{The monomorphism restriction} +%* * +%************************************************************************ + +Not exported: + +\begin{code} +isUnRestrictedGroup :: [Id] -- Signatures given for these + -> TypecheckedBind + -> Bool + +isUnRestrictedGroup sigs EmptyBind = True +isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds +isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds + +is_elem = isIn "isUnResMono" + +isUnResMono sigs EmptyMonoBinds = True +isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 && isUnResMono sigs mb2 +isUnResMono sigs (PatMonoBind (VarPat v) _ _) = v `is_elem` sigs +isUnResMono sigs (PatMonoBind other _ _) = False +isUnResMono sigs (VarMonoBind v _) = v `is_elem` sigs +isUnResMono sigs (FunMonoBind _ _ _) = True +\end{code} + + +%************************************************************************ +%* * +\subsection[GenEtc-sig]{Matching a type signature} +%* * +%************************************************************************ + +@checkSigTyVars@ is used after the type in a type signature has been unified with +the actual type found. It then checks that the type variables of the type signature +are + (a) still all type variables + eg matching signature [a] against inferred type [(p,q)] + [then a will be unified to a non-type variable] + + (b) still all distinct + eg matching signature [(a,b)] against inferred type [(p,p)] + [then a and b will be unified together] + + (c) not mentioned in the environment + eg the signature for f in this: + + g x = ... where + f :: a->[a] + f y = [x,y] + + Here, f is forced to be monorphic by the free occurence of x. + +Before doing this, the substitution is applied to the signature type variable. + +It's {\em assumed} that the substitution has already been applied to the +environment type variables. + +\begin{code} +checkSigTyVars :: [TyVar] -- Tyvars free in environment; + -- fixed points of substitution + -> [TyVar] -- The original signature type variables + -> UniType -- signature type (for err msg) + -> UniType -- inferred type (for err msg) + -> UnifyErrContext -- also for error msg + -> TcM [TyVar] -- Post-substitution signature type variables + +checkSigTyVars env_tyvars sig_tyvars sig_tau inferred_tau err_ctxt + = getSrcLocTc `thenNF_Tc` \ locn -> + applyTcSubstToTy inferred_tau `thenNF_Tc` \ inferred_tau' -> + let + match_err = badMatchErr sig_tau inferred_tau' err_ctxt locn + in + applyTcSubstToTyVars sig_tyvars `thenNF_Tc` \ sig_tys -> + + -- Check point (a) above + checkMaybesTc (map getTyVarMaybe sig_tys) match_err `thenTc` \ sig_tyvars' -> + + -- Check point (b) + checkTc (not (hasNoDups sig_tyvars')) match_err `thenTc_` + + -- Check point (c) + -- We want to report errors in terms of the original signature tyvars, + -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond + -- 1-1 with sig_tyvars, so we can just map back. + let + is_elem = isIn "checkSigTyVars" + + mono_tyvars = [ sig_tyvar + | (sig_tyvar,sig_tyvar') <- zipEqual sig_tyvars sig_tyvars', + sig_tyvar' `is_elem` env_tyvars + ] + in + checkTc (not (null mono_tyvars)) + (notAsPolyAsSigErr sig_tau mono_tyvars err_ctxt locn) `thenTc_` + + returnTc sig_tyvars' +\end{code} diff --git a/ghc/compiler/typecheck/Jmakefile b/ghc/compiler/typecheck/Jmakefile new file mode 100644 index 0000000..3e0bd41 --- /dev/null +++ b/ghc/compiler/typecheck/Jmakefile @@ -0,0 +1,11 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) +HaskellSuffixRules() + +/* LIT2LATEX_OPTS=-tbird */ + +LIT2LATEX_OPTS=-ttgrind + +LitDocRootTargetWithNamedOutput(root,lit,root-standalone) diff --git a/ghc/compiler/typecheck/Spec.hi b/ghc/compiler/typecheck/Spec.hi new file mode 100644 index 0000000..6f67f4b --- /dev/null +++ b/ghc/compiler/typecheck/Spec.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Spec where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import HsExpr(Expr) +import HsPat(TypecheckedPat) +import Id(Id) +import Inst(Inst, InstOrigin) +import LIE(LIE) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TyVar(TyVar) +import UniType(UniType) +specId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((Expr Id TypecheckedPat, LIE, UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2002222 _N_ _S_ "U(LSLL)AALLLL" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +specTy :: InstOrigin -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([TyVar], [Inst], UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 22002120 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/Spec.lhs b/ghc/compiler/typecheck/Spec.lhs new file mode 100644 index 0000000..7bee36a --- /dev/null +++ b/ghc/compiler/typecheck/Spec.lhs @@ -0,0 +1,158 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +%************************************************************************ +%* * +\section[Spec]{Specialisation of variables} +%* * +%************************************************************************ + +One thing which happens {\em a lot} is the instantiation of a type scheme +caused by the occurrence of a variable. It is so important that it +is written below in a very ``open-code'' fashion. All the modular monadery +is discarded, and we work directly in terms of the underlying representations. +In particular, this function knows about + + - the TcM monad + - the representation of UniTypes + +\begin{code} +#include "HsVersions.h" + +module Spec ( specId, specTy ) where + +import AbsSyn +import TcMonadFns ( copyTyVars, newDicts ) +import TcMonad + +import AbsUniType {- ( instantiateTauTy, instantiateThetaTy, + cloneTyVarFromTemplate, splitType + ) -} -- pragmas want to see it all! +import Id ( getIdUniType, mkInstId, DictVar(..) ) +import Inst -- ( mkMethod, InstOrigin(..), Inst, InstTemplate, SpecInfo ) +import LIE +import Subst ( getSubstTyVarUnique ) +import UniType -- known **GRIEVOUS** violation of UniType abstractness!!! +import SplitUniq +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Spec-specId]{Instantiating an Id} +%* * +%************************************************************************ + +@specId@ takes an @Id@ and implements the SPEC and REL rules +returning + - the id applied to suitable types and dictionaries + - the LIE + - its instantiated tau type + +For efficiency, it knows about the TcM implementation. + +\begin{code} +specId :: Id -> NF_TcM (TypecheckedExpr, LIE, TauType) + +specId id sw_chkr dtys subst uniq errs src_loc + = case (spec_sigma subst uniq src_loc id (getIdUniType id)) of + (result, subst2) -> (result, subst2, errs) +\end{code} + +\begin{code} +spec_sigma :: Subst -- TyVar unique supply inside *here* + -> SplitUniqSupply -- "normal" unique supply + -> SrcLoc + -> Id + -> UniType + -> ((TypecheckedExpr, LIE, TauType), Subst) + +spec_sigma subst uniq src_loc id (UniSyn _ _ ty) + = spec_sigma subst uniq src_loc id ty + +spec_sigma subst uniq src_loc id ty@(UniForall _ _) + = collect [] [] subst ty + where + collect tenv tyvar_tys subst (UniForall tyvar ty) + = case (getSubstTyVarUnique subst) of + (subst', u) -> + collect ((tyvar, new_tyvar_ty) : tenv) + (new_tyvar_ty : tyvar_tys) + subst' ty + where + new_tyvar_ty = UniTyVar (cloneTyVarFromTemplate tyvar u) + + collect tenv tyvar_tys subst ty + = spec_rho tenv (reverse tyvar_tys) subst uniq src_loc id ty + +spec_sigma subst uniq src_loc id tau_ty + -- Not polymorphic => cannot be overloaded + = ((Var id, nullLIE, tau_ty), subst) +\end{code} + +\begin{code} +spec_rho :: [(TyVarTemplate, UniType)] -> [UniType] + -> Subst -> SplitUniqSupply -> SrcLoc + -> Id -> UniType + -> ((TypecheckedExpr, LIE, TauType), Subst) + +spec_rho tenv tys subst uniqs src_loc id (UniSyn _ _ ty) + = spec_rho tenv tys subst uniqs src_loc id ty + +spec_rho tenv tys subst uniqs src_loc id (UniFun (UniDict _ _) ty) + = ((Var inst_id, unitLIE method, instantiateTauTy tenv tau_ty), + subst) + where + method = mkMethod u id tys (OccurrenceOf id src_loc) + inst_id = mkInstId method + u = getSUnique uniqs + tau_ty = discard_dicts ty + + discard_dicts (UniFun (UniDict _ _) ty) = discard_dicts ty + discard_dicts other_ty = other_ty + +spec_rho tenv tys subst uniqs src_loc id tau_ty + = ((TyApp (Var id) tys, nullLIE, instantiateTauTy tenv tau_ty), + subst) +\end{code} + + +%************************************************************************ +%* * +\subsection[Spec-specTy]{Instantiating a type} +%* * +%************************************************************************ + +@specTy@ takes a polymorphic type, and instantiates it with fresh type +variables. It strips off the context part, gets fresh dictionary +variables for each predicate in the context. It returns + + - a list of the dictionary variables (remember they contain + their types) + - an instantiated tau-type + +The returned values are fixed points of the current substitution +though the arguments may not be. + +\begin{code} +specTy :: InstOrigin -> SigmaType -> NF_TcM ([TyVar], [Inst], TauType) + +specTy origin sigma_ty + = let + (old_tyvars, theta, tau_ty) = splitType sigma_ty + in + -- make new tyvars for each of the universally quantified type vars + copyTyVars old_tyvars `thenNF_Tc` \ (inst_env, new_tyvars, _) -> + + -- instantiate the tau type + let + tau_ty' = instantiateTauTy inst_env tau_ty + in + -- instantiate the dictionary types + newDicts origin (instantiateThetaTy inst_env theta) `thenNF_Tc` \ dicts -> + + -- return the list of tyvars, the list of dicts and the tau type + returnNF_Tc ( new_tyvars, dicts, tau_ty' ) +\end{code} + diff --git a/ghc/compiler/typecheck/Subst.hi b/ghc/compiler/typecheck/Subst.hi new file mode 100644 index 0000000..d83f503 --- /dev/null +++ b/ghc/compiler/typecheck/Subst.hi @@ -0,0 +1,36 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Subst where +import Bag(Bag) +import Class(Class) +import Maybes(Labda) +import NameTypes(ShortName) +import PreludeGlaST(_MutableArray) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +data SubstResult = SubstOK | OccursCheck TyVar UniType | AlreadyBound UniType +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +applySubstToThetaTy :: Subst -> [(Class, UniType)] -> (Subst, [(Class, UniType)]) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +applySubstToTy :: Subst -> UniType -> (Subst, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +applySubstToTyVar :: Subst -> TyVar -> (Subst, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +combineSubstUndos :: Subst -> Subst + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSLL)" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +extendSubst :: TyVar -> UniType -> Subst -> (Subst, SubstResult) + {-# GHC_PRAGMA _A_ 2 _U_ 221 _N_ _N_ _N_ _N_ #-} +getSubstTyVarUnique :: Subst -> (Subst, Unique) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(U(LU(P))P)LLU(P))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique]) + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(U(U(LU(P))P)LLU(P))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mkEmptySubst :: Int -> Subst + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +pushSubstUndos :: Subst -> Subst + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +undoSubstUndos :: Subst -> Subst + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSLL)" {_A_ 4 _U_ 2112 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/Subst.lhs b/ghc/compiler/typecheck/Subst.lhs new file mode 100644 index 0000000..f5fad7f --- /dev/null +++ b/ghc/compiler/typecheck/Subst.lhs @@ -0,0 +1,827 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Subst]{Substitutions} + +\begin{code} +#include "HsVersions.h" + +module Subst ( + Subst, SubstResult(..), -- Subst is an abstract data type + + mkEmptySubst, extendSubst, + +--not exported: applySubstToTauTy, + applySubstToTy, + applySubstToThetaTy, applySubstToTyVar, + + getSubstTyVarUniques, getSubstTyVarUnique, + + pushSubstUndos, combineSubstUndos, undoSubstUndos, + -- pruneSubst, + + -- and to make the interface self-sufficient... + TyVar, UniType + ) where + +import AbsUniType -- lots of stuff, plus... +import UniType -- UniType(..) -- *********** YOW!!! ******** +import Bag ( emptyBag, unionBags, snocBag, + bagToList, filterBag, unitBag, Bag ) +import Maybes ( Maybe(..), maybeToBool ) +import Outputable +import Unique +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Subst-magic-importst]{Funny imports to support magic implementation} +%* * +%************************************************************************ + +Or lack thereof. + +If we are compiling with Glasgow Haskell we can use mutable +arrays to implement the substitution ... + +\begin{code} +#ifndef __GLASGOW_HASKELL__ + +import LiftMonad + +#else {- __GLASGOW_HASKELL__ -} + +import PreludeGlaST + +type STWorld = _State _RealWorld + +newWorld (S# real_world) = S# real_world + +#endif {- __GLASGOW_HASKELL__ -} +\end{code} + +%************************************************************************ +%* * +\subsection[Subst-common]{@Subst@: common implementation-independent bits} +%* * +%************************************************************************ + +\begin{code} +data SubstResult + = SubstOK + | OccursCheck TyVar + TauType + | AlreadyBound TauType -- The variable is already bound + -- to this type. The type is *not* + -- necessarily a fixed pt of the + -- substitution +\end{code} + +Common signatures of major functions. + +\begin{code} +mkEmptySubst :: Int -> Subst +\end{code} + +%--------- + +@extendSubst@: Add a single binding to the substitution. We have to: +\begin{itemize} +\item +apply the existing bindings to the new one; +\item +check whether we are adding a trivial substitution of a type +variable to itself (if so, do nothing); +\item +perform an occurs check on the right-hand side of the new binding; +\end{itemize} +We do not apply the new binding to all the existing ones. This is +delayed until the substitution is applied. +\begin{code} +extendSubst :: TyVar -- Tyvar to bind + -> TauType -- Type to bind it to; NB can be a synonym + -> SubstM SubstResult +\end{code} + +%--------- + +Apply a substitution to a given type. + + {\em The type returned is guaranteed to be + a fixed point of the substitution.} + +Hence, we have to traverse the type determining the type mapped to +tyvars. The type mapped must be recusively traversed as the substition +is not stored idempotently. + +@applySubstToTauTy@ does not expect to meet a dict or forall type. +@applySubstToTy@ may encounter these, but complains if the forall +binds a variable which is in the domain of the substitution. + +\begin{code} +applySubstToTy :: Subst -> UniType -> (Subst, UniType) +applySubstToTauTy :: Subst -> TauType -> (Subst, TauType) +applySubstToThetaTy :: Subst -> ThetaType -> (Subst, ThetaType) +applySubstToTyVar :: Subst -> TyVar -> (Subst, TauType) +\end{code} + +These functions are only used by the type checker. We know that +all the for-all'd type variables are fixed points of the substitution, +so it's quite safe just to apply the substitution inside foralls. + +%--------- + +Sorta obvious. +\begin{code} +getSubstTyVarUnique :: Subst -> (Subst, Unique) +getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique]) +\end{code} + +%--------- + +@pushSubstUndos@ starts a new subst undo scope, saving the old scopes. +It also saves the current unique supply so that it can be restored if +the typecheck fails. + +@combineSubstUndos@ is called after a successful typecheck. It +combines the current undos with the previos ones in case we fail in an +outer scope. If no previous undos exist the undos are thrown away as +we must have succeeded at the top level. The unique supply of the +successful scope is returned to the unique supply of the current +scope. + +@undoSubstUndos@ is called when a typecheck failed. The any +substitution modifications are undone and the undo information +discarded. The saved unique supply of the enclosing scope is restored. +\begin{code} +pushSubstUndos, combineSubstUndos, undoSubstUndos :: Subst -> Subst +\end{code} + +%************************************************************************ +%* * +\subsection[Subst-Arrays]{@Subst@ with mutable @Arrays@ !!!} +%* * +%************************************************************************ + +Depends on.... +\begin{code} +#ifdef __GLASGOW_HASKELL__ +\end{code} + +%************************************************************************ +%* * +\subsubsection{@Subst@: specification and representation} +%* * +%************************************************************************ + +{\em Specification:} +* When new bindings are added to the substitution, an occurs check is performed. +* The applySubst function guarantees to return a fixed point of the substitution. + +{\em Representation:} +A substitution binds type variables to tau-types, that is @UniType@s without +any @UniForall@ or @UniDict@ constructors. + +It is represented as an array, indexed on Int, with a world +token, and a stack of type variables whos subst may be undone. The +array is extended (by copying) if it overflows. The supply of +Ints and the size of the array are linked so the substitution +is also responsible for allocating the supply of uniques. + +The undo information is a stack of bags of the nested modifications to +the substitution. If the typecheck fails the modifications to the +substition are undone. If it succeeds the current undos are combined +with the undos in the enclosing scope so that they would be undone if +the enclsing scope typecheck fails. + +The unique supply is also stacked so that it can be restored if a +typecheck fails. + +NOTE: The uniqueness of the world token, and hence the substitution, +is critical as the 'worldSEQ' operation is unsafe if the token can be +duplicated!!! + +\begin{code} +type SubstArray = _MutableArray _RealWorld Int (Maybe TauType) + +type SubstArrayIndex = Int -- Allocated within this module, single-threadedly + +data Subst + = MkSubst SubstArray -- Mapping for allocated tyvars + + [(SubstArrayIndex, Bag (SubstArrayIndex, Maybe TauType))] + -- Stack to be undone if we fail, plus next free + -- slot when reverting. All the undos are for + -- slots earlier than the corresp "next free" index. + -- + -- The "bag" is a lie: it's really a sequence, with + -- the most recently performed write appearing first. + + STWorld -- State token + + SubstArrayIndex -- Next free slot +\end{code} + +Here's a local monad for threading the substitution around: + +\begin{code} +type SubstM a = Subst -> (Subst,a) + +returnSubstM x = \s -> (s,x) +thenSubstM m k = \s -> case m s of { (s1, r) -> k r s1 } + +mapSubstM f [] = returnSubstM [] +mapSubstM f (x:xs) = f x `thenSubstM` \ r -> + mapSubstM f xs `thenSubstM` \ rs -> + returnSubstM (r:rs) + +-- Breaks the ST abstraction. But we have to do so somewhere... +doST :: STWorld -> ST _RealWorld a -> (a, STWorld) +doST w st = st w +\end{code} + +%******************************************************** +%* * +\subsubsection{@Subst@: the array} +%* * +%******************************************************** + +\begin{code} +writeSubst :: SubstArrayIndex -> Maybe TauType -> SubstM () + -- writeSubst writes in such a way that we can undo it later + +writeSubst index new_val + (MkSubst arr undo_stack@((checkpoint, undos):rest_undo_stack) + world next_free) + | index < checkpoint -- Record in undos + = let + (old, new_world) = doST world ( + readArray arr index `thenStrictlyST` \ old_val -> + writeArray arr index new_val `seqStrictlyST` + returnStrictlyST old_val + ) + new_undos = unitBag (index,old) `unionBags` undos + -- The order is significant! The right most thing + -- gets undone last + in + (MkSubst arr ((checkpoint, new_undos) : rest_undo_stack) new_world next_free, ()) + +writeSubst index new_val (MkSubst arr undo_stack world next_free) + -- No need to record in undos: undo_stack is empty, + -- or index is after checkpoint + = let + (_, new_world) = doST world (writeArray arr index new_val) + in + (MkSubst arr undo_stack new_world next_free, ()) + +readSubst :: SubstArrayIndex -> SubstM (Maybe TauType) +readSubst index (MkSubst arr undos world supplies) + = let + (result, new_world) = doST world (readArray arr index) + in + (MkSubst arr undos new_world supplies, result) + +tyVarToIndex :: TyVar -> SubstArrayIndex +tyVarToIndex tyvar = unpkUnifiableTyVarUnique (getTheUnique tyvar) +\end{code} + +%******************************************************** +%* * +\subsubsection{@Subst@: building them} +%* * +%******************************************************** + +The function @mkEmptySubst@ used to be a CAF containing a mutable +array. The imperative world had a name for this kind of thing: +``global variable'' and has observed that using these ``global variables'' +leads to something they call ``side effects''. + +These ``side effects'' never caused a problem for @hsc@ because empty +substitutions are only used in one place (the typechecker) and only +used once in every program run. In \tr{ghci} however, we might use the +typechecker several times---in which case we'd like to have a +different (fresh) substitution each time. The easy way (HACK) to +achieve this is to deCAFinate so that a fresh substitution will be +created each time the typechecker runs. + +\begin{code} +aRRAY_START :: Int +aRRAY_START = 0 + +mkEmptySubst aRRAY_SIZE + = let + world = newWorld (S# realWorld#) + (arr, new_world) = doST world (newArray (aRRAY_START,aRRAY_SIZE) Nothing) + in + MkSubst arr [] new_world aRRAY_START + +extendSubstArr :: Subst + -> Subst +extendSubstArr (MkSubst old_arr undos world next_free) + = let + -- these "sizes" are really end-limits (WDP 94/11) + cur_size = case (boundsOfArray old_arr) of { (_, x) -> x } + new_size = (cur_size * 2) + 1 + + (new_arr, new_world) = doST world ( + newArray (aRRAY_START,new_size) Nothing `thenStrictlyST` \ new_arr -> + let + copyArr pos + | pos > cur_size = returnStrictlyST () + | otherwise + = readArray old_arr pos `thenStrictlyST` \ ele -> + writeArray new_arr pos ele `seqStrictlyST` + copyArr (pos + 1) + in + copyArr aRRAY_START `seqStrictlyST` + returnStrictlyST new_arr + ) + in + MkSubst new_arr undos new_world next_free +\end{code} + +\begin{code} +extendSubst tyvar tau_ty + = readSubst index `thenSubstM` \ maybe_ty -> + + case maybe_ty of + Just exist_ty -> -- Bound already + returnSubstM (AlreadyBound exist_ty) + + Nothing -> -- Not already bound + apply_rep_to_ty tau_ty `thenSubstM` \ new_tau_ty -> + case expandVisibleTySyn new_tau_ty of + UniTyVar tv | tv `eqTyVar` tyvar -> + -- Trivial new binding of a type variable to itself; + -- return old substition + returnSubstM SubstOK + + other | tyvar `is_elem` (extractTyVarsFromTy new_tau_ty) -> + -- Occurs check finds error + returnSubstM (OccursCheck tyvar new_tau_ty) + + | otherwise -> + -- OK to bind + writeSubst index (Just new_tau_ty) `thenSubstM` \ _ -> + returnSubstM SubstOK + where + index = tyVarToIndex tyvar + is_elem = isIn "extendSubst" +\end{code} + +%******************************************************** +%* * +\subsubsection{@Subst@: lookup} +%* * +%******************************************************** + +All of them use the underlying function, @apply_rep_to_ty@, which +ensures that an idempotent result is returned. + +\begin{code} +applySubstToTy subst ty = apply_rep_to_ty ty subst +applySubstToTauTy subst tau_ty = apply_rep_to_ty tau_ty subst +applySubstToTyVar subst tyvar = apply_rep_to_ty (mkTyVarTy tyvar) subst +applySubstToThetaTy subst theta_ty + = let + do_one (clas, ty) = apply_rep_to_ty ty `thenSubstM` \ new_ty -> + returnSubstM (clas, new_ty) + in + mapSubstM do_one theta_ty subst +\end{code} + +And now down to serious business... +\begin{code} +apply_rep_to_ty :: UniType -> SubstM UniType + +apply_rep_to_ty (UniTyVar tyvar) + = readSubst index `thenSubstM` \ maybe_ty -> + case maybe_ty of + + Nothing -> -- Not found, so return a trivial type + returnSubstM (mkTyVarTy tyvar) + + Just ty -> -- Found, so recursively apply the subst the result to + -- maintain idempotence! + apply_rep_to_ty ty `thenSubstM` \ new_ty -> + + -- The mapping for this tyvar is then updated with the + -- result to reduce the number of subsequent lookups + writeSubst index (Just new_ty) `thenSubstM` \ _ -> + + returnSubstM new_ty + where + index = tyVarToIndex tyvar + +apply_rep_to_ty (UniFun t1 t2) + = apply_rep_to_ty t1 `thenSubstM` \ new_t1 -> + apply_rep_to_ty t2 `thenSubstM` \ new_t2 -> + returnSubstM (UniFun new_t1 new_t2) + +apply_rep_to_ty (UniData con args) + = mapSubstM apply_rep_to_ty args `thenSubstM` \ new_args -> + returnSubstM (UniData con new_args) + +apply_rep_to_ty (UniSyn con args ty) + = mapSubstM apply_rep_to_ty args `thenSubstM` \ new_args -> + apply_rep_to_ty ty `thenSubstM` \ new_ty -> + returnSubstM (UniSyn con new_args new_ty) + +apply_rep_to_ty (UniDict clas ty) + = apply_rep_to_ty ty `thenSubstM` \ new_ty -> + returnSubstM (UniDict clas new_ty) + +apply_rep_to_ty (UniForall v ty) + = apply_rep_to_ty ty `thenSubstM` \ new_ty -> + returnSubstM (UniForall v new_ty) + +apply_rep_to_ty ty@(UniTyVarTemplate v) = returnSubstM ty +\end{code} + +%************************************************************************ +%* * +\subsubsection{Allocating @TyVarUniques@} +%* * +%************************************************************************ + +The array is extended if the allocated type variables would cause an +out of bounds error. + +\begin{code} +getSubstTyVarUnique subst@(MkSubst arr undo world next_free) + | next_free <= size -- The common case; there's a spare slot + = (MkSubst arr undo world new_next_free, uniq) + + | otherwise -- Need more room: Extend first, then re-try + = getSubstTyVarUnique (extendSubstArr subst) + + where + size = case (boundsOfArray arr) of { (_, x) -> x } + uniq = mkUnifiableTyVarUnique next_free + new_next_free = next_free + 1 + + +getSubstTyVarUniques n subst@(MkSubst arr undo world next_free) + | new_next_free - 1 <= size -- The common case; there's a spare slot + = (MkSubst arr undo world new_next_free, uniqs) + + | otherwise -- Need more room: extend, then re-try + = getSubstTyVarUniques n (extendSubstArr subst) + + where + size = case (boundsOfArray arr) of { (_, x) -> x } + uniqs = [mkUnifiableTyVarUnique (next_free + i) | i <- [0..n-1]] + new_next_free = next_free + n +\end{code} + +%************************************************************************ +%* * +\subsubsection{Undoing substitution on typechecking failure} +%* * +%************************************************************************ + +\begin{code} +pushSubstUndos (MkSubst arr undos world next_free) + = MkSubst arr ((next_free,emptyBag):undos) world next_free + +combineSubstUndos (MkSubst arr [_] world next_free) + = MkSubst arr [] world next_free -- top level undo ignored + +combineSubstUndos (MkSubst arr ((_,u1):(checkpoint,u2):undo_stack) + world next_free) + = MkSubst arr ((checkpoint, new_u1 `unionBags` u2):undo_stack) world next_free + where + -- Keep only undos which apply to indices before checkpoint + new_u1 = filterBag (\ (index,val) -> index < checkpoint) u1 + +undoSubstUndos (MkSubst arr ((checkpoint,undo_now):undo_stack) world next_free) + = MkSubst arr undo_stack new_world checkpoint + where + (_, new_world) = doST world (perform_undo (bagToList undo_now) `seqStrictlyST` + clear_block checkpoint + ) + + perform_undo [] = returnStrictlyST () + perform_undo ((index,val):undos) = writeArray arr index val `seqStrictlyST` + perform_undo undos + + -- (clear_block n) clears the array from n up to next_free + -- This is necessary because undos beyond supp2 aren't recorded in undos + clear_block n | n >= next_free = returnStrictlyST () + | otherwise = writeArray arr n Nothing `seqStrictlyST` + clear_block (n+1) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Pruning a substitution} +%* * +%************************************************************************ + +ToDo: Implement with array !! Ignore? Restore unique supply? + +@pruneSubst@ prunes a substitution to a given level. + +This is tricky stuff. The idea is that if we + (a) catch the current unique supply + (b) do some work + (c) back-substitute over the results of the work + (d) prune the substitution back to the level caught in (a) +then everything will be fine. Any *subsequent* unifications to +these just-pruned ones will be added and not subsequently deleted. + +NB: this code relies on the idempotence property, otherwise discarding +substitions might be dangerous. + +\begin{code} +{- +pruneSubst :: TyVarUnique -> Subst -> Subst + +pruneSubst keep_marker (MkSubst subst_rep) + = -- BSCC("pruneSubst") + MkSubst [(tyvar,ty) | (tyvar,ty) <- subst_rep, + getTheUnique tyvar `ltUnique` keep_marker] + -- ESCC +-} +\end{code} + +%************************************************************************ +%* * +\subsection[Subst-Lists]{@Subst@ with poor list implementation} +%* * +%************************************************************************ + +If don't have Glasgow Haskell we have to revert to list implementation +of arrays ... + +\begin{code} +#else {- ! __GLASGOW_HASKELL__ -} +\end{code} + +%************************************************************************ +%* * +\subsubsection{@Subst@: specification and representation} +%* * +%************************************************************************ + +{\em Specification:} +* When new bindings are added to the substitution, an occurs check is performed. +* The applySubst function guarantees to return a fixed point of the substitution. + +{\em Representation:} +A substitution binds type variables to tau-types, that is @UniType@s without +any @UniForall@ or @UniDict@ constructors. + +It is represented as an association list, indexed on Uniques +with a stack of type variable unique markers indicating undo +checkpoints. The supply of TyVarUniques is also part of the +aubstitution. + +The undo information is a stack of tyvar markers. If the typecheck +fails all extensions to the association list subsequent to (and +including) the marker are undone. If it succeeds the current marker is +discarded. + +The unique supply is also stacked so that it can be restored if a +typecheck fails. + +\begin{code} +type SubstRep = [(Unique, TauType)] + +data Subst + = MkSubst SubstRep -- mapping for allocated tyvars + [Maybe Unique] -- stack of markers to strip off if we fail + [UniqueSupply] -- stack of tyvar unique supplies + +mkEmptySubst size = MkSubst [] [] [] +\end{code} + +\begin{code} +lookup_rep :: SubstRep -> TyVar -> Maybe TauType +lookup_rep alist tyvar + = let + key = getTheUnique tyvar + + lookup [] = Nothing + lookup ((u,ty):rest) + = case (cmpUnique key u) of { EQ_ -> Just ty; _ -> lookup rest } + in + lookup alist +\end{code} + +%******************************************************** +%* * +\subsubsection{@Subst@: building them} +%* * +%******************************************************** + +\begin{code} +--OLD? initSubst init = MkSubst [] [] [mkUniqueSupply init] +\end{code} + +\begin{code} +extendSubst subst@(MkSubst srep undo supp) tyvar tau_ty + = -- BSCC("extendSubst") + apply_rep_to_ty srep tau_ty `thenLft` \ new_tau_ty -> + + case expandVisibleTySyn new_tau_ty of + + UniTyVar tv | tv `eqTyVar` tyvar -> + -- Trivial new binding; return old substition + (SubstOK, subst) + + _ -> let + is_elem = isIn "extendSubst2" + in + if (tyvar `is_elem` (extractTyVarsFromTy new_tau_ty)) then + (OccursCheck tyvar new_tau_ty, subst) + else + case lookup_rep srep tyvar of + Just exist_ty -> + (AlreadyBound exist_ty, subst) + Nothing -> + let + new_srep = (getTheUnique tyvar, new_tau_ty) : srep + new_undo = case undo of + [] -> [] + -- top level undo ignored + + (Nothing : undos) -> (Just (getTheUnique tyvar)) : undos + (Just _ : _ ) -> undo + -- only first undo recorded + in + (SubstOK, MkSubst new_srep new_undo supp) + -- ESCC +\end{code} + +%******************************************************** +%* * +\subsubsection{@Subst@: lookup} +%* * +%******************************************************** + +All of them use the underlying function, @apply_rep_to_ty@, which +ensures that an idempotent result is returned. + +\begin{code} +applySubstToTy subst@(MkSubst srep undo supp) ty + = -- BSCC("applySubstToTy") + apply_rep_to_ty srep ty `thenLft` \ new_ty -> + (subst, new_ty) + -- ESCC + +applySubstToTauTy subst@(MkSubst srep undo supp) tauty + = -- BSCC("applySubstToTauTy") + apply_rep_to_ty srep tauty `thenLft`\ new_tauty -> + (subst, new_tauty) + -- ESCC + +applySubstToThetaTy subst@(MkSubst srep undo supp) theta + = -- BSCC("applySubstToThetaTy") + let + do_one (clas, ty) = apply_rep_to_ty srep ty `thenLft` \ new_ty -> + returnLft (clas, new_ty) + in + mapLft do_one theta `thenLft` \ new_theta -> + (subst, new_theta) + -- ESCC + +applySubstToTyVar subst@(MkSubst srep undo supp) tyvar + = -- BSCC("applySubstToTyVar") + apply_rep_to_ty srep (mkTyVarTy tyvar) `thenLft` \ new_tauty -> + (subst, new_tauty) + -- ESCC +\end{code} + +And now down to serious business... +\begin{code} +apply_rep_to_ty :: SubstRep -> UniType -> LiftM UniType + +apply_rep_to_ty srep (UniTyVar tyvar) + = case lookup_rep srep tyvar of + Nothing -> -- Not found, so return a trivial type + returnLft (mkTyVarTy tyvar) + + Just ty -> -- Found, so recursively apply the subst the result to + -- maintain idempotence! + apply_rep_to_ty srep ty + +apply_rep_to_ty srep (UniFun t1 t2) + = apply_rep_to_ty srep t1 `thenLft` \ new_t1 -> + apply_rep_to_ty srep t2 `thenLft` \ new_t2 -> + returnLft (UniFun new_t1 new_t2) + +apply_rep_to_ty srep (UniData con args) + = mapLft (apply_rep_to_ty srep) args `thenLft` \ new_args -> + returnLft (UniData con new_args) + +apply_rep_to_ty srep (UniSyn con args ty) + = mapLft (apply_rep_to_ty srep) args `thenLft` \ new_args -> + apply_rep_to_ty srep ty `thenLft` \ new_ty -> + returnLft (UniSyn con new_args new_ty) + +apply_rep_to_ty srep (UniDict clas ty) + = apply_rep_to_ty srep ty `thenLft` \ new_ty -> + returnLft (UniDict clas new_ty) + +apply_rep_to_ty srep (UniForall v ty) + = apply_rep_to_ty srep ty `thenLft` \ new_ty -> + returnLft (UniForall v new_ty) + +apply_rep_to_ty srep ty@(UniTyVarTemplate v) = returnLft ty +\end{code} + +%************************************************************************ +%* * +\subsubsection{Allocating TyVarUniques} +%* * +%************************************************************************ + +The array is extended if the allocated type variables would cause an +out of bounds error. + +\begin{code} +getSubstTyVarUnique subst@(MkSubst srep undo (supp:supps)) + = -- BSCC("allocTyVarUniques") + case getUnique supp of + (new_supp, uniq) -> (MkSubst srep undo (new_supp:supps), uniq) + -- ESCC + +getSubstTyVarUniques n subst@(MkSubst srep undo (supp:supps)) + = -- BSCC("allocTyVarUniques") + case getUniques n supp of + (new_supp, uniqs) -> (MkSubst srep undo (new_supp:supps), uniqs) + -- ESCC +\end{code} + +%************************************************************************ +%* * +\subsubsection[Subst-undo]{Undoing substitution on typechecking failure} +%* * +%************************************************************************ + +\begin{code} +pushSubstUndos subst@(MkSubst srep undos (supp:supps)) + = -- BSCC("pushSubstUndos") + MkSubst srep (Nothing:undos) (supp:supp:supps) + -- ESCC + +combineSubstUndos subst@(MkSubst srep (u:us) (supp1:supp2:supps)) + = -- BSCC("combineSubstUndos") + MkSubst srep us (supp1:supps) + -- ESCC + +undoSubstUndos subst@(MkSubst srep (u:us) (supp1:supp2:supps)) + = -- BSCC("undoSubstUndos") + let + strip_to [] key = [] + strip_to ((u,ty):srep) key + = case (cmpUnique u key) of { EQ_ -> srep; _ -> strip_to srep key } + + perform_undo Nothing srep = srep + perform_undo (Just uniq) srep = strip_to srep uniq + in + MkSubst (perform_undo u srep) us (supp2:supps) + + -- Note: the saved unique supply is restored from the enclosing scope + + -- ESCC +\end{code} + +%************************************************************************ +%* * +\subsubsection{Pruning a substitution} +%* * +%************************************************************************ + +ToDo: Implement with list !! Ignore? Restore unique supply? + +@pruneSubst@ prunes a substitution to a given level. + +This is tricky stuff. The idea is that if we + (a) catch the current unique supply + (b) do some work + (c) back-substitute over the results of the work + (d) prune the substitution back to the level caught in (a) +then everything will be fine. Any *subsequent* unifications to +these just-pruned ones will be added and not subsequently deleted. + +NB: this code relies on the idempotence property, otherwise discarding +substitions might be dangerous. + +\begin{code} +{- +pruneSubst :: TyVarUnique -> Subst -> Subst + +pruneSubst keep_marker (MkSubst subst_rep) + = -- BSCC("pruneSubst") + MkSubst [(tyvar,ty) | (tyvar,ty) <- subst_rep, + getTheUnique tyvar `ltUnique` keep_marker] + -- ESCC +-} +\end{code} + +\begin{code} +#endif {- ! __GLASGOW_HASKELL__ -} +\end{code} diff --git a/ghc/compiler/typecheck/TcBinds.hi b/ghc/compiler/typecheck/TcBinds.hi new file mode 100644 index 0000000..a17da4f --- /dev/null +++ b/ghc/compiler/typecheck/TcBinds.hi @@ -0,0 +1,21 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcBinds where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsBinds(Binds) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcLocalBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b) + {-# GHC_PRAGMA _A_ 4 _U_ 2212222222 _N_ _S_ "LLSL" _N_ _N_ #-} +tcTopBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b) + {-# GHC_PRAGMA _A_ 4 _U_ 2212222222 _N_ _S_ "LLSL" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs new file mode 100644 index 0000000..1631365 --- /dev/null +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -0,0 +1,541 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcBinds]{TcBinds} + +\begin{code} +#include "HsVersions.h" + +module TcBinds ( + tcTopBindsAndThen, tcLocalBindsAndThen + ) where + +--IMPORT_Trace -- ToDo:rm (debugging) + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( newLocalsWithOpenTyVarTys, + newLocalsWithPolyTyVarTys, + newSpecPragmaId, newSpecId, + applyTcSubstAndCollectTyVars + ) +import AbsSyn -- the stuff being typechecked + +import AbsUniType ( isTyVarTy, isGroundTy, isUnboxedDataType, + isGroundOrTyVarTy, extractTyVarsFromTy, + UniType + ) +import BackSubst ( applyTcSubstToBinds ) +import E +import Errors ( topLevelUnboxedDeclErr, specGroundnessErr, + specCtxtGroundnessErr, Error(..), UnifyErrContext(..) + ) +import GenSpecEtc ( checkSigTyVars, genBinds, SignatureInfo(..) ) +import Id ( getIdUniType, mkInstId ) +import IdInfo ( SpecInfo(..) ) +import Inst +import LIE ( nullLIE, mkLIE, plusLIE, LIE ) +import Maybes ( assocMaybe, catMaybes, Maybe(..) ) +import Spec ( specTy ) +import TVE ( nullTVE, TVE(..), UniqFM ) +import TcMonoBnds ( tcMonoBinds ) +import TcPolyType ( tcPolyType ) +import TcSimplify ( bindInstsOfLocalFuns ) +import Unify ( unifyTauTy ) +import UniqFM ( emptyUFM ) -- profiling, pragmas only +import Util +\end{code} + +%************************************************************************ +%* * +\subsection{Type-checking top-level bindings} +%* * +%************************************************************************ + +@tcBindsAndThen@ takes a boolean which indicates whether the binding +group is at top level or not. The difference from inner bindings is +that +\begin{enumerate} +\item +we zero the substitution before each group +\item +we back-substitute after each group. +\end{enumerate} +We still return an LIE, but it is sure to contain nothing but constant +dictionaries, which we resolve at the module level. + +@tcTopBinds@ returns an LVE, not, as you might expect, a GVE. Why? +Because the monomorphism restriction means that is might return some +monomorphic things, with free type variables. Hence it must be an LVE. + +The LIE returned by @tcTopBinds@ may constrain some type variables, +but they are guaranteed to be a subset of those free in the +corresponding returned LVE. + +%************************************************************************ +%* * +\subsection{Type-checking bindings} +%* * +%************************************************************************ + +@tcBindsAndThen@ typechecks a @Binds@. The "and then" part is because +it needs to know something about the {\em usage} of the things bound, +so that it can create specialisations of them. So @tcBindsAndThen@ +takes a function which, given an extended environment, E, typechecks +the scope of the bindings returning a typechecked thing and (most +important) an LIE. It is this LIE which is then used as the basis for +specialising the things bound. + +@tcBindsAndThen@ also takes a "combiner" which glues together the +bindings and the "thing" to make a new "thing". + +The real work is done by @tcBindAndThen@. + +Recursive and non-recursive binds are handled in essentially the same +way: because of uniques there are no scoping issues left. The only +difference is that non-recursive bindings can bind primitive values. + +Even for non-recursive binding groups we add typings for each binder +to the LVE for the following reason. When each individual binding is +checked the type of its LHS is unified with that of its RHS; and +type-checking the LHS of course requires that the binder is in scope. + +\begin{code} +tcBindsAndThen + :: Bool + -> E + -> (TypecheckedBinds -> thing -> thing) -- Combinator + -> RenamedBinds + -> (E -> TcM (thing, LIE, thing_ty)) + -> TcM (thing, LIE, thing_ty) + +tcBindsAndThen top_level e combiner EmptyBinds do_next + = do_next e `thenTc` \ (thing, lie, thing_ty) -> + returnTc (combiner EmptyBinds thing, lie, thing_ty) + +tcBindsAndThen top_level e combiner (SingleBind bind) do_next + = tcBindAndThen top_level e combiner bind [] do_next + +tcBindsAndThen top_level e combiner (BindWith bind sigs) do_next + = tcBindAndThen top_level e combiner bind sigs do_next + +tcBindsAndThen top_level e combiner (ThenBinds binds1 binds2) do_next + = tcBindsAndThen top_level e combiner binds1 new_after + where + -- new_after :: E -> TcM (thing, LIE, thing_ty) + -- Can't write this signature, cos it's monomorphic in thing and + -- thing_ty. + new_after e = tcBindsAndThen top_level e combiner binds2 do_next +\end{code} + +Simple wrappers for export: +\begin{code} +tcTopBindsAndThen + :: E + -> (TypecheckedBinds -> thing -> thing) -- Combinator + -> RenamedBinds + -> (E -> TcM (thing, LIE, anything)) + -> TcM (thing, LIE, anything) + +tcTopBindsAndThen e combiner binds do_next + = tcBindsAndThen True e combiner binds do_next + +tcLocalBindsAndThen + :: E + -> (TypecheckedBinds -> thing -> thing) -- Combinator + -> RenamedBinds + -> (E -> TcM (thing, LIE, thing_ty)) + -> TcM (thing, LIE, thing_ty) + +tcLocalBindsAndThen e combiner binds do_next + = tcBindsAndThen False e combiner binds do_next +\end{code} + +An aside. The original version of @tcBindsAndThen@ which lacks a +combiner function, appears below. Though it is perfectly well +behaved, it cannot be typed by Haskell, because the recursive call is +at a different type to the definition itself. There aren't too many +examples of this, which is why I thought it worth preserving! [SLPJ] + +\begin{pseudocode} +tcBindsAndThen + :: Bool -> E -> RenamedBinds + -> (E -> TcM (thing, LIE, thing_ty)) + -> TcM ((TypecheckedBinds, thing), LIE, thing_ty) + +tcBindsAndThen top_level e EmptyBinds do_next + = do_next e `thenTc` \ (thing, lie, thing_ty) -> + returnTc ((EmptyBinds, thing), lie, thing_ty) + +tcBindsAndThen top_level e (SingleBind bind) do_next + = tcBindAndThen top_level e bind [] do_next + +tcBindsAndThen top_level e (BindWith bind sigs) do_next + = tcBindAndThen top_level e bind sigs do_next + +tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next + = tcBindsAndThen top_level e binds1 new_after + `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) -> + + returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty) + + where + -- new_after :: E -> TcM ((TypecheckedBinds, thing), LIE, thing_ty) + -- Can't write this signature, cos it's monomorphic in thing and thing_ty + new_after e = tcBindsAndThen top_level e binds2 do_next +\end{pseudocode} + +%************************************************************************ +%* * +\subsection{Bind} +%* * +%************************************************************************ + +\begin{code} +tcBindAndThen + :: Bool -- At top level + -> E + -> (TypecheckedBinds -> thing -> thing) -- Combinator + -> RenamedBind -- The Bind to typecheck + -> [RenamedSig] -- ...and its signatures + -> (E -> TcM (thing, LIE, thing_ty)) -- Thing to type check in + -- augmented envt + -> TcM (thing, LIE, thing_ty) -- Results, incl the + +tcBindAndThen top_level e combiner bind sigs do_next + = -- Deal with the bind + tcBind top_level e bind sigs `thenTc` \ (poly_binds, poly_lie, poly_lve) -> + + -- Now do whatever happens next, in the augmented envt + do_next (growE_LVE e poly_lve) `thenTc` \ (thing, thing_lie, thing_ty) -> + let + bound_ids = map snd poly_lve + in + -- Create specialisations + specialiseBinds bound_ids thing_lie poly_binds poly_lie + `thenNF_Tc` \ (final_binds, final_lie) -> + -- All done + returnTc (combiner final_binds thing, final_lie, thing_ty) +\end{code} + +\begin{code} +tcBind :: Bool -> E + -> RenamedBind -> [RenamedSig] + -> TcM (TypecheckedBinds, LIE, LVE) -- LIE is a fixed point of substitution + +tcBind False e bind sigs -- Not top level + = tcBind_help False e bind sigs + +tcBind True e bind sigs -- Top level! + = pruneSubstTc (tvOfE e) ( + + -- DO THE WORK + tcBind_help True e bind sigs `thenTc` \ (new_binds, lie, lve) -> + +{- Top-level unboxed values are now allowed + They will be lifted by the Desugarer (see CoreLift.lhs) + + -- CHECK FOR PRIMITIVE TOP-LEVEL BINDS + listTc [ checkTc (isUnboxedDataType (getIdUniType id)) + (topLevelUnboxedDeclErr id (getSrcLoc id)) + | (_,id) <- lve ] `thenTc_` +-} + + -- Back-substitute over the binds, since we are about to discard + -- a good chunk of the substitution. + applyTcSubstToBinds new_binds `thenNF_Tc` \ final_binds -> + + -- The lie is already a fixed point of the substitution; it just turns out + -- that almost always this happens automatically, and so we made it part of + -- the specification of genBinds. + returnTc (final_binds, lie, lve) + ) +\end{code} + +\begin{code} +tcBind_help top_level e bind sigs + = -- Create an LVE binding each identifier to an appropriate type variable + new_locals binders `thenNF_Tc` \ bound_ids -> + let lve = binders `zip` bound_ids in + + -- Now deal with type signatures, if any + tcSigs e lve sigs `thenTc` \ sig_info -> + + -- Check the bindings: this is the point at which we can use + -- error recovery. If checking the bind fails we just + -- return the empty bindings. The variables will still be in + -- scope, but bound to completely free type variables, which + -- is just what we want to minimise subsequent error messages. + recoverTc (NonRecBind EmptyMonoBinds, nullLIE) + (tc_bind (growE_LVE e lve) bind) `thenNF_Tc` \ (bind', lie) -> + + -- Notice that genBinds gets the old (non-extended) environment + genBinds top_level e bind' lie lve sig_info `thenTc` \ (binds', lie, lve) -> + + -- Add bindings corresponding to SPECIALIZE pragmas in the code + mapAndUnzipTc (doSpecPragma e lve) (get_spec_pragmas sig_info) + `thenTc` \ (spec_binds_s, spec_lie_s) -> + + returnTc (binds' `ThenBinds` (SingleBind (NonRecBind ( + foldr AndMonoBinds EmptyMonoBinds spec_binds_s))), + lie `plusLIE` (foldr plusLIE nullLIE spec_lie_s), + lve) + where + binders = collectBinders bind + + new_locals binders + = case bind of + NonRecBind _ -> -- Recursive, so no unboxed types + newLocalsWithOpenTyVarTys binders + + RecBind _ -> -- Non-recursive, so we permit unboxed types + newLocalsWithPolyTyVarTys binders + + get_spec_pragmas sig_info + = catMaybes (map get_pragma_maybe sig_info) + where + get_pragma_maybe s@(ValSpecInfo _ _ _ _) = Just s + get_pragma_maybe _ = Nothing +\end{code} + +\begin{verbatim} + f :: Ord a => [a] -> b -> b + {-# SPECIALIZE f :: [Int] -> b -> b #-} +\end{verbatim} +We generate: +\begin{verbatim} + f@Int = /\ b -> let d1 = ... + in f Int b d1 + + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + + spec_h = /\b -> h [Int] b dListOfInt + ^^^^^^^^^^^^^^^^^^^^ This bit created by specId +\end{verbatim} + +\begin{code} +doSpecPragma :: E -> LVE + -> SignatureInfo + -> TcM (TypecheckedMonoBinds, LIE) + +doSpecPragma e lve (ValSpecInfo name spec_ty using src_loc) + = let + main_id = assoc "doSpecPragma" lve name + -- Get the parent Id; it should exist (renamer promises...). + + main_id_ty = getIdUniType main_id + main_id_free_tyvars = extractTyVarsFromTy main_id_ty + origin = ValSpecOrigin name src_loc + err_ctxt = ValSpecSigCtxt name spec_ty src_loc + in + addSrcLocTc src_loc ( + specTy origin spec_ty `thenNF_Tc` \ (spec_tyvars, spec_dicts, spec_tau) -> + + -- Check that the SPECIALIZE pragma had an empty context + checkTc (not (null spec_dicts)) + (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_` + + -- Make an instance of this id + specTy origin main_id_ty `thenNF_Tc` \ (main_tyvars, main_dicts, main_tau) -> + + -- Check that the specialised type is indeed an instance of + -- the inferred type. + -- The unification should leave all type vars which are + -- currently free in the environment still free, and likewise + -- the signature type vars. + -- The only way type vars free in the envt could possibly be affected + -- is if main_id_ty has free type variables. So we just extract them, + -- and check that they are not constrained in any way by the unification. + applyTcSubstAndCollectTyVars main_id_free_tyvars `thenNF_Tc` \ free_tyvars' -> + unifyTauTy spec_tau main_tau err_ctxt `thenTc_` + checkSigTyVars [] (spec_tyvars ++ free_tyvars') + spec_tau main_tau err_ctxt `thenTc_` + + -- Check that the type variables of the polymorphic function are + -- either left polymorphic, or instantiate to ground type. + -- Also check that the overloaded type variables are instantiated to + -- ground type; or equivalently that all dictionaries have ground type + applyTcSubstToTyVars main_tyvars `thenNF_Tc` \ main_arg_tys -> + applyTcSubstToInsts main_dicts `thenNF_Tc` \ main_dicts' -> + + checkTc (not (all isGroundOrTyVarTy main_arg_tys)) + (specGroundnessErr err_ctxt main_arg_tys) + `thenTc_` + + checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType main_dicts'])) + (specCtxtGroundnessErr err_ctxt main_dicts') + `thenTc_` + + -- Build a suitable binding; depending on whether we were given + -- a value (Maybe Name) to be used as the specialisation. + case using of + Nothing -> + + -- Make a specPragmaId to which to bind the new call-instance + newSpecPragmaId name spec_ty Nothing + `thenNF_Tc` \ pseudo_spec_id -> + let + pseudo_bind = VarMonoBind pseudo_spec_id pseudo_rhs + pseudo_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var main_id) main_arg_tys) + (map mkInstId main_dicts')) + in + returnTc (pseudo_bind, mkLIE main_dicts') + + Just spec_name -> -- use spec_name as the specialisation value ... + let + spec_id = lookupE_Value e spec_name + spec_id_ty = getIdUniType spec_id + + spec_id_free_tyvars = extractTyVarsFromTy spec_id_ty + spec_id_ctxt = ValSpecSpecIdCtxt name spec_ty spec_name src_loc + + spec_tys = map maybe_ty main_arg_tys + maybe_ty ty | isTyVarTy ty = Nothing + | otherwise = Just ty + in + -- Make an instance of the spec_id + specTy origin spec_id_ty `thenNF_Tc` \ (spec_id_tyvars, spec_id_dicts, spec_id_tau) -> + + -- Check that the specialised type is indeed an instance of + -- the type inferred for spec_id + -- The unification should leave all type vars which are + -- currently free in the environment still free, and likewise + -- the signature type vars. + -- The only way type vars free in the envt could possibly be affected + -- is if spec_id_ty has free type variables. So we just extract them, + -- and check that they are not constrained in any way by the unification. + applyTcSubstAndCollectTyVars spec_id_free_tyvars `thenNF_Tc` \ spec_id_free_tyvars' -> + unifyTauTy spec_tau spec_id_tau spec_id_ctxt `thenTc_` + checkSigTyVars [] (spec_tyvars ++ spec_id_free_tyvars') + spec_tau spec_id_tau spec_id_ctxt `thenTc_` + + -- Check that the type variables of the explicit spec_id are + -- either left polymorphic, or instantiate to ground type. + -- Also check that the overloaded type variables are instantiated to + -- ground type; or equivalently that all dictionaries have ground type + applyTcSubstToTyVars spec_id_tyvars `thenNF_Tc` \ spec_id_arg_tys -> + applyTcSubstToInsts spec_id_dicts `thenNF_Tc` \ spec_id_dicts' -> + + checkTc (not (all isGroundOrTyVarTy spec_id_arg_tys)) + (specGroundnessErr spec_id_ctxt spec_id_arg_tys) + `thenTc_` + + checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType spec_id_dicts'])) + (specCtxtGroundnessErr spec_id_ctxt spec_id_dicts') + `thenTc_` + + -- Make a local SpecId to bind to applied spec_id + newSpecId main_id spec_tys spec_ty `thenNF_Tc` \ local_spec_id -> + + -- Make a specPragmaId id with a spec_info for local_spec_id + -- This is bound to local_spec_id + -- The SpecInfo will be extracted by the specialiser and + -- used to create a call instance for main_id (which is + -- extracted from the spec_id) + -- NB: the pseudo_local_id must stay in the scope of main_id !!! + let + spec_info = SpecInfo spec_tys (length main_dicts') local_spec_id + in + newSpecPragmaId name spec_ty (Just spec_info) `thenNF_Tc` \ pseudo_spec_id -> + let + spec_bind = VarMonoBind local_spec_id spec_rhs + spec_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var spec_id) spec_id_arg_tys) + (map mkInstId spec_id_dicts')) + pseudo_bind = VarMonoBind pseudo_spec_id (Var local_spec_id) + in + returnTc (spec_bind `AndMonoBinds` pseudo_bind, mkLIE spec_id_dicts') + ) +\end{code} + +\begin{code} +tc_bind :: E + -> RenamedBind + -> TcM (TypecheckedBind, LIE) + +tc_bind e (NonRecBind mono_binds) + = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) -> + returnTc (NonRecBind mono_binds2, lie) + +tc_bind e (RecBind mono_binds) + = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) -> + returnTc (RecBind mono_binds2, lie) +\end{code} + +\begin{code} +specialiseBinds + :: [Id] -- Ids bound in this group + -> LIE -- LIE of scope of these bindings + -> TypecheckedBinds + -> LIE + -> NF_TcM (TypecheckedBinds, LIE) + +specialiseBinds bound_ids lie_of_scope poly_binds poly_lie + = bindInstsOfLocalFuns lie_of_scope bound_ids + `thenNF_Tc` \ (lie2, inst_mbinds) -> + + returnNF_Tc (poly_binds `ThenBinds` (SingleBind (NonRecBind inst_mbinds)), + lie2 `plusLIE` poly_lie) +\end{code} + +%************************************************************************ +%* * +\subsection{Signatures} +%* * +%************************************************************************ + +@tcSigs@ checks the signatures for validity, and returns a list of +{\em freshly-instantiated} signatures. That is, the types are already +split up, and have fresh type variables (not @TyVarTemplate@s) +installed. + +\begin{code} +tcSigs :: E -> LVE + -> [RenamedSig] + -> TcM [SignatureInfo] + +tcSigs e lve [] = returnTc [] + +tcSigs e lve (s:ss) + = tc_sig s `thenTc` \ sig_info1 -> + tcSigs e lve ss `thenTc` \ sig_info2 -> + returnTc (sig_info1 : sig_info2) + where + tc_sig (Sig v ty _ src_loc) -- no interesting pragmas on non-iface sigs + = addSrcLocTc src_loc ( + + babyTcMtoTcM + (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty -> + + let val = assoc "tcSigs" lve v in + -- (The renamer/dependency-analyser should have ensured + -- that there are only signatures for which there is a + -- corresponding binding.) + + -- Instantiate the type, and unify with the type variable + -- found in the Id. + specTy SignatureOrigin sigma_ty `thenNF_Tc` \ (tyvars, dicts, tau_ty) -> + unifyTauTy (getIdUniType val) tau_ty + (panic "ToDo: unifyTauTy(tcSigs)") `thenTc_` + + returnTc (TySigInfo val tyvars dicts tau_ty src_loc) + ) + + tc_sig (SpecSig v ty using src_loc) + = addSrcLocTc src_loc ( + + babyTcMtoTcM + (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty -> + + returnTc (ValSpecInfo v sigma_ty using src_loc) + ) + + tc_sig (InlineSig v guide locn) + = returnTc (ValInlineInfo v guide locn) + + tc_sig (DeforestSig v locn) + = returnTc (ValDeforestInfo v locn) + + tc_sig (MagicUnfoldingSig v str locn) + = returnTc (ValMagicUnfoldingInfo v str locn) +\end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.hi b/ghc/compiler/typecheck/TcClassDcl.hi new file mode 100644 index 0000000..dcf17a5 --- /dev/null +++ b/ghc/compiler/typecheck/TcClassDcl.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcClassDcl where +import Bag(Bag) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsBinds(Binds, MonoBinds) +import HsDecls(ClassDecl) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import IdInfo(SpecEnv) +import InstEnv(InstTemplate) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +import UniqFM(UniqFM) +data ClassInfo {-# GHC_PRAGMA ClassInfo Class (MonoBinds Name (InPat Name)) #-} +tcClassDecls1 :: E -> (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) -> [ClassDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([ClassInfo], UniqFM Class, [(Name, Id)]) + {-# GHC_PRAGMA _A_ 9 _U_ 221222122 _N_ _S_ "LLSLLLLLL" _N_ _N_ #-} +tcClassDecls2 :: E -> [ClassInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs new file mode 100644 index 0000000..b960d18 --- /dev/null +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -0,0 +1,510 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcClassDcl]{Typechecking class declarations} + +\begin{code} +#include "HsVersions.h" + +module TcClassDcl ( + tcClassDecls1, tcClassDecls2, + ClassInfo -- abstract + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty -- add proper one below + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( newDicts, newClassOpLocals, copyTyVars ) +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( pAT_ERROR_ID ) +import AbsUniType ( mkClass, getClassKey, getClassBigSig, + getClassOpString, getClassOps, splitType, + mkSuperDictSelType, InstTyEnv(..), + instantiateTy, instantiateThetaTy, UniType + ) +import BackSubst ( applyTcSubstToBinds ) +import CE -- ( nullCE, unitCE, plusCE, CE(..), UniqFM ) +import E ( mkE, getE_TCE, getE_CE, tvOfE, nullGVE, plusGVE, E, TCE(..), UniqFM, GVE(..) ) +import Errors ( confusedNameErr, Error(..) ) +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Id ( mkSuperDictSelId, mkInstId, getIdUniType, + Id, DictFun(..) + ) +import IdInfo +import Inst ( InstOrigin(..), Inst ) +import InstEnv +import LIE ( nullLIE, mkLIE, plusLIE, LIE ) +import Maybes ( Maybe(..) ) +import Name ( Name(..) ) +import PlainCore ( escErrorMsg ) +import Spec ( specTy ) +import TVE ( mkTVE, TVE(..) + IF_ATTACK_PRAGMAS(COMMA u2i) + ) +import TcClassSig ( tcClassSigs ) +import TcContext ( tcContext ) +import TcInstDcls ( processInstBinds ) +import TcPragmas ( tcGenPragmas ) +import Util +\end{code} + +@ClassInfo@ communicates the essential information about +locally-defined classes between passes 1 and 2. + +\begin{code} +data ClassInfo + = ClassInfo Class + RenamedMonoBinds +\end{code} + + +%************************************************************************ +%* * +\subsection[TcClassDcl]{Does the real work (apart from default methods)} +%* * +%************************************************************************ + +\begin{code} +tcClassDecls1 + :: E -- Consult the CE/TCE args only to build knots + -> InstanceMapper -- Maps class name to its instances, + -- ...and its ops to their instances, + -> [RenamedClassDecl] + -> TcM ([ClassInfo], -- boiled-down info related to classes + CE, -- env so we can look up classes elsewhere + GVE) -- env so we can look up class ops elsewhere + +tcClassDecls1 e rec_inst_mapper [] + = returnTc ([], nullCE, nullGVE) + +tcClassDecls1 e rec_inst_mapper (cd:cds) + = tc_clas1 cd `thenTc` \ (cinfo1_maybe, ce1, gve1) -> + tcClassDecls1 e rec_inst_mapper cds `thenTc` \ (cinfo2, ce2, gve2) -> + let + glued_cinfos + = case cinfo1_maybe of + Nothing -> cinfo2 + Just xx -> xx : cinfo2 + in + returnTc (glued_cinfos, ce1 `plusCE` ce2, gve1 `plusGVE` gve2) + where + rec_ce = getE_CE e + rec_tce = getE_TCE e +--FAKE: fake_E = mkE rec_tce rec_ce + + tc_clas1 (ClassDecl context class_name + tyvar_name class_sigs def_methods pragmas src_loc) + + = addSrcLocTc src_loc ( + + -- The knot is needed so that the signatures etc can point + -- back to the class itself + fixTc (\ ~(rec_clas, _) -> + let + (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas + in + -- Get new (template) type variables for the class + let (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name] in + + -- Typecheck the class context; since there is only one type + -- variable in scope, we are assured that the it will be of + -- the form (C1 a, C2 a...) + babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta -> + + -- Make the superclass selector ids; the "class" pragmas + -- may have info about the superclass dict selectors; + -- so it is only tcClassPragmas that gives back the + -- final Ids. + getUniquesTc (length theta) `thenNF_Tc` \ uniqs -> + let + super_classes = [ supers | (supers, _) <- theta ] + super_tys + = [ mkSuperDictSelType rec_clas super | super <- super_classes ] + super_info = zip3 super_classes uniqs super_tys + in + (case pragmas of + NoClassPragmas -> + returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ] + + SuperDictPragmas prags -> +-- pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) ( + mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags) +-- ) +-- where +-- pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty] + + ) `thenNF_Tc` \ super_class_sel_ids -> + + -- Typecheck the class signatures, checking that each mentions + -- the class type variable somewhere, and manufacturing + -- suitable Ids for selectors and default methods. + babyTcMtoTcM + (tcClassSigs e tve rec_clas rec_class_op_inst_fn + clas_tyvar class_sigs) + `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) -> + + -- Make the class object itself, producing clas::Class + let + clas + = mkClass class_name clas_tyvar + super_classes super_class_sel_ids + ops op_sel_ids defm_ids + rec_clas_inst_env + in + returnTc (clas, ops_gve) + ) `thenTc` \ (clas, ops_gve) -> + + -- Return the class decl for further work if it is + -- local, otherwise just return the CE + returnTc (if (isLocallyDefined class_name) then + Just (ClassInfo clas def_methods) + else + Nothing, + unitCE (getClassKey clas) clas, + ops_gve + )) + where + ----------- + mk_super_id clas (super_clas, uniq, ty) id_info + = mkSuperDictSelId uniq clas super_clas ty id_info + + ----------- + mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags) + = fixNF_Tc ( \ rec_super_id -> + babyTcMtoNF_TcM + (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags) + `thenNF_Tc` \ id_info -> + + returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info) + ) + +{- SOMETHING LIKE THIS NEEDED? ToDo [WDP] + tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc) + = failTc (confusedNameErr + "Bad name for a class (a type constructor, or Prelude name?)" + bad_name src_loc) +-} +\end{code} + + +%************************************************************************ +%* * +\subsection[ClassDcl-pass2]{Class decls pass 2: default methods} +%* * +%************************************************************************ + +The purpose of pass 2 is +\begin{enumerate} +\item +to beat on the explicitly-provided default-method decls (if any), +using them to produce a complete set of default-method decls. +(Omitted ones elicit an error message.) +\item +to produce a definition for the selector function for each method +\end{enumerate} + +Pass~2 only applies to locally-defined class declarations. + +The function @tcClassDecls2@ just arranges to apply +@tcClassDecls2_help@ to each local class decl. + +\begin{code} +tcClassDecls2 e class_info + = let + -- Get type variables free in environment. Sadly, there may be + -- some, because of the dreaded monomorphism restriction + free_tyvars = tvOfE e + in + tcClassDecls2_help e free_tyvars class_info + +tcClassDecls2_help + :: E + -> [TyVar] + -> [ClassInfo] + -> NF_TcM (LIE, TypecheckedBinds) + +tcClassDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds) + +tcClassDecls2_help e free_tyvars ((ClassInfo clas default_binds) : rest) + = tcClassDecl2 e free_tyvars clas default_binds `thenNF_Tc` \ (lie1, binds1) -> + tcClassDecls2_help e free_tyvars rest `thenNF_Tc` \ (lie2, binds2) -> + returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2) +\end{code} + +@tcClassDecl2@ is the business end of things. + +\begin{code} +tcClassDecl2 :: E + -> [TyVar] -- Free in the envt + -> Class + -> RenamedMonoBinds -- The default decls + -> NF_TcM (LIE, TypecheckedBinds) + +tcClassDecl2 e free_tyvars clas default_binds + = let + src_loc = getSrcLoc clas + origin = ClassDeclOrigin src_loc + (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids) + = getClassBigSig clas + in + -- Prune the substitution when we are finished, and arrange error recovery + recoverTc (nullLIE, EmptyBinds) ( + addSrcLocTc src_loc ( + pruneSubstTc free_tyvars ( + + -- Generate bindings for the selector functions + buildSelectors origin clas clas_tyvar_tmpl scs sc_sel_ids ops op_sel_ids + `thenNF_Tc` \ sel_binds -> + -- Ditto for the methods + buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl + defm_ids default_binds `thenTc` \ (const_insts, meth_binds) -> + + -- Back-substitute through the definitions + applyTcSubstToInsts const_insts `thenNF_Tc` \ final_const_insts -> + applyTcSubstToBinds (sel_binds `ThenBinds` meth_binds) `thenNF_Tc` \ final_binds -> + returnTc (mkLIE final_const_insts, final_binds) + ))) +\end{code} + +%************************************************************************ +%* * +\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses} +%* * +%************************************************************************ + +\begin{code} +buildSelectors :: InstOrigin + -> Class -- The class object + -> TyVarTemplate -- Class type variable + -> [Class] -> [Id] -- Superclasses and selectors + -> [ClassOp] -> [Id] -- Class ops and selectors + -> NF_TcM TypecheckedBinds + +buildSelectors origin clas clas_tyvar_tmpl + scs sc_sel_ids + ops op_sel_ids + = + -- Instantiate the class variable + copyTyVars [clas_tyvar_tmpl] `thenNF_Tc` \ (inst_env, [clas_tyvar], [clas_tyvar_ty]) -> + -- Make an Inst for each class op, and + -- dicts for the superclasses. These are used to + -- construct the selector functions + newClassOpLocals inst_env ops `thenNF_Tc` \ method_ids -> + newDicts origin [ (super_clas, clas_tyvar_ty) + | super_clas <- scs + ] `thenNF_Tc` \ dicts -> + let dict_ids = map mkInstId dicts in + + -- Make suitable bindings for the selectors + let mk_op_sel op sel_id method_id + = mkSelExpr origin clas_tyvar dict_ids method_ids method_id `thenNF_Tc` \ rhs -> + returnNF_Tc (VarMonoBind sel_id rhs) + mk_sc_sel sc sel_id dict_id + = mkSelExpr origin clas_tyvar dict_ids method_ids dict_id `thenNF_Tc` \ rhs -> + returnNF_Tc (VarMonoBind sel_id rhs) + in + listNF_Tc (zipWith3 mk_op_sel ops op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> + listNF_Tc (zipWith3 mk_sc_sel scs sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> + + returnNF_Tc (SingleBind ( + NonRecBind ( + foldr AndMonoBinds EmptyMonoBinds ( + op_sel_binds ++ sc_sel_binds)))) +\end{code} + +%************************************************************************ +%* * +\subsection[ClassDcl-misc]{Miscellaneous} +%* * +%************************************************************************ + +Make a selector expression for @local@ from a dictionary consisting of +@dicts@ and @op_locals@. + +We have to do a bit of jiggery pokery to get the type variables right. +Suppose we have the class decl: +\begin{verbatim} + class Foo a where + op1 :: Ord b => a -> b -> a + op2 :: ... +\end{verbatim} +Then the method selector for \tr{op1} is like this: +\begin{verbatim} + op1_sel = /\ab -> \dFoo -> case dFoo of + (op1_method,op2_method) -> op1_method b +\end{verbatim} +Note that the type variable for \tr{b} is lifted to the top big lambda, and +\tr{op1_method} is applied to it. This is preferable to the alternative: +\begin{verbatim} + op1_sel' = /\a -> \dFoo -> case dFoo of + (op1_method,op2_method) -> op1_method +\end{verbatim} +because \tr{op1_sel'} then has the rather strange type +\begin{verbatim} + op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a +\end{verbatim} +whereas \tr{op1_sel} (the one we use) has the decent type +\begin{verbatim} + op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a +\end{verbatim} + +{\em NOTE:} +We could do the same thing for the dictionaries, giving +\begin{verbatim} + op1_sel = /\ab -> \dFoo -> \dOrd -> case dFoo of + (m1,m2) -> m1 b dOrd +\end{verbatim} +but WE ASSUME THAT DICTIONARY APPLICATION IS CURRIED, so the two are +precisely equivalent, and have the same type, namely +\begin{verbatim} + op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a +\end{verbatim} + +WDP 95/03: Quite false (``DICTIONARY APPLICATION IS CURRIED''). +Specialisation now wants to see all type- and dictionary-applications +absolutely explicitly. + +\begin{code} +mkSelExpr :: InstOrigin -> TyVar -> [Id] -> [Id] -> Id -> NF_TcM TypecheckedExpr + +mkSelExpr origin clas_tyvar dicts op_locals local + = let + (op_tyvar_tmpls,local_theta,_) = splitType (getIdUniType local) + in + copyTyVars op_tyvar_tmpls `thenNF_Tc` \ (inst_env, op_tyvars, tys) -> + let + inst_theta = instantiateThetaTy inst_env local_theta + in + newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts -> + let + local_dicts = map mkInstId local_dict_insts + in + returnNF_Tc (TyLam (clas_tyvar:op_tyvars) + (ClassDictLam + dicts + op_locals + (mkDictLam local_dicts + (mkDictApp (mkTyApp (Var local) tys) local_dicts)))) +\end{code} + + +%************************************************************************ +%* * +\subsection[Default methods]{Default methods} +%* * +%************************************************************************ + +The default methods for a class are each passed a dictionary for the +class, so that they get access to the other methods at the same type. +So, given the class decl +\begin{verbatim} +class Foo a where + op1 :: a -> Bool + op2 :: Ord b => a -> b -> b -> b + + op1 x = True + op2 x y z = if (op1 x) && (y < z) then y else z +\end{verbatim} +we get the default methods: +\begin{verbatim} +defm.Foo.op1 :: forall a. Foo a => a -> Bool +defm.Foo.op1 = /\a -> \dfoo -> \x -> True + +defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b +defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z -> + if (op1 a dfoo x) && (< b dord y z) then y else z +\end{verbatim} +Notice that, like all ids, the foralls of defm.Foo.op2 are at the top. + +When we come across an instance decl, we may need to use the default +methods: +\begin{verbatim} +instance Foo Int where {} +\end{verbatim} +gives +\begin{verbatim} +const.Foo.Int.op1 :: Int -> Bool +const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int + +const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b +const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int + +dfun.Foo.Int :: Foo Int +dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2) +\end{verbatim} +Notice that, as with method selectors above, we assume that dictionary +application is curried, so there's no need to mention the Ord dictionary +in const.Foo.Int.op2 +\begin{verbatim} +instance Foo a => Foo [a] where {} + +dfun.Foo.List :: forall a. Foo a -> Foo [a] +dfun.Foo.List + = /\ a -> \ dfoo_a -> + let rec + op1 = defm.Foo.op1 [a] dfoo_list + op2 = /\b -> defm.Foo.op2 [a] b dfoo_list + dfoo_list = (op1, op2) + in + dfoo_list +\end{verbatim} + +\begin{code} +buildDefaultMethodBinds + :: E + -> [TyVar] + -> InstOrigin + -> Class + -> TyVarTemplate + -> [Id] + -> RenamedMonoBinds + -> TcM ([Inst], TypecheckedBinds) + +buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl + default_method_ids default_binds + = -- Deal with the method declarations themselves + processInstBinds e + free_tyvars + (makeClassDeclDefaultMethodRhs clas origin default_method_ids) + [] -- No tyvars in scope for "this inst decl" + [] -- No insts available + default_method_ids + default_binds `thenTc` \ (dicts_needed, default_binds') -> + + returnTc (dicts_needed, SingleBind (NonRecBind default_binds')) +\end{code} + +@makeClassDeclDefaultMethodRhs@ builds the default method for a +class declaration when no explicit default method is given. + +\begin{code} +makeClassDeclDefaultMethodRhs + :: Class + -> InstOrigin + -> [Id] + -> Int + -> NF_TcM TypecheckedExpr + +makeClassDeclDefaultMethodRhs clas origin method_ids tag + = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) -> + + returnNF_Tc (mkTyLam tyvars ( + mkDictLam (map mkInstId dicts) ( + App (mkTyApp (Var pAT_ERROR_ID) [tau]) + (Lit (StringLit (_PK_ error_msg)))))) + where + method_id = method_ids !! (tag-1) + class_op = (getClassOps clas) !! (tag-1) + + error_msg = "%D" -- => No default method for \" + ++ unencoded_part_of_msg + + unencoded_part_of_msg = escErrorMsg ( + _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." + ++ (ppShow 80 (ppr PprForUser class_op)) + ++ "\"" ) + + (clas_mod, clas_name) = getOrigName clas +\end{code} diff --git a/ghc/compiler/typecheck/TcClassSig.hi b/ghc/compiler/typecheck/TcClassSig.hi new file mode 100644 index 0000000..0452110 --- /dev/null +++ b/ghc/compiler/typecheck/TcClassSig.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcClassSig where +import Bag(Bag) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsBinds(Sig) +import Id(Id) +import IdInfo(SpecEnv) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +tcClassSigs :: E -> UniqFM UniType -> Class -> (ClassOp -> SpecEnv) -> TyVarTemplate -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ClassOp], [(Name, Id)], [Id], [Id]) + {-# GHC_PRAGMA _A_ 6 _U_ 2222212122 _N_ _S_ "LLLLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcClassSig.lhs b/ghc/compiler/typecheck/TcClassSig.lhs new file mode 100644 index 0000000..cec1789 --- /dev/null +++ b/ghc/compiler/typecheck/TcClassSig.lhs @@ -0,0 +1,105 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcClassSig]{Typecheck a class signature} + +\begin{code} +#include "HsVersions.h" + +module TcClassSig ( tcClassSigs ) where + +import TcMonad -- typechecking monadic machinery +import AbsSyn -- the stuff being typechecked + +import AbsUniType +import CE ( CE(..) ) +import E ( mkE, getE_TCE, getE_CE, nullGVE, unitGVE, plusGVE, GVE(..), E ) +import Errors ( methodTypeLacksTyVarErr, confusedNameErr ) +import Id ( mkDefaultMethodId, mkClassOpId, IdInfo ) +import IdInfo +import InstEnv ( InstTemplate ) +import TCE ( TCE(..), UniqFM ) +import TVE ( TVE(..) ) +import TcPolyType ( tcPolyType ) +import TcPragmas ( tcClassOpPragmas ) +import Util +\end{code} + +\begin{code} +tcClassSigs :: E -> TVE -> Class -- Knot tying only! + -> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops + -> TyVarTemplate -- The class type variable, used for error check only + -> [RenamedClassOpSig] + -> Baby_TcM ([ClassOp], -- class ops + GVE, -- env for looking up the class ops + [Id], -- selector ids + [Id]) -- default-method ids + +tcClassSigs e tve rec_clas rec_classop_spec_fn clas_tyvar sigs + = mapB_Tc tc_sig sigs `thenB_Tc` \ stuff -> + let + (ops, op_gves, sel_ids, defm_ids) = unzip4 stuff + in + returnB_Tc (ops, foldr plusGVE nullGVE op_gves, sel_ids, defm_ids) + where + rec_ce = getE_CE e + rec_tce = getE_TCE e +--FAKE: fake_E = mkE rec_tce rec_ce + + tc_sig (ClassOpSig name@(ClassOpName op_uniq _ op_name tag) poly_ty pragmas src_loc) + = addSrcLocB_Tc src_loc ( + tcPolyType rec_ce rec_tce tve poly_ty `thenB_Tc` \ local_ty -> + +-- OLD: convoluted way to compute global_ty +-- let +-- (local_tyvar_tmpls, theta, tau) = splitType local_ty +-- in +-- -- Make new tyvars for each of the universally quantified type vars +-- copyTyVars (clas_tyvar:local_tyvar_tmpls) +-- `thenB_Tc` \ (inst_env, new_tyvars, _) -> +-- +-- let -- Instantiate the tau type +-- full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta +-- full_rho = mkRhoTy full_theta tau +-- inst_full_rho = instantiateTy inst_env full_rho +-- (_, global_ty) = quantifyTy new_tyvars inst_full_rho + + let + (local_tyvar_tmpls, theta, tau) = splitType local_ty + full_theta = (rec_clas, (mkTyVarTemplateTy clas_tyvar)) : theta + full_tyvar_tmpls = clas_tyvar : local_tyvar_tmpls + global_ty = mkForallTy full_tyvar_tmpls (mkRhoTy full_theta tau) + class_op = mkClassOp op_name tag local_ty + + not_elem = isn'tIn "tcClassSigs" + in + -- Check that the class type variable is mentioned + checkB_Tc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty) + (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenB_Tc_` + + -- Munch the pragmas, building a suitable default-method + -- Id from the details found there. + getUniqueB_Tc `thenB_Tc` \ d_uniq -> + + fixB_Tc ( \ ~(rec_op_id, rec_defm_id) -> + tcClassOpPragmas e{-fake_E-} + global_ty + rec_op_id rec_defm_id + (rec_classop_spec_fn class_op) + pragmas `thenB_Tc` \ (op_info, defm_info) -> + + returnB_Tc ( + mkClassOpId op_uniq rec_clas class_op global_ty op_info, + mkDefaultMethodId d_uniq rec_clas class_op False{-do better later-} global_ty defm_info + ) + + ) `thenB_Tc` \ (selector_id, default_method_id) -> + + returnB_Tc (class_op, unitGVE name selector_id, selector_id, default_method_id) + ) + + tc_sig (ClassOpSig name _ _ src_loc) + = failB_Tc (confusedNameErr + "Bad name on a class-method signature (a Prelude name?)" + name src_loc) +\end{code} diff --git a/ghc/compiler/typecheck/TcConDecls.hi b/ghc/compiler/typecheck/TcConDecls.hi new file mode 100644 index 0000000..83a170c --- /dev/null +++ b/ghc/compiler/typecheck/TcConDecls.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcConDecls where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import HsDecls(ConDecl) +import Id(Id) +import IdInfo(SpecEnv) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +tcConDecls :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> SpecEnv -> [ConDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)] + {-# GHC_PRAGMA _A_ 10 _U_ 2222212122 _N_ _S_ "LLLLLSLLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcConDecls.lhs b/ghc/compiler/typecheck/TcConDecls.lhs new file mode 100644 index 0000000..86519ac --- /dev/null +++ b/ghc/compiler/typecheck/TcConDecls.lhs @@ -0,0 +1,55 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcConDecls]{Typechecking @ConDecls@} + +\begin{code} +#include "HsVersions.h" + +module TcConDecls ( tcConDecls ) where + +import TcMonad -- typechecking monadic machinery +import AbsSyn + +import CE ( CE(..) ) +import E ( GVE(..), nullGVE, plusGVE ) +import Errors ( confusedNameErr ) +import Id ( mkDataCon, SpecEnv ) +import TCE ( TCE(..), UniqFM ) +import TVE ( TVE(..) ) +import TcMonoType ( tcMonoType ) +import Util +\end{code} + +\begin{code} +tcConDecls :: TCE -> TVE -> TyCon -> [TyVarTemplate] -> SpecEnv + -> [RenamedConDecl] -> Baby_TcM GVE + +tcConDecls tce tve tycon tyvars specenv [] = returnB_Tc nullGVE + +tcConDecls tce tve tycon tyvars specenv (cd:cds) + = tc_decl cd `thenB_Tc` \ gve_fst -> + tcConDecls tce tve tycon tyvars specenv cds `thenB_Tc` \ gve_rest -> + returnB_Tc (plusGVE gve_fst gve_rest) + where + tc_decl (ConDecl name@(OtherTopId uniq full_name) tys src_loc) + = addSrcLocB_Tc src_loc ( + mapB_Tc (tcMonoType fake_CE tce tve) tys `thenB_Tc` \ arg_tys -> + returnB_Tc [(name, data_con arg_tys)] + ) + where + fake_CE = panic "tcConDecls:CE" + + data_con arg_tys + = mkDataCon uniq + full_name + tyvars + [{-no context-}] + arg_tys + tycon + specenv + + tc_decl (ConDecl odd_name _ src_loc) + = failB_Tc (confusedNameErr "Bad name for a data constructor (a Prelude name?)" + odd_name src_loc) +\end{code} diff --git a/ghc/compiler/typecheck/TcContext.hi b/ghc/compiler/typecheck/TcContext.hi new file mode 100644 index 0000000..34f6b50 --- /dev/null +++ b/ghc/compiler/typecheck/TcContext.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcContext where +import Bag(Bag) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +tcContext :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> [(Name, Name)] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Class, UniType)] + {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcContext.lhs b/ghc/compiler/typecheck/TcContext.lhs new file mode 100644 index 0000000..fc79ae3 --- /dev/null +++ b/ghc/compiler/typecheck/TcContext.lhs @@ -0,0 +1,55 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcContext]{Typecheck a type-class context} + +\begin{code} +module TcContext ( tcContext ) where + +#include "HsVersions.h" + +import TcMonad -- typechecking monadic machinery +import AbsSyn -- the stuff being typechecked + +import CE ( lookupCE, CE(..) ) +import Errors ( naughtyCCallContextErr ) +import TCE ( TCE(..), UniqFM ) +import TVE ( TVE(..) ) +import TcMonoType ( tcMonoType ) +import Unique ( cCallableClassKey, cReturnableClassKey ) +import Util + +tcContext :: CE -> TCE -> TVE -> RenamedContext -> Baby_TcM ThetaType + +tcContext ce tce tve context + = mapB_Tc (tcClassAssertion ce tce tve) context + +tcClassAssertion ce tce tve (class_name, tyname) + | canBeUsedInContext class_name + = tcMonoType ce tce tve (MonoTyVar tyname) `thenB_Tc` \ ty -> + returnB_Tc (lookupCE ce class_name, ty) + + | otherwise + = getSrcLocB_Tc `thenB_Tc` \ locn -> + failB_Tc (naughtyCCallContextErr class_name locn) +\end{code} + +HACK warning: Someone discovered that @_CCallable_@ and @_CReturnable@ +could be used in contexts such as: +\begin{verbatim} +foo :: _CCallable a => a -> PrimIO Int +\end{verbatim} + +Doing this utterly wrecks the whole point of introducing these +classes so we specifically check that this isn't being done. + +\begin{code} +canBeUsedInContext :: Name -> Bool + +canBeUsedInContext class_name + = class_name /= cCallableClass && class_name /= cReturnableClass + where + cCallableClass = PreludeClass cCallableClassKey bottom + cReturnableClass = PreludeClass cReturnableClassKey bottom + bottom = panic "canBeUsedInContext" +\end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.hi b/ghc/compiler/typecheck/TcDefaults.hi new file mode 100644 index 0000000..03fe2bb --- /dev/null +++ b/ghc/compiler/typecheck/TcDefaults.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcDefaults where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsDecls(DefaultDecl) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcDefaults :: E -> [DefaultDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [UniType] + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs new file mode 100644 index 0000000..811f04b --- /dev/null +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -0,0 +1,67 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% +\section[TcDefaults]{Typechecking \tr{default} declarations} + +\begin{code} +#include "HsVersions.h" + +module TcDefaults ( tcDefaults ) where + +import TcMonad +import AbsSyn + +import AbsPrel ( intTy, doubleTy, unitTy ) +import AbsUniType ( UniType + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import CE ( lookupCE, CE(..) ) +import E +import Inst +import Name +import TcMonoType ( tcMonoType ) +import TcSimplify ( tcSimplifyCheckThetas ) +import TVE +import Unique ( numClassKey, Unique ) +import Util +\end{code} + +\begin{code} +tcDefaults :: E + -> [RenamedDefaultDecl] + -> TcM [UniType] -- defaulting types to heave + -- into Tc monad for later use + -- in Disambig. + +tcDefaults _ [] + = returnTc [intTy, doubleTy] -- language-specified default `default' + +tcDefaults e [DefaultDecl mono_tys locn] + = let + ce = getE_CE e + tce = getE_TCE e + tve = nullTVE + + num_clas = lookupCE ce (PreludeClass numClassKey (panic "tcDefaults")) + in + babyTcMtoTcM (mapB_Tc (tcMonoType ce tce tve) mono_tys) `thenTc` \ tau_tys -> + + -- compensate for extreme parser hack: `default ()' actually + -- sends the *type* () through to here. Squash it. + case tau_tys of + [ty] | ty == unitTy -> returnTc [] + + _ -> -- (Back to your regularly scheduled programming...) + + -- Check that all the types are instances of Num + + tcSimplifyCheckThetas (DefaultDeclOrigin locn) + [ (num_clas, ty) | ty <- tau_tys ] `thenTc` \ _ -> + -- We only care about whether it worked or not + + returnTc tau_tys -- caller will bung them into Tc monad + +tcDefaults _ (_:_) + = error "ERROR: You can only have one `default' declaration per module." + -- ToDo: proper error msg. +\end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.hi b/ghc/compiler/typecheck/TcDeriv.hi new file mode 100644 index 0000000..f37c444 --- /dev/null +++ b/ghc/compiler/typecheck/TcDeriv.hi @@ -0,0 +1,33 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcDeriv where +import Bag(Bag) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import HsBinds(Binds) +import HsDecls(FixityDecl) +import HsPat(InPat) +import Maybes(Labda) +import Name(Name) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import ProtoName(ProtoName) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcInstDcls(InstInfo) +import TcMonad(TcResult) +import TyCon(TyCon) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM) +type DerivEqn = (Class, TyCon, [TyVar], [(Class, UniType)]) +data TagThingWanted = GenCon2Tag | GenTag2Con | GenMaxTag +con2tag_PN :: TyCon -> ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +maxtag_PN :: TyCon -> ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +tag2con_PN :: TyCon -> ProtoName + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +tcDeriving :: _PackedString -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Bag InstInfo -> UniqFM TyCon -> [FixityDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo, Binds Name (InPat Name), PprStyle -> Int -> Bool -> PrettyRep) + {-# GHC_PRAGMA _A_ 5 _U_ 22220222222 _N_ _S_ "LLLSA" {_A_ 4 _U_ 2222222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs new file mode 100644 index 0000000..40007d9 --- /dev/null +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -0,0 +1,755 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[TcDeriv]{Deriving} + +Handles @deriving@ clauses on @data@ declarations. + +********** Don't forget + +Multi-instance checking in renamer should include deriving. + +\begin{code} +#include "HsVersions.h" + +module TcDeriv ( + tcDeriving, + con2tag_PN, tag2con_PN, maxtag_PN, + TagThingWanted(..), DerivEqn(..) + ) where + +IMPORT_Trace -- ToDo:rm debugging +import Outputable +import Pretty + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( copyTyVars ) +import AbsSyn -- the stuff being typechecked +import TcGenDeriv -- support code that generates all the grimy bindings + -- for derived instance decls. + +import AbsPrel ( mkFunTy ) +import AbsUniType +import UniType ( UniType(..) ) -- *********** CHEATING!!! **************** +import Bag +import CE ( CE(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import E ( E ) +import Errors +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- InstancePragmas(..) +import Id ( getDataConSig, isNullaryDataCon, DataCon(..) ) +import IdInfo +import Inst ( InstOrigin(..) ) +import InstEnv +import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) +import NameTypes ( mkFullName, mkPreludeCoreName, + Provenance(..), FullName, ShortName + ) +import ProtoName ( eqProtoName, ProtoName(..), Name ) +import RenameAuxFuns -- why not? take all of it... +import RenameBinds4 ( rnMethodBinds4, rnTopBinds4 ) +import RenameMonad4 -- initRn4, etc. +import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc ) +import TCE -- ( rngTCE, TCE(..), UniqFM ) +import TcInstDcls ( InstInfo(..), buildInstanceEnvs, mkInstanceRelatedIds ) +import TcSimplify ( tcSimplifyThetas ) +import Unique -- *Key stuff +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[TcDeriv-intro]{Introduction to how we do deriving} +%* * +%************************************************************************ + +Consider + + data T a b = C1 (Foo a) (Bar b) + | C2 Int (T b a) + | C3 (T a a) + deriving (Eq) + +We want to come up with an instance declaration of the form + + instance (Ping a, Pong b, ...) => Eq (T a b) where + x == y = ... + +It is pretty easy, albeit tedious, to fill in the code "...". The +trick is to figure out what the context for the instance decl is, +namely @Ping@, @Pong@ and friends. + +Let's call the context reqd for the T instance of class C at types +(a,b, ...) C (T a b). Thus: + + Eq (T a b) = (Ping a, Pong b, ...) + +Now we can get a (recursive) equation from the @data@ decl: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + +Foo and Bar may have explicit instances for @Eq@, in which case we can +just substitute for them. Alternatively, either or both may have +their @Eq@ instances given by @deriving@ clauses, in which case they +form part of the system of equations. + +Now all we need do is simplify and solve the equations, iterating to +find the least fixpoint. Notice that the order of the arguments can +switch around, as here in the recursive calls to T. + +Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b. + +We start with: + + Eq (T a b) = {} -- The empty set + +Next iteration: + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b u {} u {} u {} + = Eq a u Ping b + +Next iteration: + + Eq (T a b) = Eq (Foo a) u Eq (Bar b) -- From C1 + u Eq (T b a) u Eq Int -- From C2 + u Eq (T a a) -- From C3 + + After simplification: + = Eq a u Ping b + u (Eq b u Ping a) + u (Eq a u Ping a) + + = Eq a u Ping b u Eq b u Ping a + +The next iteration gives the same result, so this is the fixpoint. We +need to make a canonical form of the RHS to ensure convergence. We do +this by simplifying the RHS to a form in which + + - the classes constrain only tyvars + - the list is sorted by tyvar (major key) and then class (minor key) + - no duplicates, of course + +So, here are the synonyms for the ``equation'' structures: + +\begin{code} +type DerivEqn = (Class, TyCon, [TyVar], DerivRhs) + -- The tyvars bind all the variables in the RHS + -- NEW: it's convenient to re-use InstInfo + -- We'll "panic" out some fields... + +type DerivRhs = [(Class, TauType)] -- Same as a ThetaType! + +type DerivSoln = DerivRhs +\end{code} + +%************************************************************************ +%* * +\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} +%* * +%************************************************************************ + +\begin{code} +tcDeriving :: FAST_STRING -- name of module under scrutiny + -> GlobalNameFuns -- for "renaming" bits of generated code + -> Bag InstInfo -- What we already know about instances + -> TCE -- All known TyCon info + -> [RenamedFixityDecl] -- Fixity info; may be used for Text + -> TcM (Bag InstInfo, -- The generated "instance decls". + RenamedBinds, -- Extra generated bindings + PprStyle -> Pretty) -- Printable derived instance decls; + -- for debugging via -ddump-derivings. + +tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities + = -- Fish the "deriving"-related information out of the TCE, + -- from which we make the necessary "equations". + makeDerivEqns tce `thenTc` \ eqns -> + + -- Take the equation list and solve it, to deliver a list of + -- solutions, a.k.a. the contexts for the instance decls + -- required for the corresponding equations. + solveDerivEqns modname inst_decl_infos_in eqns + `thenTc` \ new_inst_infos -> + + -- Now augment the InstInfos, adding in the rather boring + -- actual-code-to-do-the-methods binds. We may also need to + -- generate extra not-one-inst-decl-specific binds, notably + -- "con2tag" and/or "tag2con" functions. We do these + -- separately. + + gen_taggery_Names eqns `thenTc` \ nm_alist_etc -> + let + nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ] + + -- We have the renamer's final "name funs" in our hands + -- (they were passed in). So we can handle ProtoNames + -- that refer to anything "out there". But our generated + -- code may also mention "con2tag" (etc.). So we need + -- to augment to "name funs" to include those. + (rn_val_gnf, rn_tc_gnf) = renamer_name_funs + + deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of + Just xx -> Just xx + Nothing -> rn_val_gnf pname + + deriver_name_funs = (deriv_val_gnf, rn_tc_gnf) + + assoc_maybe [] _ = Nothing + assoc_maybe ((v,xxx) : vs) key + = if v `eqProtoName` key then Just xxx else assoc_maybe vs key + in + gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds -> + + mapTc (gen_inst_info modname fixities deriver_name_funs) new_inst_infos + `thenTc` \ really_new_inst_infos -> + + returnTc (listToBag really_new_inst_infos, + extra_binds, + ddump_deriving really_new_inst_infos extra_binds) + where + ddump_deriving :: [InstInfo] -> RenamedBinds -> (PprStyle -> Pretty) + + ddump_deriving inst_infos extra_binds sty + = ppAboves ((map (pp_1 sty) inst_infos) ++ [ppr sty extra_binds]) + where + pp_1 sty (InstInfo clas tv_tmpls ty inst_decl_theta _ _ _ mbinds _ _ _ _) + = ppAbove (ppr sty (mkSigmaTy tv_tmpls inst_decl_theta + (UniDict clas ty))) + (ppr sty mbinds) +\end{code} + + +%************************************************************************ +%* * +\subsection[TcDeriv-eqns]{Forming the equations} +%* * +%************************************************************************ + +@makeDerivEqns@ fishes around to find the info about needed derived +instances. Complicating factors: +\begin{itemize} +\item +We can only derive @Enum@ if the data type is an enumeration +type (all nullary data constructors). + +\item +We can only derive @Ix@ if the data type is an enumeration {\em +or} has just one data constructor (e.g., tuples). +\end{itemize} + +[See Appendix~E in the Haskell~1.2 report.] This code here deals w/ +all those. + +\begin{code} +makeDerivEqns :: TCE -> TcM [DerivEqn] + +makeDerivEqns tce + = let + think_about_deriving = need_deriving (rngTCE tce) + in + mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_` + + let + (derive_these, _) = removeDups cmp think_about_deriving + in + + listNF_Tc (map mk_eqn derive_these) `thenNF_Tc` \ eqns -> + + returnTc eqns + where + ------------------------------------------------------------------ + need_deriving :: [TyCon] -> [(Class, TyCon)] + -- find the tycons that have `deriving' clauses + + need_deriving tycons_to_consider + = foldr ( \ tycon acc -> + case (getTyConDerivings tycon) of + [] -> acc + cs -> [ (clas,tycon) | clas <- cs ] ++ acc + ) + [] -- init accumulator + tycons_to_consider + + ------------------------------------------------------------------ + chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM () + + chk_out whole_deriving_list this_one@(clas, tycon) + = -- Are the relevant superclasses catered for? + -- E.g., for "... deriving Ord", is there an + -- instance of "Eq"? + let + (_, super_classes, _) = getClassSig clas + clas_key = getClassKey clas + in + + -- Are things OK for deriving Enum (if appropriate)? + checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon)) + (derivingEnumErr tycon) `thenTc_` + + -- Are things OK for deriving Ix (if appropriate)? + checkTc (clas_key == ixClassKey + && not (isEnumerationTyCon tycon + || maybeToBool (maybeSingleConstructorTyCon tycon))) + (derivingIxErr tycon) + + ------------------------------------------------------------------ + cmp :: (Class, TyCon) -> (Class, TyCon) -> TAG_ + + cmp (c1, t1) (c2, t2) + = case cmpClass c1 c2 of + EQ_ -> cmpTyCon t1 t2 + other -> other + + ------------------------------------------------------------------ + mk_eqn :: (Class, TyCon) -> NF_TcM DerivEqn + -- we swizzle the tyvars, data cons, etc., out of the tycon, + -- to make the rest of the equation + + mk_eqn (clas, tycon) + = let + tyvar_tmpls = getTyConTyVarTemplates tycon + data_cons = getTyConDataCons tycon + in + copyTyVars tyvar_tmpls `thenNF_Tc` \ (_, tyvars, tyvar_tys) -> + + let + constraints = concat [mk_constraints tyvar_tys con | con <- data_cons] + in + returnNF_Tc (clas, tycon, tyvars, constraints) + where + mk_constraints tyvar_tys data_con + = [ (clas, instantiateTy inst_env arg_ty) + | arg_ty <- arg_tys, + not (isPrimType arg_ty) -- No constraints for primitive types + ] + where + (con_tyvar_tmpls, _, arg_tys, _) = getDataConSig data_con + inst_env = con_tyvar_tmpls `zipEqual` tyvar_tys + -- Type vars in data contructor should be same in number + -- as in the type contsructor! +\end{code} + +%************************************************************************ +%* * +\subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations} +%* * +%************************************************************************ + +A ``solution'' (to one of the equations) is a list of (k,UniTyVar tv) +terms, which is the final correct RHS for the corresponding original +equation. +\begin{itemize} +\item +Each (k,UniTyVarTemplate tv) in a solution constrains only a type +variable, tv. + +\item +The (k,UniTyVarTemplate tv) pairs in a solution are canonically +ordered by sorting on type varible, tv, (major key) and then class, k, +(minor key) +\end{itemize} + +\begin{code} +solveDerivEqns :: FAST_STRING + -> Bag InstInfo + -> [DerivEqn] + -> TcM [InstInfo] -- Solns in same order as eqns. + -- This bunch is Absolutely minimal... + +solveDerivEqns modname inst_decl_infos_in orig_eqns + = iterateDeriv initial_solutions + where + -- The initial solutions for the equations claim that each + -- instance has an empty context; this solution is certainly + -- in canonical form. + initial_solutions :: [DerivSoln] + initial_solutions = [ [] | _ <- orig_eqns ] + + -- iterateDeriv calculates the next batch of solutions, + -- compares it with the current one; finishes if they are the + -- same, otherwise recurses with the new solutions. + + iterateDeriv :: [DerivSoln] ->TcM [InstInfo] + + iterateDeriv current_solns + = -- Extend the inst info from the explicit instance decls + -- with the current set of solutions, giving a + + add_solns modname inst_decl_infos_in orig_eqns current_solns + `thenTc` \ (new_inst_infos, inst_mapper) -> + + -- Simplify each RHS, using a DerivingOrigin containing an + -- inst_mapper reflecting the previous solution + let + mk_deriv_origin clas ty + = DerivingOrigin inst_mapper clas is_fun_type tycon locn + where + is_fun_type = isFunType ty + (tycon,_,_) = getUniDataTyCon ty + locn = if is_fun_type then mkUnknownSrcLoc{-sigh-} else getSrcLoc tycon + in + listTc [ tcSimplifyThetas mk_deriv_origin rhs + | (_, _, _, rhs) <- orig_eqns + ] `thenTc` \ next_solns -> + + -- Canonicalise the solutions, so they compare nicely + let canonicalised_next_solns + = [ sortLt less_than next_soln | next_soln <- next_solns ] in + + if current_solns == canonicalised_next_solns then + returnTc new_inst_infos + else + iterateDeriv canonicalised_next_solns + + where + ------------------------------------------------------------------ + less_than :: (Class, TauType) -> (Class, TauType) -> Bool + + less_than (clas1, UniTyVar tv1) (clas2, UniTyVar tv2) + = tv1 < tv2 || (tv1 == tv2 && clas1 < clas2) +#ifdef DEBUG + less_than other_1 other_2 + = pprPanic "tcDeriv:less_than:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2]) +#endif +\end{code} + +\begin{code} +add_solns :: FAST_STRING + -> Bag InstInfo -- The global, non-derived ones + -> [DerivEqn] -> [DerivSoln] + -> TcM ([InstInfo], -- The new, derived ones + InstanceMapper) + -- the eqns and solns move "in lockstep"; we have the eqns + -- because we need the LHS info for addClassInstance. + +add_solns modname inst_infos_in eqns solns + = listTc (zipWith mk_deriv_inst_info eqns solns) `thenTc` \ new_inst_infos -> + + buildInstanceEnvs (inst_infos_in `unionBags` + listToBag new_inst_infos) `thenTc` \ inst_mapper -> + + returnTc (new_inst_infos, inst_mapper) + where + mk_deriv_inst_info (clas, tycon, tyvars, _) theta + -- The complication here is rather boring: InstInfos need TyVarTemplates, + -- and we have only TyVars in our hand. + = let + tyvar_tmpls = mkTemplateTyVars tyvars + tv_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls + + env = tyvars `zipEqual` tv_tmpl_tys + + tycon_tmpl_ty = applyTyCon tycon tv_tmpl_tys + theta_tmpl = [(clas, mapOverTyVars to_tmpl ty) | (clas,ty) <- theta] + + to_tmpl = assoc "mk_deriv_inst_info" env + + (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas + in + returnTc ( + InstInfo clas tyvar_tmpls tycon_tmpl_ty + theta_tmpl + theta_tmpl -- Blarg. This is the dfun_theta slot, + -- which is needed by buildInstanceEnv; + -- This works ok for solving the eqns, and + -- gen_eqns sets it to its final value + -- (incl super class dicts) before we + -- finally return it. +#ifndef DEBUG + (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids") + (panic "add_soln:binds") (panic "add_soln:from_here") + (panic "add_soln:modname") mkGeneratedSrcLoc + (panic "add_soln:upragmas") + ) +#else + bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom + ) + where + bottom = panic "add_soln" +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[TcDeriv-normal-binds]{Bindings for the various classes} +%* * +%************************************************************************ + +After all the trouble to figure out the required context for the +derived instance declarations, all that's left is to chug along to +produce them. They will then be shoved into @tcInstDecls2@, which +will do all its usual business. + +There are lots of possibilities for code to generate. Here are +various general remarks. + +PRINCIPLES: +\begin{itemize} +\item +We want derived instances of @Eq@ and @Ord@ (both v common) to be +``you-couldn't-do-better-by-hand'' efficient. + +\item +Deriving @Text@---also pretty common, usually just for +@show@---should also be reasonable good code. + +\item +Deriving for the other classes isn't that common or that big a deal. +\end{itemize} + +PRAGMATICS: + +\begin{itemize} +\item +Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method. + +\item +Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too. + +\item +We {\em normally} generated code only for the non-defaulted methods; +there are some exceptions for @Eq@ and (especially) @Ord@... + +\item +Sometimes we use a @_con2tag_@ function, which returns a data +constructor's numeric (@Int#@) tag. These are generated by +@gen_tag_n_con_binds@, and the heuristic for deciding if one of +these is around is given by @hasCon2TagFun@. + + +The examples under the different sections below will make this +clearer. + +\item +Much less often (really just for deriving @Ix@), we use a +@_tag2con_@ function. See the examples. + +\item +We use Pass~4 of the renamer!!! Reason: we're supposed to be +producing @RenamedMonoBinds@ for the methods, but that means +producing correctly-uniquified code on the fly. This is entirely +possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. +So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through +the renamer. What a great hack! +\end{itemize} + +\begin{code} +gen_inst_info :: FAST_STRING -- Module name + -> [RenamedFixityDecl] -- all known fixities; + -- may be needed for Text + -> GlobalNameFuns -- lookup stuff for names we may use + -> InstInfo -- the main stuff to work on + -> TcM InstInfo -- the gen'd (filled-in) "instance decl" + +gen_inst_info modname fixities deriver_name_funs + info@(InstInfo clas tyvar_tmpls ty inst_decl_theta _ _ _ _ _ _ locn _) + = + -- Generate the various instance-related Ids + mkInstanceRelatedIds + (panic "add_solns:E") + -- These two are only needed if there are pragmas to typecheck; + -- but there ain't since we are generating the code right here. + True {-yes, from_here-} + NoInstancePragmas + mkGeneratedSrcLoc + clas + tyvar_tmpls ty + inst_decl_theta + [{-no user pragmas-}] + `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + + -- Generate the bindings for the new instance declaration, + -- rename it, and check for errors + getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> + let + (tycon,_,_) = getUniDataTyCon ty + + omit_readsPrec = sw_chkr OmitDerivedRead + + proto_mbinds + = if clas_key == textClassKey then gen_Text_binds fixities omit_readsPrec tycon + else if clas_key == eqClassKey then gen_Eq_binds tycon + else if clas_key == ordClassKey then gen_Ord_binds tycon + else if clas_key == enumClassKey then gen_Enum_binds tycon + else if clas_key == ixClassKey then gen_Ix_binds tycon + else if clas_key == binaryClassKey then gen_Binary_binds tycon + else panic "gen_inst_info:bad derived class" + in + rn4MtoTcM deriver_name_funs ( + rnMethodBinds4 clas_Name proto_mbinds + ) `thenNF_Tc` \ (mbinds, errs) -> + + if not (isEmptyBag errs) then + pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) + else + --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) ( + + -- All done + let + from_here = isLocallyDefined tycon -- If so, then from here + in + returnTc (InstInfo clas tyvar_tmpls ty + inst_decl_theta dfun_theta dfun_id const_meth_ids + -- and here comes the main point... + (if from_here then mbinds else EmptyMonoBinds) + from_here modname locn []) + --) + where + clas_key = getClassKey clas + clas_Name + = let (mod, nm) = getOrigName clas in + PreludeClass clas_key (mkPreludeCoreName mod nm) +\end{code} + +%************************************************************************ +%* * +\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)} +%* * +%************************************************************************ + +data Foo ... = ... + +con2tag_Foo :: Foo ... -> Int# +tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# +maxtag_Foo :: Int -- ditto (NB: not unboxed) + +\begin{code} +gen_tag_n_con_binds :: GlobalNameFuns + -> [(ProtoName, Name, TyCon, TagThingWanted)] + -> TcM RenamedBinds + +gen_tag_n_con_binds deriver_name_funs nm_alist_etc + = let + proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc + proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list + in + + rn4MtoTcM deriver_name_funs ( + rnTopBinds4 (SingleBind (RecBind proto_mbinds)) + ) `thenNF_Tc` \ (binds, errs) -> + + if not (isEmptyBag errs) then + panic "gen_inst_info:renamer errs (2)!" + else + returnTc binds +\end{code} + +%************************************************************************ +%* * +\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} +%* * +%************************************************************************ + +We have a @con2tag@ function for a tycon if: +\begin{itemize} +\item +We're deriving @Eq@ and the tycon has nullary data constructors. + +\item +Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@ +(enum type only????) +\end{itemize} + +We have a @tag2con@ function for a tycon if: +\begin{itemize} +\item +We're deriving @Enum@, or @Ix@ (enum type only???) +\end{itemize} + +If we have a @tag2con@ function, we also generate a @maxtag@ constant. + +\begin{code} +data TagThingWanted + = GenCon2Tag | GenTag2Con | GenMaxTag + +gen_taggery_Names :: [DerivEqn] + -> TcM [(ProtoName, Name, -- for an assoc list + TyCon, -- related tycon + TagThingWanted)] + +gen_taggery_Names eqns + = let all_tycons = [ tc | (_, tc, _, _) <- eqns ] + (tycons_of_interest, _) = removeDups cmpTyCon all_tycons + in + foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> + foldlTc do_tag2con names_so_far tycons_of_interest + where + do_con2tag acc_Names tycon + = if (we_are_deriving eqClassKey tycon + && any isNullaryDataCon (getTyConDataCons tycon)) + || (we_are_deriving ordClassKey tycon + && not (maybeToBool (maybeSingleConstructorTyCon tycon))) + || (we_are_deriving enumClassKey tycon) + || (we_are_deriving ixClassKey tycon) + then + getUniqueTc `thenNF_Tc` ( \ u -> + returnTc ((con2tag_PN tycon, OtherTopId u (con2tag_FN tycon), tycon, GenCon2Tag) + : acc_Names) ) + else + returnTc acc_Names + + do_tag2con acc_Names tycon + = if (we_are_deriving enumClassKey tycon) + || (we_are_deriving ixClassKey tycon) + then + getUniqueTc `thenNF_Tc` \ u1 -> + getUniqueTc `thenNF_Tc` \ u2 -> + returnTc ( (tag2con_PN tycon, OtherTopId u1 (tag2con_FN tycon), tycon, GenTag2Con) + : (maxtag_PN tycon, OtherTopId u2 (maxtag_FN tycon), tycon, GenMaxTag) + : acc_Names) + else + returnTc acc_Names + + we_are_deriving clas_key tycon + = is_in_eqns clas_key tycon eqns + where + is_in_eqns clas_key tycon [] = False + is_in_eqns clas_key tycon ((c,t,_,_):eqns) -- ToDo: InstInfo + = (clas_key == getClassKey c && tycon == t) + || is_in_eqns clas_key tycon eqns + +con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName +con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName + +con2tag_PN tycon + = let (mod, nm) = getOrigName tycon + con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") + in + Imp mod con2tag [mod] con2tag + +con2tag_FN tycon + = let (mod, nm) = getOrigName tycon + con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") + in + mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc + +tag2con_PN tycon + = let (mod, nm) = getOrigName tycon + tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") + in + Imp mod tag2con [mod] tag2con + +tag2con_FN tycon + = let (mod, nm) = getOrigName tycon + tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") + in + mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc + +maxtag_PN tycon + = let (mod, nm) = getOrigName tycon + maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") + in + Imp mod maxtag [mod] maxtag + +maxtag_FN tycon + = let (mod, nm) = getOrigName tycon + maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") + in + mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc +\end{code} diff --git a/ghc/compiler/typecheck/TcExpr.hi b/ghc/compiler/typecheck/TcExpr.hi new file mode 100644 index 0000000..46fe724 --- /dev/null +++ b/ghc/compiler/typecheck/TcExpr.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcExpr where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsExpr(Expr) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcExpr :: E -> Expr Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, LIE, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs new file mode 100644 index 0000000..6b73340 --- /dev/null +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -0,0 +1,701 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcExpr]{TcExpr} + +\begin{code} +#include "HsVersions.h" + +module TcExpr ( + tcExpr +#ifdef DPH + , tcExprs +#endif + ) where + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( newPolyTyVarTy, newOpenTyVarTy, + newDict, newMethod, newOverloadedLit, + applyTcSubstAndCollectTyVars, + mkIdsWithPolyTyVarTys + ) +import AbsSyn -- the stuff being typechecked + + +import AbsPrel ( intPrimTy, charPrimTy, doublePrimTy, + floatPrimTy, addrPrimTy, addrTy, + boolTy, charTy, stringTy, mkFunTy, mkListTy, + mkTupleTy, mkPrimIoTy +#ifdef DPH + ,mkProcessorTy, mkPodTy,toPodId, + processorClass,pidClass +#endif {- Data Parallel Haskell -} + ) +import AbsUniType +import E +import CE ( lookupCE ) + +#ifndef DPH +import Errors ( badMatchErr, UnifyErrContext(..) ) +#else +import Errors ( badMatchErr, podCompLhsError, UnifyErrContext(..) ) +#endif {- Data Parallel Haskell -} + +import GenSpecEtc ( checkSigTyVars ) +import Id ( mkInstId, getIdUniType, Id ) +import Inst +import LIE ( nullLIE, unitLIE, plusLIE, unMkLIE, mkLIE, LIE ) +import ListSetOps ( unionLists ) +import Maybes ( Maybe(..) ) +import TVE ( nullTVE, TVE(..) ) +import Spec ( specId, specTy ) +import TcBinds ( tcLocalBindsAndThen ) +import TcMatches ( tcMatchesCase, tcMatch ) +import TcPolyType ( tcPolyType ) +import TcQuals ( tcQuals ) +import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) +#ifdef DPH +import TcParQuals +#endif {- Data Parallel Haskell -} +import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) +import UniqFM ( emptyUFM ) -- profiling, pragmas only +import Unique -- *Key stuff +import Util + +tcExpr :: E -> RenamedExpr -> TcM (TypecheckedExpr, LIE, UniType) +\end{code} + +%************************************************************************ +%* * +\subsection{The TAUT rules for variables} +%* * +%************************************************************************ + +\begin{code} +tcExpr e (Var name) + = specId (lookupE_Value e name) `thenNF_Tc` \ stuff@(expr, lie, ty) -> + + -- Check that there's no lurking rank-2 polymorphism + -- isTauTy is over-paranoid, because we don't expect + -- any submerged polymorphism other than rank-2 polymorphism + + checkTc (not (isTauTy ty)) (error "tcExpr Var: MISSING ERROR MESSAGE") -- ToDo: + `thenTc_` + + returnTc stuff +\end{code} + +%************************************************************************ +%* * +\subsection{Literals} +%* * +%************************************************************************ + +Overloaded literals. + +\begin{code} +tcExpr e (Lit lit@(IntLit i)) + = getSrcLocTc `thenNF_Tc` \ loc -> + newPolyTyVarTy `thenNF_Tc` \ ty -> + let + from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") + from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") + in + newOverloadedLit (LiteralOrigin lit loc) + (OverloadedIntegral i from_int from_integer) + ty + `thenNF_Tc` \ over_lit -> + + returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty) + +tcExpr e (Lit lit@(FracLit f)) + = getSrcLocTc `thenNF_Tc` \ loc -> + newPolyTyVarTy `thenNF_Tc` \ ty -> + let + from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational") + in + newOverloadedLit (LiteralOrigin lit loc) + (OverloadedFractional f from_rational) + ty + `thenNF_Tc` \ over_lit -> + + returnTc (Var (mkInstId over_lit), unitLIE over_lit, ty) + +tcExpr e (Lit lit@(LitLitLitIn s)) + = getSrcLocTc `thenNF_Tc` \ loc -> + let + -- Get the callable class. Rather turgid and a HACK (ToDo). + ce = getE_CE e + cCallableClass = lookupCE ce (PreludeClass cCallableClassKey bottom) + bottom = panic "tcExpr:LitLitLit" + in + newPolyTyVarTy `thenNF_Tc` \ ty -> + + newDict (LitLitOrigin loc (_UNPK_ s)) cCallableClass ty `thenNF_Tc` \ dict -> + + returnTc (Lit (LitLitLit s ty), mkLIE [dict], ty) +\end{code} + +Primitive literals: + +\begin{code} +tcExpr e (Lit (CharPrimLit c)) + = returnTc (Lit (CharPrimLit c), nullLIE, charPrimTy) + +tcExpr e (Lit (StringPrimLit s)) + = returnTc (Lit (StringPrimLit s), nullLIE, addrPrimTy) + +tcExpr e (Lit (IntPrimLit i)) + = returnTc (Lit (IntPrimLit i), nullLIE, intPrimTy) + +tcExpr e (Lit (FloatPrimLit f)) + = returnTc (Lit (FloatPrimLit f), nullLIE, floatPrimTy) + +tcExpr e (Lit (DoublePrimLit d)) + = returnTc (Lit (DoublePrimLit d), nullLIE, doublePrimTy) +\end{code} + +Unoverloaded literals: + +\begin{code} +tcExpr e (Lit (CharLit c)) + = returnTc (Lit (CharLit c), nullLIE, charTy) + +tcExpr e (Lit (StringLit str)) + = returnTc (Lit (StringLit str), nullLIE, stringTy) +\end{code} + +%************************************************************************ +%* * +\subsection{Other expression forms} +%* * +%************************************************************************ + +\begin{code} +tcExpr e (Lam match) + = tcMatch e match `thenTc` \ (match',lie,ty) -> + returnTc (Lam match',lie,ty) + +tcExpr e (App e1 e2) = accum e1 [e2] + where + accum (App e1 e2) args = accum e1 (e2:args) + accum fun args = tcApp (foldl App) e fun args + +-- equivalent to (op e1) e2: +tcExpr e (OpApp e1 op e2) + = tcApp (\fun [arg1,arg2] -> OpApp arg1 fun arg2) e op [e1,e2] +\end{code} + +Note that the operators in sections are expected to be binary, and +a type error will occur if they aren't. + +\begin{code} +-- equivalent to +-- \ x -> e op x, +-- or +-- \ x -> op e x, +-- or just +-- op e + +tcExpr e (SectionL expr op) + = tcApp (\ fun [arg] -> SectionL arg fun) e op [expr] + +-- equivalent to \ x -> x op expr, or +-- \ x -> op x expr + +tcExpr e (SectionR op expr) + = tcExpr e op `thenTc` \ (op', lie1, op_ty) -> + tcExpr e expr `thenTc` \ (expr',lie2, expr_ty) -> + newOpenTyVarTy `thenNF_Tc` \ ty1 -> + newOpenTyVarTy `thenNF_Tc` \ ty2 -> + let + result_ty = mkFunTy ty1 ty2 + in + unifyTauTy op_ty (mkFunTy ty1 (mkFunTy expr_ty ty2)) + (SectionRAppCtxt op expr) `thenTc_` + + returnTc (SectionR op' expr', plusLIE lie1 lie2, result_ty) +\end{code} + +The interesting thing about @ccall@ is that it is just a template +which we instantiate by filling in details about the types of its +argument and result (ie minimal typechecking is performed). So, the +basic story is that we allocate a load of type variables (to hold the +arg/result types); unify them with the args/result; and store them for +later use. + +\begin{code} +tcExpr e (CCall lbl args may_gc is_asm ignored_fake_result_ty) + = getSrcLocTc `thenNF_Tc` \ src_loc -> + let + -- Get the callable and returnable classes. Rather turgid (ToDo). + ce = getE_CE e + cCallableClass = lookupCE ce (PreludeClass cCallableClassKey bottom) + cReturnableClass = lookupCE ce (PreludeClass cReturnableClassKey bottom) + bottom = panic "tcExpr:CCall" + + new_arg_dict (arg, arg_ty) = newDict (CCallOrigin src_loc (_UNPK_ lbl) (Just arg)) + cCallableClass arg_ty + + result_origin = CCallOrigin src_loc (_UNPK_ lbl) Nothing {- Not an arg -} + in + + -- Arguments + tcExprs e args `thenTc` \ (args', args_lie, arg_tys) -> + + -- The argument types can be unboxed or boxed; the result + -- type must, however, be boxed since it's an argument to the PrimIO + -- type constructor. + newPolyTyVarTy `thenNF_Tc` \ result_ty -> + + -- Construct the extra insts, which encode the + -- constraints on the argument and result types. + mapNF_Tc new_arg_dict (args `zip` arg_tys) `thenNF_Tc` \ arg_dicts -> + newDict result_origin cReturnableClass result_ty `thenNF_Tc` \ res_dict -> + + returnTc (CCall lbl args' may_gc is_asm result_ty, + args_lie `plusLIE` mkLIE (res_dict : arg_dicts), + mkPrimIoTy result_ty) +\end{code} + +\begin{code} +tcExpr e (SCC label expr) + = tcExpr e expr `thenTc` \ (expr', lie, expr_ty) -> + -- No unification. Give SCC the type of expr + returnTc (SCC label expr', lie, expr_ty) + +tcExpr e (Let binds expr) + = tcLocalBindsAndThen e + Let -- The combiner + binds -- Bindings to check + (\ e -> tcExpr e expr) -- Typechecker for the expression + +tcExpr e (Case expr matches) + = tcExpr e expr `thenTc` \ (expr',lie1,expr_ty) -> + tcMatchesCase e matches `thenTc` \ (matches',lie2,match_ty) -> + newOpenTyVarTy `thenNF_Tc` \ result_ty -> + + unifyTauTy (mkFunTy expr_ty result_ty) match_ty + (CaseCtxt expr matches) `thenTc_` + + returnTc (Case expr' matches', plusLIE lie1 lie2, result_ty) + +tcExpr e (If pred b1 b2) + = tcExpr e pred `thenTc` \ (pred',lie1,predTy) -> + + unifyTauTy predTy boolTy (PredCtxt pred) `thenTc_` + + tcExpr e b1 `thenTc` \ (b1',lie2,result_ty) -> + tcExpr e b2 `thenTc` \ (b2',lie3,b2Ty) -> + + unifyTauTy result_ty b2Ty (BranchCtxt b1 b2) `thenTc_` + + returnTc (If pred' b1' b2', plusLIE lie1 (plusLIE lie2 lie3), result_ty) + +tcExpr e (ListComp expr quals) + = mkIdsWithPolyTyVarTys binders `thenNF_Tc` \ lve -> + -- Binders of a list comprehension must be boxed. + let + new_e = growE_LVE e lve + in + tcQuals new_e quals `thenTc` \ (quals',lie1) -> + tcExpr new_e expr `thenTc` \ (expr', lie2, ty) -> + returnTc (ListComp expr' quals', plusLIE lie1 lie2, mkListTy ty) + where + binders = collectQualBinders quals +\end{code} + +\begin{code} +tcExpr e (ExplicitList []) + = newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> + returnTc (ExplicitListOut tyvar_ty [], nullLIE, mkListTy tyvar_ty) + + +tcExpr e (ExplicitList exprs) -- Non-empty list + = tcExprs e exprs `thenTc` \ (exprs', lie, tys@(elt_ty:_)) -> + unifyTauTyList tys (ListCtxt exprs) `thenTc_` + returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty) + +tcExpr e (ExplicitTuple exprs) + = tcExprs e exprs `thenTc` \ (exprs', lie, tys) -> + returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys) + +tcExpr e (ArithSeqIn seq@(From expr)) + = getSrcLocTc `thenNF_Tc` \ loc -> + tcExpr e expr `thenTc` \ (expr', lie, ty) -> + let + enum_from_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFrom") + in + newMethod (ArithSeqOrigin seq loc) + enum_from_id [ty] `thenNF_Tc` \ enum_from -> + + returnTc (ArithSeqOut (Var (mkInstId enum_from)) (From expr'), + plusLIE (unitLIE enum_from) lie, + mkListTy ty) + +tcExpr e (ArithSeqIn seq@(FromThen expr1 expr2)) + = getSrcLocTc `thenNF_Tc` \ loc -> + tcExpr e expr1 `thenTc` \ (expr1',lie1,ty1) -> + tcExpr e expr2 `thenTc` \ (expr2',lie2,ty2) -> + + unifyTauTyList [ty1, ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_` + let + enum_from_then_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThen") + in + newMethod (ArithSeqOrigin seq loc) + enum_from_then_id [ty1] `thenNF_Tc` \ enum_from_then -> + + returnTc (ArithSeqOut (Var (mkInstId enum_from_then)) + (FromThen expr1' expr2'), + (unitLIE enum_from_then) `plusLIE` lie1 `plusLIE` lie2, + mkListTy ty1) + +tcExpr e (ArithSeqIn seq@(FromTo expr1 expr2)) + = getSrcLocTc `thenNF_Tc` \ loc -> + tcExpr e expr1 `thenTc` \ (expr1',lie1,ty1) -> + tcExpr e expr2 `thenTc` \ (expr2',lie2,ty2) -> + + unifyTauTyList [ty1,ty2] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_` + let + enum_from_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromTo") + in + newMethod (ArithSeqOrigin seq loc) + enum_from_to_id [ty1] `thenNF_Tc` \ enum_from_to -> + returnTc (ArithSeqOut (Var (mkInstId enum_from_to)) + (FromTo expr1' expr2'), + (unitLIE enum_from_to) `plusLIE` lie1 `plusLIE` lie2, + mkListTy ty1) + +tcExpr e (ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) + = getSrcLocTc `thenNF_Tc` \ loc -> + tcExpr e expr1 `thenTc` \ (expr1',lie1,ty1) -> + tcExpr e expr2 `thenTc` \ (expr2',lie2,ty2) -> + tcExpr e expr3 `thenTc` \ (expr3',lie3,ty3) -> + + unifyTauTyList [ty1,ty2,ty3] (ArithSeqCtxt (ArithSeqIn seq)) `thenTc_` + let + enum_from_then_to_id = lookupE_ClassOpByKey e enumClassKey SLIT("enumFromThenTo") + in + newMethod (ArithSeqOrigin seq loc) + enum_from_then_to_id [ty1] `thenNF_Tc` \ enum_from_then_to -> + + returnTc (ArithSeqOut (Var (mkInstId enum_from_then_to)) + (FromThenTo expr1' expr2' expr3'), + (unitLIE enum_from_then_to) `plusLIE` lie1 `plusLIE` lie2 `plusLIE` lie3, + mkListTy ty1) +\end{code} + +%************************************************************************ +%* * +\subsection{Expressions type signatures} +%* * +%************************************************************************ + +\begin{code} +tcExpr e (ExprWithTySig expr poly_ty) + = tcExpr e expr `thenTc` \ (texpr, lie, tau_ty) -> + babyTcMtoTcM (tcPolyType (getE_CE e) (getE_TCE e) nullTVE poly_ty) `thenTc` \ sigma_sig -> + + -- Check the tau-type part + specTy SignatureOrigin sigma_sig `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau) -> + unifyTauTy tau_ty sig_tau (ExprSigCtxt expr sig_tau) `thenTc_` + + -- Check the type variables of the signature + applyTcSubstAndCollectTyVars (tvOfE e) `thenNF_Tc` \ env_tyvars -> + checkSigTyVars env_tyvars sig_tyvars sig_tau tau_ty (ExprSigCtxt expr sig_tau) + `thenTc` \ sig_tyvars' -> + + -- Check overloading constraints + tcSimplifyAndCheck + False {- Not top level -} + env_tyvars sig_tyvars' + sig_dicts (unMkLIE lie) + (ExprSigCtxt expr sigma_sig) `thenTc_` + + -- If everything is ok, return the stuff unchanged, except for + -- the effect of any substutions etc. We simply discard the + -- result of the tcSimplifyAndCheck, except for any default + -- resolution it may have done, which is recorded in the + -- substitution. + returnTc (texpr, lie, tau_ty) +\end{code} + +%************************************************************************ +%* * +\subsection{Data Parallel Expressions (DPH only)} +%* * +%************************************************************************ + +Constraints enforced by the Static semantics for ParallelZF +$exp_1$ = << $exp_2$ | quals >> + +\begin{enumerate} +\item The type of the expression $exp_1$ is <<$exp_2$>> +\item The type of $exp_2$ must be in the class {\tt Processor} +\end{enumerate} + +\begin{code} +#ifdef DPH +tcExpr e (ParallelZF expr quals) + = let binders = collectParQualBinders quals in + mkIdsWithPolyTyVarTys binders `thenNF_Tc` (\ lve -> + let e' = growE_LVE e lve in + tcParQuals e' quals `thenTc` (\ (quals',lie1) -> + tcExpr e' expr `thenTc` (\ (expr', lie2,ty) -> + getSrcLocTc `thenNF_Tc` (\ src_loc -> + if (isProcessorTy ty) then + returnTc (ParallelZF expr' quals', + plusLIE lie1 lie2 , + mkPodTy ty) + else + failTc (podCompLhsError ty src_loc) + )))) +#endif {- Data Parallel Haskell -} +\end{code} + +Constraints enforced by the Static semantics for Explicit Pods +exp = << $exp_1$ ... $exp_n$>> (where $n >= 0$) + +\begin{enumerate} +\item The type of the all the expressions in the Pod must be the same. +\item The type of an expression in a POD must be in class {\tt Processor} +\end{enumerate} + +\begin{code} +#ifdef DPH +tcExpr e (ExplicitPodIn exprs) + = panic "Ignoring explicit PODs for the time being" +{- + = tcExprs e exprs `thenTc` (\ (exprs',lie,tys) -> + newPolyTyVarTy `thenNF_Tc` (\ elt_ty -> + newDict processorClass elt_ty `thenNF_Tc` (\ procDict -> + let + procLie = mkLIEFromDicts procDict + in + unifyTauTyList (elt_ty:tys) (PodCtxt exprs) `thenTc_` + + returnTc ((App + (DictApp + (TyApp (Var toPodId) [elt_ty]) + procDict) + (ExplicitListOut elt_ty exprs')), + plusLIE procLie lie, + mkPodTy elt_ty) + ))) -} +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +#ifdef DPH +tcExpr e (ExplicitProcessor exprs expr) + = tcPidExprs e exprs `thenTc` (\ (exprs',lie1,tys) -> + tcExpr e expr `thenTc` (\ (expr',lie2,ty) -> + returnTc (ExplicitProcessor exprs' expr', + plusLIE lie1 lie2, + mkProcessorTy tys ty) + )) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection{@tcExprs@ typechecks a {\em list} of expressions} +%* * +%************************************************************************ + +ToDo: Possibly find a version of a listTc TcM which would pass the +appropriate functions for the LIE. + +\begin{code} +tcExprs :: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType]) + +tcExprs e [] = returnTc ([], nullLIE, []) +tcExprs e (expr:exprs) + = tcExpr e expr `thenTc` \ (expr', lie1, ty) -> + tcExprs e exprs `thenTc` \ (exprs', lie2, tys) -> + returnTc (expr':exprs', plusLIE lie1 lie2, ty:tys) +\end{code} + + +%************************************************************************ +%* * +\subsection{@tcApp@ typchecks an application} +%* * +%************************************************************************ + +\begin{code} +tcApp :: (TypecheckedExpr -> [TypecheckedExpr] -> TypecheckedExpr) -- Result builder + -> E + -> RenamedExpr + -> [RenamedExpr] + -> TcM (TypecheckedExpr, LIE, UniType) + +tcApp build_result_expression e orig_fun arg_exprs + = tcExpr' e orig_fun (length arg_exprs) + `thenTc` \ (fun', lie_fun, fun_ty) -> + unify_fun 1 fun' lie_fun arg_exprs fun_ty + where + -- Used only in the error message + maybe_fun_id = case orig_fun of + Var name -> Just (lookupE_Value e name) + other -> Nothing + + unify_args :: Int -- Current argument number + -> TypecheckedExpr -- Current rebuilt expression + -> LIE -- Corresponding LIE + -> [RenamedExpr] -- Remaining args + -> [TauType] -- Remaining arg types + -> TauType -- result type + -> TcM (TypecheckedExpr, LIE, UniType) + + unify_args arg_no fun lie (arg:args) (arg_ty:arg_tys) fun_res_ty + = tcExpr e arg `thenTc` \ (arg', lie_arg, actual_arg_ty) -> + + -- These applyTcSubstToTy's are just to improve the error message... + applyTcSubstToTy actual_arg_ty `thenNF_Tc` \ actual_arg_ty' -> + applyTcSubstToTy arg_ty `thenNF_Tc` \ arg_ty' -> + let + err_ctxt = FunAppCtxt orig_fun maybe_fun_id arg arg_ty' actual_arg_ty' arg_no + in + matchArgTy e arg_ty' arg' lie_arg actual_arg_ty' err_ctxt + `thenTc` \ (arg'', lie_arg') -> + + unify_args (arg_no+1) (App fun arg'') (lie `plusLIE` lie_arg') args arg_tys fun_res_ty + + unify_args arg_no fun lie [] arg_tys fun_res_ty + = -- We've run out of actual arguments Check that none of + -- arg_tys has a for-all at the top For example, "build" on + -- its own is no good; it must be applied to something. + let + result_ty = glueTyArgs arg_tys fun_res_ty + in + checkTc (not (isTauTy result_ty)) + (error "ERROR: 2 rank failure (NEED ERROR MSG [ToDo])") `thenTc_` + returnTc (fun, lie, result_ty) + + -- When we run out of arg_tys we go back to unify_fun in the hope + -- that our unification work may have shown up some more arguments + unify_args arg_no fun lie args [] fun_res_ty + = unify_fun arg_no fun lie args fun_res_ty + + + unify_fun :: Int -- Current argument number + -> TypecheckedExpr -- Current rebuilt expression + -> LIE -- Corresponding LIE + -> [RenamedExpr] -- Remaining args + -> TauType -- Remaining function type + -> TcM (TypecheckedExpr, LIE, UniType) + + unify_fun arg_no fun lie args fun_ty + = -- Find out as much as possible about the function + applyTcSubstToTy fun_ty `thenNF_Tc` \ fun_ty' -> + + -- Now see whether it has any arguments + case (splitTyArgs fun_ty') of + + ([], _) -> -- Function has no arguments left + + newOpenTyVarTy `thenNF_Tc` \ result_ty -> + tcExprs e args `thenTc` \ (args', lie_args, arg_tys) -> + + -- At this point, a unification error must mean the function is + -- being applied to too many arguments. + unifyTauTy fun_ty' (glueTyArgs arg_tys result_ty) + (TooManyArgsCtxt orig_fun) `thenTc_` + + returnTc (build_result_expression fun args', + lie `plusLIE` lie_args, + result_ty) + + (fun_arg_tys, fun_res_ty) -> -- Function has non-empty list of argument types + + unify_args arg_no fun lie args fun_arg_tys fun_res_ty +\end{code} + +\begin{code} +matchArgTy :: E + -> UniType -- Expected argument type + -> TypecheckedExpr -- Type checked argument + -> LIE -- Actual argument LIE + -> UniType -- Actual argument type + -> UnifyErrContext + -> TcM (TypecheckedExpr, -- The incoming type checked arg, + -- possibly wrapped in a big lambda + LIE) -- Possibly reduced somewhat + +matchArgTy e expected_arg_ty arg_expr actual_arg_lie actual_arg_ty err_ctxt + | isForAllTy expected_arg_ty + = -- Ha! The argument type of the function is a for-all type, + -- An example of rank-2 polymorphism. + + -- This applyTcSubstToTy is just to improve the error message.. + + applyTcSubstToTy actual_arg_ty `thenNF_Tc` \ actual_arg_ty' -> + + -- Instantiate the argument type + -- ToDo: give this a real origin + specTy UnknownOrigin expected_arg_ty `thenNF_Tc` \ (arg_tyvars, arg_lie, arg_tau) -> + + if not (null arg_lie) then + -- Paranoia check + panic "Non-null overloading in tcApp" + else + -- Assert: arg_lie = [] + + unifyTauTy arg_tau actual_arg_ty' err_ctxt `thenTc_` + + -- Check that the arg_tyvars havn't been constrained + -- The interesting bit here is that we must include the free variables + -- of the expected arg ty. Here's an example: + -- runST (newVar True) + -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) + -- for (newVar True), with s fresh. Then we unify with the runST's arg type + -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. + -- So now s' isn't unconstrained because it's linked to a. + -- Conclusion: include the free vars of the expected arg type in the + -- list of "free vars" for the signature check. + applyTcSubstAndCollectTyVars + (tvOfE e `unionLists` + extractTyVarsFromTy expected_arg_ty) `thenNF_Tc` \ free_tyvars -> + checkSigTyVars free_tyvars arg_tyvars arg_tau actual_arg_ty rank2_err_ctxt + `thenTc` \ arg_tyvars' -> + + -- Check that there's no overloading involved + -- Even if there isn't, there may be some Insts which mention the arg_tyvars, + -- but which, on simplification, don't actually need a dictionary involving + -- the tyvar. So we have to do a proper simplification right here. + let insts = unMkLIE actual_arg_lie + in + applyTcSubstToInsts insts `thenNF_Tc` \ insts' -> + + tcSimplifyRank2 arg_tyvars' insts' rank2_err_ctxt `thenTc` \ (free_insts, inst_binds) -> + + -- This Let binds any Insts which came out of the simplification. + -- It's a bit out of place here, but using AbsBind involves inventing + -- a couple of new names which seems worse. + returnTc (TyLam arg_tyvars' (Let (mk_binds inst_binds) arg_expr), mkLIE free_insts) + + | otherwise + = -- The ordinary, non-rank-2 polymorphic case + unifyTauTy expected_arg_ty actual_arg_ty err_ctxt `thenTc_` + returnTc (arg_expr, actual_arg_lie) + + where + rank2_err_ctxt = Rank2ArgCtxt arg_expr expected_arg_ty + + mk_binds [] = EmptyBinds + mk_binds ((inst,rhs):inst_binds) = (SingleBind (NonRecBind (VarMonoBind (mkInstId inst) rhs))) + `ThenBinds` + mk_binds inst_binds +\end{code} + +This version only does not check for 2nd order if it is applied. + +\begin{code} +tcExpr' :: E -> RenamedExpr -> Int -> TcM (TypecheckedExpr,LIE,UniType) + +tcExpr' e v@(Var name) n + | n > 0 = specId (lookupE_Value e name) `thenNF_Tc` \ (expr, lie, ty) -> + returnTc (expr, lie, ty) +tcExpr' e exp n = tcExpr e exp +\end{code} diff --git a/ghc/compiler/typecheck/TcGRHSs.hi b/ghc/compiler/typecheck/TcGRHSs.hi new file mode 100644 index 0000000..09a63e8 --- /dev/null +++ b/ghc/compiler/typecheck/TcGRHSs.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcGRHSs where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsMatches(GRHSsAndBinds) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcGRHSsAndBinds :: E -> GRHSsAndBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (GRHSsAndBinds Id TypecheckedPat, LIE, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs new file mode 100644 index 0000000..a66c33a --- /dev/null +++ b/ghc/compiler/typecheck/TcGRHSs.lhs @@ -0,0 +1,76 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcGRHSs]{Typecheck guarded right-hand-sides} + +\begin{code} +module TcGRHSs ( tcGRHSsAndBinds ) where + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( boolTy ) +import E ( growE_LVE, E, LVE(..), TCE(..), UniqFM, CE(..) ) + -- TCE and CE for pragmas only +import Errors ( UnifyErrContext(..) ) +import LIE ( plusLIE, LIE ) +import TcBinds ( tcLocalBindsAndThen ) +import TcExpr ( tcExpr ) +import Unify ( unifyTauTy ) +import Util -- pragmas only +\end{code} + +\begin{code} +tcGRHSs :: E -> [RenamedGRHS] -> TcM ([TypecheckedGRHS], LIE, UniType) + +tcGRHSs e [grhs] + = tcGRHS e grhs `thenTc` \ (grhs', lie, ty) -> + returnTc ([grhs'], lie, ty) + +tcGRHSs e gs@(grhs:grhss) + = tcGRHS e grhs `thenTc` \ (grhs', lie1, ty1) -> + tcGRHSs e grhss `thenTc` \ (grhss', lie2, ty2) -> + + unifyTauTy ty1 ty2 (GRHSsBranchCtxt gs) `thenTc_` + + returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1) + + +tcGRHS e (OtherwiseGRHS expr locn) + = addSrcLocTc locn ( + tcExpr e expr `thenTc` \ (expr, lie, ty) -> + returnTc (OtherwiseGRHS expr locn, lie, ty) + ) + +tcGRHS e (GRHS guard expr locn) + = addSrcLocTc locn ( + tcExpr e guard `thenTc` \ (guard2, guard_lie, guard_ty) -> + + unifyTauTy guard_ty boolTy (GRHSsGuardCtxt guard) `thenTc_` + + tcExpr e expr `thenTc` \ (expr2, expr_lie, expr_ty) -> + + returnTc (GRHS guard2 expr2 locn, plusLIE guard_lie expr_lie, expr_ty) + ) +\end{code} + + +@tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable +pieces. + +\begin{code} +tcGRHSsAndBinds :: E + -> RenamedGRHSsAndBinds + -> TcM (TypecheckedGRHSsAndBinds, LIE, UniType) + +tcGRHSsAndBinds e (GRHSsAndBindsIn grhss binds) + = tcLocalBindsAndThen e + combiner binds + (\e -> tcGRHSs e grhss `thenTc` (\ (grhss', lie, ty) -> + returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie, ty) + ) + ) + where + combiner binds1 (GRHSsAndBindsOut grhss binds2 ty) + = GRHSsAndBindsOut grhss (binds1 `ThenBinds` binds2) ty +\end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.hi b/ghc/compiler/typecheck/TcGenDeriv.hi new file mode 100644 index 0000000..5ff491f --- /dev/null +++ b/ghc/compiler/typecheck/TcGenDeriv.hi @@ -0,0 +1,95 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcGenDeriv where +import HsBinds(MonoBinds) +import HsDecls(FixityDecl) +import HsExpr(Expr) +import HsPat(InPat) +import Name(Name) +import ProtoName(ProtoName) +import TcDeriv(TagThingWanted) +import TyCon(TyCon) +a_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv a_PN] _N_ #-} +a_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +a_Pat :: InPat ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv a_PN] _N_ #-} +ah_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +b_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv b_PN] _N_ #-} +b_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +b_Pat :: InPat ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv b_PN] _N_ #-} +bh_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +c_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv c_PN] _N_ #-} +c_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +c_Pat :: InPat ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv c_PN] _N_ #-} +ch_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cmp_eq_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +d_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv d_PN] _N_ #-} +d_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +d_Pat :: InPat ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv d_PN] _N_ #-} +dh_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqH_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eq_TAG_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv eq_TAG_PN] _N_ #-} +eq_TAG_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +error_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +false_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv false_PN] _N_ #-} +false_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +geH_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gen_Binary_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (MonoBinds ProtoName (InPat ProtoName)) } [ _NOREP_S_ "gen_Binary_binds" ] _N_ #-} +gen_Enum_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} +gen_Eq_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-} +gen_Ix_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-} +gen_Ord_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-} +gen_Text_binds :: [FixityDecl Name] -> Bool -> TyCon -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +gen_tag_n_con_monobind :: (ProtoName, Name, TyCon, TagThingWanted) -> MonoBinds ProtoName (InPat ProtoName) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LALE)" {_A_ 3 _U_ 211 _N_ _N_ _N_ _N_} _N_ _N_ #-} +gt_TAG_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv gt_TAG_PN] _N_ #-} +gt_TAG_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +leH_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +ltH_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +lt_TAG_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv lt_TAG_PN] _N_ #-} +lt_TAG_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +minusH_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +mkInt_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +rangeSize_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +true_Expr :: Expr ProtoName a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv true_PN] _N_ #-} +true_PN :: ProtoName + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs new file mode 100644 index 0000000..c1f9b64 --- /dev/null +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -0,0 +1,1070 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcGenDeriv]{Generating derived instance declarations} + +This module is nominally ``subordinate'' to @TcDeriv@, which is the +``official'' interface to deriving-related things. + +This is where we do all the grimy bindings' generation. + +\begin{code} +#include "HsVersions.h" + +module TcGenDeriv ( + a_Expr, + a_PN, + a_Pat, + ah_PN, + b_Expr, + b_PN, + b_Pat, + bh_PN, + c_Expr, + c_PN, + c_Pat, + ch_PN, + cmp_eq_PN, + d_Expr, + d_PN, + d_Pat, + dh_PN, + eqH_PN, + eq_TAG_Expr, + eq_TAG_PN, + error_PN, + false_Expr, + false_PN, + geH_PN, + gen_Binary_binds, + gen_Enum_binds, + gen_Eq_binds, + gen_Ix_binds, + gen_Ord_binds, + gen_Text_binds, + gen_tag_n_con_monobind, + gt_TAG_Expr, + gt_TAG_PN, + leH_PN, + ltH_PN, + lt_TAG_Expr, + lt_TAG_PN, + minusH_PN, + mkInt_PN, + rangeSize_PN, + true_Expr, + true_PN + ) where + +IMPORT_Trace -- ToDo:rm debugging +import Outputable +import Pretty + +import AbsSyn -- the stuff being typechecked + +import AbsPrel {-( trueDataCon, falseDataCon, intDataCon, eRROR_ID, + ltPrimDataCon, eqPrimDataCon, gtPrimDataCon, + charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, + floatPrimTy, doublePrimTy + )-} +import PrimOps -- *********** ditto + +import AbsUniType ( getTyConDataCons, isEnumerationTyCon, + maybeSingleConstructorTyCon, --UNUSED: preludeClassDerivedFor, + -- UNUSED: isEnumerationTyConMostly, + isPrimType, UniType, + TauType(..), TyVarTemplate, ThetaType(..) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Id ( getDataConArity, getDataConTag, + getDataConSig, isNullaryDataCon, fIRST_TAG, + isDataCon, DataCon(..), ConTag(..), Id + ) +import Maybes ( maybeToBool, Maybe(..) ) +import Name ( Name(..) ) +import ProtoName ( ProtoName(..) ) +import RenameAuxFuns -- why not? take all of it... +import RenameMonad4 -- initRn4, etc. +import SrcLoc ( mkGeneratedSrcLoc ) +import TcDeriv ( con2tag_PN, tag2con_PN, maxtag_PN, + TagThingWanted(..), DerivEqn(..) + ) +import Unique -- some ClassKey stuff +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[TcGenDeriv-classes]{Generating code, by derivable class} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection[TcGenDeriv-Eq]{Generating @Eq@ instance declarations} +%* * +%************************************************************************ + +Here are the heuristics for the code we generate for @Eq@: +\begin{itemize} +\item + Let's assume we have a data type with some (possibly zero) nullary + data constructors and some ordinary, non-nullary ones (the rest, + also possibly zero of them). Here's an example, with both \tr{N}ullary + and \tr{O}rdinary data cons. +\begin{verbatim} +data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... +\end{verbatim} + +\item + For the ordinary constructors (if any), we emit clauses to do The + Usual Thing, e.g.,: + +\begin{verbatim} +(==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2 +(==) (O2 a1) (O2 a2) = a1 == a2 +(==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 +\end{verbatim} + + Note: if we're comparing unboxed things, e.g., if \tr{a1} and + \tr{a2} are \tr{Float#}s, then we have to generate +\begin{verbatim} +case (a1 `eqFloat#` a2) of + r -> r +\end{verbatim} + for that particular test. + +\item + If there are any nullary constructors, we emit a catch-all clause of + the form: + +\begin{verbatim} +(==) a b = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + case (a# ==# b#) of { + r -> r + }}} +\end{verbatim} + + If there aren't any nullary constructors, we emit a simpler + catch-all: +\begin{verbatim} +(==) a b = False +\end{verbatim} + +\item + For the @(/=)@ method, we normally just use the default method. + + If the type is an enumeration type, we could/may/should? generate + special code that calls @con2tag_Foo@, much like for @(==)@ shown + above. + +\item + We thought about doing this: If we're also deriving @Ord@ for this + tycon, we generate: +\begin{verbatim} +instance ... Eq (Foo ...) where + (==) a b = case (tagCmp a b) of { _LT -> False; _EQ -> True ; _GT -> False} + (/=) a b = case (tagCmp a b) of { _LT -> True ; _EQ -> False; _GT -> True } +\begin{verbatim} + However, that requires that \tr{Ord } was put in the context + for the instance decl, which it probably wasn't, so the decls + produced don't get through the typechecker. +\end{itemize} + +\begin{code} +gen_Eq_binds :: TyCon -> ProtoNameMonoBinds + +gen_Eq_binds tycon + = case (partition isNullaryDataCon (getTyConDataCons tycon)) + of { (nullary_cons, nonnullary_cons) -> + let + rest + = if null nullary_cons then + case maybeSingleConstructorTyCon tycon of + Just _ -> [] + Nothing -> -- if cons don't match, then False + [([a_Pat, b_Pat], false_Expr)] + else -- calc. and compare the tags + [([a_Pat, b_Pat], + untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)] + (cmp_tags_Expr eqH_PN ah_PN bh_PN true_Expr false_Expr))] + in + mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest) + `AndMonoBinds` boring_ne_method + } + where + ------------------------------------------------------------------ + pats_etc data_con + = let + con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) + 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 + (_,_, arg_tys, _) -> arg_tys + in + ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) + where + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr [ty] [a] [b] = eq_Expr ty (Var a) (Var b) + nested_eq_expr (t:ts) (a:as) (b:bs) + = let + rest_expr = nested_eq_expr ts as bs + in + and_Expr (eq_Expr t (Var a) (Var b)) rest_expr + +boring_ne_method + = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] ( + App (Var not_PN) (App (App (Var eq_PN) a_Expr) b_Expr) + ) +\end{code} + +%************************************************************************ +%* * +\subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations} +%* * +%************************************************************************ + +For a derived @Ord@, we concentrate our attentions on the non-standard +@_tagCmp@ method, which type: +\begin{verbatim} +_tagCmp :: a -> a -> _CMP_TAG + +-- and the builtin tag type is: + +data _CMP_TAG = _LT | _EQ | _GT deriving () +\end{verbatim} + +(All this @_tagCmp@ stuff is due to the sterling analysis by Julian +Seward.) + +We will use the same example data type as above: +\begin{verbatim} +data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... +\end{verbatim} + +\begin{itemize} +\item + We do all the other @Ord@ methods with calls to @_tagCmp@: +\begin{verbatim} +instance ... (Ord ) where + a < b = case _tagCmp a b of { _LT -> True; _EQ -> False; _GT -> False } + a <= b = case _tagCmp a b of { _LT -> True; _EQ -> True; _GT -> False } + a >= b = case _tagCmp a b of { _LT -> False; _EQ -> True; _GT -> True } + a > b = case _tagCmp a b of { _LT -> False; _EQ -> False; _GT -> True } + + max a b = case _tagCmp a b of { _LT -> b; _EQ -> a; _GT -> a } + min a b = case _tagCmp a b of { _LT -> a; _EQ -> a; _GT -> b } + + -- _tagCmp to come... +\end{verbatim} + +\item + @_tagCmp@ always has two parts. First, we use the compared + data-constructors' tags to deal with the case of different + constructors: +\begin{verbatim} +_tagCmp a b = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + case (a# ==# b#) of { + True -> cmp_eq a b + False -> case (a# <# b#) of + True -> _LT + False -> _GT + }}} + where + cmp_eq = ... to come ... +\end{verbatim} + +\item + We are only left with the ``help'' function @cmp_eq@, to deal with + comparing data constructors with the same tag. + + For the ordinary constructors (if any), we emit the sorta-obvious + tagCmp-style stuff; for our example: +\begin{verbatim} +cmp_eq (O1 a1 b1) (O1 a2 b2) + = case (_tagCmp a1 a2) of { _LT -> _LT; _EQ -> _tagCmp b1 b2; _GT -> _GT } + +cmp_eq (O2 a1) (O2 a2) + = _tagCmp a1 a2 + +cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2) + = case (_tagCmp a1 a2) of { + _LT -> _LT; + _GT -> _GT; + _EQ -> case _tagCmp b1 b2 of { + _LT -> _LT; + _GT -> _GT; + _EQ -> _tagCmp c1 c2 + } + } +\end{verbatim} + + Again, we must be careful about unboxed comparisons. For example, + if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to + generate: +\begin{verbatim} +cmp_eq lt eq gt (O2 a1) (O2 a2) + = tagCmpInt# a1 a2 + -- or maybe the unfolded equivalent +\end{verbatim} + +\item + For the remaining nullary constructors, we already know that the + tags are equal so: +\begin{verbatim} +cmp_eq _ _ = _EQ +\end{verbatim} +\end{itemize} + +\begin{code} +gen_Ord_binds :: TyCon -> ProtoNameMonoBinds + +gen_Ord_binds tycon + = defaulted `AndMonoBinds` tagCmp + where + -------------------------------------------------------------------- + tagCmp = mk_easy_FunMonoBind tagCmp_PN + [a_Pat, b_Pat] + [cmp_eq] + (if maybeToBool (maybeSingleConstructorTyCon tycon) then + cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr + else + untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] + (cmp_tags_Expr eqH_PN ah_PN bh_PN + -- True case; they are equal + -- If an enumeration type we are done; else + -- recursively compare their components + (if isEnumerationTyCon tycon then + eq_TAG_Expr + else + cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr + ) + -- False case; they aren't equal + -- So we need to do a less-than comparison on the tags + (cmp_tags_Expr ltH_PN ah_PN bh_PN lt_TAG_Expr gt_TAG_Expr))) + + (nullary_cons, nonnullary_cons) + = partition isNullaryDataCon (getTyConDataCons tycon) + + cmp_eq + = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc) + where + pats_etc data_con + = ([con1_pat, con2_pat], + nested_tagCmp_expr tys_needed as_needed bs_needed) + where + con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) + 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 + (_,_, arg_tys, _) -> arg_tys + + nested_tagCmp_expr [ty] [a] [b] + = careful_tagCmp_Case ty lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr (Var a) (Var b) + + nested_tagCmp_expr (ty:tys) (a:as) (b:bs) + = let eq_expr = nested_tagCmp_expr tys as bs + in careful_tagCmp_Case ty lt_TAG_Expr eq_expr gt_TAG_Expr (Var a) (Var b) + + deflt_pats_etc + = if null nullary_cons + then [] + else [([a_Pat, b_Pat], eq_TAG_Expr)] + -------------------------------------------------------------------- + +defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] + +lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] ( + tagCmp_Case true_Expr false_Expr false_Expr a_Expr b_Expr) +le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] ( + tagCmp_Case true_Expr true_Expr false_Expr a_Expr b_Expr) +ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] ( + tagCmp_Case false_Expr true_Expr true_Expr a_Expr b_Expr) +gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] ( + tagCmp_Case false_Expr false_Expr true_Expr a_Expr b_Expr) + +max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] ( + tagCmp_Case b_Expr a_Expr a_Expr a_Expr b_Expr) +min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] ( + tagCmp_Case a_Expr a_Expr b_Expr a_Expr b_Expr) +\end{code} + +%************************************************************************ +%* * +\subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations} +%* * +%************************************************************************ + +@Enum@ can only be derived for enumeration types. For a type +\begin{verbatim} +data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} + +we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a +@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@). + +\begin{verbatim} +instance ... Enum (Foo ...) where + enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] + + -- or, really... + enumFrom a + = case con2tag_Foo a of + a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo) + + enumFromThen a b + = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo] + + -- or, really... + enumFromThen a b + = case con2tag_Foo a of { a# -> + case con2tag_Foo b of { b# -> + map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo) + }} +\end{verbatim} + +For @enumFromTo@ and @enumFromThenTo@, we use the default methods. + +\begin{code} +gen_Enum_binds :: TyCon -> ProtoNameMonoBinds + +gen_Enum_binds tycon + = enum_from `AndMonoBinds` enum_from_then + where + enum_from + = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] ( + untag_Expr tycon [(a_PN, ah_PN)] ( + App (App (Var map_PN) (Var (tag2con_PN tycon))) ( + enum_from_to_Expr + (App (Var mkInt_PN) (Var ah_PN)) + (Var (maxtag_PN tycon))))) + + enum_from_then + = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] ( + untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] ( + App (App (Var map_PN) (Var (tag2con_PN tycon))) ( + enum_from_then_to_Expr + (App (Var mkInt_PN) (Var ah_PN)) + (App (Var mkInt_PN) (Var bh_PN)) + (Var (maxtag_PN tycon))))) +\end{code} + +%************************************************************************ +%* * +\subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations} +%* * +%************************************************************************ + +Deriving @Ix@ is only possible for enumeration types and +single-constructor types. We deal with them in turn. + +For an enumeration type, e.g., +\begin{verbatim} + data Foo ... = N1 | N2 | ... | Nn +\end{verbatim} +things go not too differently from @Enum@: +\begin{verbatim} +instance ... Ix (Foo ...) where + range (a, b) + = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b] + + -- or, really... + range (a, b) + = case (con2tag_Foo a) of { a# -> + case (con2tag_Foo b) of { b# -> + map tag2con_Foo (enumFromTo (I# a#) (I# b#)) + }} + + index c@(a, b) d + = if inRange c d + then case (con2tag_Foo d -# con2tag_Foo a) of + r# -> I# r# + else error "Ix.Foo.index: out of range" + + inRange (a, b) c + = let + p_tag = con2tag_Foo c + in + p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b + + -- or, really... + inRange (a, b) c + = case (con2tag_Foo a) of { a_tag -> + case (con2tag_Foo b) of { b_tag -> + case (con2tag_Foo c) of { c_tag -> + if (c_tag >=# a_tag) then + c_tag <=# b_tag + else + False + }}} +\end{verbatim} +(modulo suitable case-ification to handle the unboxed tags) + +For a single-constructor type (NB: this includes all tuples), e.g., +\begin{verbatim} + data Foo ... = MkFoo a b Int Double c c +\end{verbatim} +we follow the scheme given in Figure~19 of the Haskell~1.2 report +(p.~147). + +\begin{code} +gen_Ix_binds :: TyCon -> ProtoNameMonoBinds + +gen_Ix_binds tycon + = if isEnumerationTyCon tycon + then enum_ixes + else single_con_ixes + where + tycon_str = _UNPK_ (snd (getOrigName tycon)) + + -------------------------------------------------------------- + enum_ixes = enum_range `AndMonoBinds` + enum_index `AndMonoBinds` enum_inRange + + enum_range + = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] ( + untag_Expr tycon [(a_PN, ah_PN)] ( + untag_Expr tycon [(b_PN, bh_PN)] ( + App (App (Var map_PN) (Var (tag2con_PN tycon))) ( + enum_from_to_Expr + (App (Var mkInt_PN) (Var ah_PN)) + (App (Var mkInt_PN) (Var bh_PN)) + )))) + + enum_index + = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] ( + If (App (App (Var inRange_PN) c_Expr) d_Expr) ( + untag_Expr tycon [(a_PN, ah_PN)] ( + untag_Expr tycon [(d_PN, dh_PN)] ( + let + grhs = [OtherwiseGRHS (App (Var mkInt_PN) (Var c_PN)) mkGeneratedSrcLoc] + in + Case (OpApp (Var dh_PN) (Var minusH_PN) (Var ah_PN)) {-of-} + [PatMatch (VarPatIn c_PN) + (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] + )) + ) {-else-} ( + App (Var error_PN) (Lit (StringLit (_PK_ ("Ix."++tycon_str++".index: out of range\n")))) + ) + ) + + enum_inRange + = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] ( + untag_Expr tycon [(a_PN, ah_PN)] ( + untag_Expr tycon [(b_PN, bh_PN)] ( + untag_Expr tycon [(c_PN, ch_PN)] ( + If (OpApp (Var ch_PN) (Var geH_PN) (Var ah_PN)) ( + (OpApp (Var ch_PN) (Var leH_PN) (Var bh_PN)) + ) {-else-} ( + false_Expr + ))))) + + -------------------------------------------------------------- + single_con_ixes = single_con_range `AndMonoBinds` + single_con_index `AndMonoBinds` single_con_inRange + + data_con + = case maybeSingleConstructorTyCon tycon of -- just checking... + Nothing -> panic "get_Ix_binds" + Just dc -> let + (_, _, arg_tys, _) = getDataConSig 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 + data_con_PN = Prel (WiredInVal data_con) + con_pat xs = ConPatIn data_con_PN (map VarPatIn xs) + con_expr xs = foldl App (Var data_con_PN) (map Var xs) + + as_needed = take (getDataConArity data_con) as_PNs + bs_needed = take (getDataConArity data_con) bs_PNs + cs_needed = take (getDataConArity data_con) cs_PNs + + -------------------------------------------------------------- + single_con_range + = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] ( + ListComp (con_expr cs_needed) (zipWith3 mk_qual as_needed bs_needed cs_needed) + ) + where + mk_qual a b c = GeneratorQual (VarPatIn c) + (App (Var range_PN) (ExplicitTuple [Var a, Var b])) + + ---------------- + single_con_index + = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] ( + foldl mk_index (Lit (IntLit 0)) (zip3 as_needed bs_needed cs_needed)) + where + mk_index multiply_by (l, u, i) + =OpApp ( + (App (App (Var index_PN) (ExplicitTuple [Var l, Var u])) (Var i)) + ) (Var plus_PN) ( + OpApp ( + (App (Var rangeSize_PN) (ExplicitTuple [Var l, Var u])) + ) (Var times_PN) multiply_by + ) + + range_size + = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] ( + OpApp ( + (App (App (Var index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr) + ) (Var plus_PN) (Lit (IntLit 1))) + + ------------------ + single_con_inRange + = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] ( + foldl1 and_Expr (zipWith3 in_range as_needed bs_needed cs_needed)) + where + in_range a b c = App (App (Var inRange_PN) (ExplicitTuple [Var a, Var b])) (Var c) +\end{code} + +%************************************************************************ +%* * +\subsubsection[TcGenDeriv-Text]{Generating @Text@ instance declarations} +%* * +%************************************************************************ + +Deriving @Text@ is a pain. @show@ is commonly used; @read@ is rarely +used---but we're supposed to generate massive amounts of code for it +anyway. We provide a command-line flag to say ``Don't bother'' +(@OmitDerivedRead@). + +We just use the default methods for @showList@ and @readList@. + +Also: ignoring all the infix-ery mumbo jumbo (ToDo) + +The part of the Haskell report that deals with this (pages~147--151, +1.2~version) is an adequate guide to what needs to be done. Note that +this is where we may (eventually) use the fixity info that's been +passed around. + +\begin{code} +gen_Text_binds :: [RenamedFixityDecl] -> Bool -> TyCon -> ProtoNameMonoBinds + +gen_Text_binds fixities omit_derived_read tycon + = if omit_derived_read + then shows_prec + else shows_prec `AndMonoBinds` reads_prec + where + ----------------------------------------------------------------------- + shows_prec + = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon)) + where + pats_etc data_con + = let + data_con_PN = Prel (WiredInVal data_con) + bs_needed = take (getDataConArity data_con) bs_PNs + con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) + + show_con + = let (mod, nm) = getOrigName data_con + space_maybe = if isNullaryDataCon data_con then _NIL_ else SLIT(" ") + in + App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe))) + + show_thingies = show_con : (spacified real_show_thingies) + + real_show_thingies + = [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b) + | b <- bs_needed ] + in + ([a_Pat, con_pat], + showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10))) + (nested_compose_Expr show_thingies)) + where + spacified [] = [] + spacified [x] = [x] + spacified (x:xs) = (x : (Var showSpace_PN) : spacified xs) + + ----------------------------------------------------------------------- + reads_prec -- ignore the infix game altogether + = let + read_con_comprehensions + = map read_con (getTyConDataCons tycon) + in + mk_easy_FunMonoBind readsPrec_PN [a_Pat] [] ( + readParen_Expr (OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))) ( + Lam (mk_easy_Match [b_Pat] [] ( + foldl1 append_Expr read_con_comprehensions + )))) + where + read_con data_con -- note: "b" is the string being "read" + = 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 + con_expr = foldl App (Var data_con_PN) (map Var as_needed) + + con_qual + = GeneratorQual + (TuplePatIn [LitPatIn (StringLit data_con_str), c_Pat]) + (App (Var lex_PN) b_Expr) + + field_quals = snd (mapAccumL mk_qual c_Expr (as_needed `zip` bs_needed)) + in + ListComp (ExplicitTuple [con_expr, + if null bs_needed then c_Expr else Var (last bs_needed)]) + (con_qual : field_quals) + where + mk_qual draw_from (con_field, str_left) + = (Var str_left, -- what to draw from down the line... + GeneratorQual + (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) + (App (App (Var readsPrec_PN) (Lit (IntLit 10))) draw_from)) +\end{code} + +%************************************************************************ +%* * +\subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations} +%* * +%************************************************************************ + +ToDo: NOT DONE YET. + +\begin{code} +gen_Binary_binds :: TyCon -> ProtoNameMonoBinds + +gen_Binary_binds tycon + = panic "gen_Binary_binds" +\end{code} + +%************************************************************************ +%* * +\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)} +%* * +%************************************************************************ + +\begin{verbatim} +data Foo ... = ... + +con2tag_Foo :: Foo ... -> Int# +tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# +maxtag_Foo :: Int -- ditto (NB: not unboxed) +\end{verbatim} + +The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) +fiddling around. + +\begin{code} +gen_tag_n_con_monobind + :: (ProtoName, Name, -- (proto)Name for the thing in question + TyCon, -- tycon in question + TagThingWanted) + -> ProtoNameMonoBinds + +gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag) + = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon)) + where + mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr) + + mk_stuff var + = ASSERT(isDataCon var) + ([pat], Lit (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))) + where + pat = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn) + var_PN = Prel (WiredInVal var) + +gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con) + = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon)) + where + mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr) + + mk_stuff var + = ASSERT(isDataCon var) + ([lit_pat], Var var_PN) + where + lit_pat = ConPatIn mkInt_PN [LitPatIn (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))] + var_PN = Prel (WiredInVal var) + +gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag) + = mk_easy_FunMonoBind pn [] [] (App (Var mkInt_PN) (Lit (IntPrimLit max_tag))) + where + max_tag = case (getTyConDataCons tycon) of + data_cons -> toInteger ((length data_cons) - fIRST_TAG) +\end{code} + +%************************************************************************ +%* * +\subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings} +%* * +%************************************************************************ + +@mk_easy_FunMonoBind fun pats binds expr@ generates: +\begin{verbatim} + fun pat1 pat2 ... patN = expr where binds +\end{verbatim} + +@mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for +multi-clause definitions; it generates: +\begin{verbatim} + fun p1a p1b ... p1N = e1 + fun p2a p2b ... p2N = e2 + ... + fun pMa pMb ... pMN = eM +\end{verbatim} + +\begin{code} +mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat] + -> [ProtoNameMonoBinds] -> ProtoNameExpr + -> ProtoNameMonoBinds + +mk_easy_FunMonoBind fun pats binds expr + = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc + +mk_easy_Match pats binds expr + = foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds))) + pats + where + mkbind [] = EmptyBinds + mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs)) + -- The renamer expects everything in its input to be a + -- "recursive" MonoBinds, and it is its job to sort things out + -- from there. + +mk_FunMonoBind :: ProtoName + -> [([ProtoNamePat], ProtoNameExpr)] + -> ProtoNameMonoBinds + +mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind" +mk_FunMonoBind fun pats_and_exprs + = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc + where + mk_match (pats, expr) + = foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds)) + pats +\end{code} + +\begin{code} +tagCmp_Case, cmp_eq_Expr :: + ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr +tagCmp_gen_Case :: + ProtoName + -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr +careful_tagCmp_Case :: -- checks for primitive types... + UniType + -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr + +tagCmp_Case = tagCmp_gen_Case tagCmp_PN +cmp_eq_Expr = tagCmp_gen_Case cmp_eq_PN + +tagCmp_gen_Case fun lt eq gt a b + = Case (App (App (Var fun) a) b) {-of-} + [PatMatch (ConPatIn lt_TAG_PN []) + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)), + + PatMatch (ConPatIn eq_TAG_PN []) + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)), + + PatMatch (ConPatIn gt_TAG_PN []) + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))] + +careful_tagCmp_Case ty lt eq gt a b + = if not (isPrimType ty) then + tagCmp_gen_Case tagCmp_PN lt eq gt a b + + else -- we have to do something special for primitive things... + If (OpApp a (Var relevant_eq_op) b) + eq + (If (OpApp a (Var relevant_lt_op) b) lt gt) + where + relevant_eq_op = assoc "careful_tagCmp_Case" eq_op_tbl ty + relevant_lt_op = assoc "careful_tagCmp_Case" lt_op_tbl ty + +eq_op_tbl = [ + (charPrimTy, Prel (WiredInVal (primOpId CharEqOp))), + (intPrimTy, Prel (WiredInVal (primOpId IntEqOp))), + (wordPrimTy, Prel (WiredInVal (primOpId WordEqOp))), + (addrPrimTy, Prel (WiredInVal (primOpId AddrEqOp))), + (floatPrimTy, Prel (WiredInVal (primOpId FloatEqOp))), + (doublePrimTy, Prel (WiredInVal (primOpId DoubleEqOp))) ] + +lt_op_tbl = [ + (charPrimTy, Prel (WiredInVal (primOpId CharLtOp))), + (intPrimTy, Prel (WiredInVal (primOpId IntLtOp))), + (wordPrimTy, Prel (WiredInVal (primOpId WordLtOp))), + (addrPrimTy, Prel (WiredInVal (primOpId AddrLtOp))), + (floatPrimTy, Prel (WiredInVal (primOpId FloatLtOp))), + (doublePrimTy, Prel (WiredInVal (primOpId DoubleLtOp))) ] + +----------------------------------------------------------------------- + +and_Expr, append_Expr :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr + +and_Expr a b = OpApp a (Var and_PN) b +append_Expr a b = OpApp a (Var append_PN) b + +----------------------------------------------------------------------- + +eq_Expr :: UniType -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr +eq_Expr ty a b + = if not (isPrimType ty) then + OpApp a (Var eq_PN) b + else -- we have to do something special for primitive things... + OpApp a (Var relevant_eq_op) b + where + relevant_eq_op = assoc "eq_Expr" eq_op_tbl ty +\end{code} + +\begin{code} +untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameExpr -> ProtoNameExpr +untag_Expr tycon [] expr = expr +untag_Expr tycon ((untag_this, put_tag_here) : more) expr + = Case (App (con2tag_Expr tycon) (Var untag_this)) {-of-} + [PatMatch (VarPatIn put_tag_here) + (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] + where + grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc] + +cmp_tags_Expr :: ProtoName -- Comparison op + -> ProtoName -> ProtoName -- Things to compare + -> ProtoNameExpr -- What to return if true + -> ProtoNameExpr -- What to return if false + -> ProtoNameExpr + +cmp_tags_Expr op a b true_case false_case + = If (OpApp (Var a) (Var op) (Var b)) true_case false_case + +enum_from_to_Expr + :: ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr +enum_from_then_to_Expr + :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr + +enum_from_to_Expr f t2 = App (App (Var enumFromTo_PN) f) t2 +enum_from_then_to_Expr f t t2 = App (App (App (Var enumFromThenTo_PN) f) t) t2 + +showParen_Expr, readParen_Expr + :: ProtoNameExpr -> ProtoNameExpr + -> ProtoNameExpr + +showParen_Expr e1 e2 = App (App (Var showParen_PN) e1) e2 +readParen_Expr e1 e2 = App (App (Var readParen_PN) e1) e2 + +nested_compose_Expr :: [ProtoNameExpr] -> ProtoNameExpr + +nested_compose_Expr [e] = e +nested_compose_Expr (e:es) + = App (App (Var compose_PN) e) (nested_compose_Expr es) +\end{code} + +\begin{code} +a_PN = Unk SLIT("a") +b_PN = Unk SLIT("b") +c_PN = Unk SLIT("c") +d_PN = Unk SLIT("d") +ah_PN = Unk SLIT("a#") +bh_PN = Unk SLIT("b#") +ch_PN = Unk SLIT("c#") +dh_PN = Unk SLIT("d#") +cmp_eq_PN = Unk SLIT("cmp_eq") +rangeSize_PN = Unk SLIT("rangeSize") + +as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] + +eq_PN = prelude_method SLIT("Eq") SLIT("==") +ne_PN = prelude_method SLIT("Eq") SLIT("/=") +le_PN = prelude_method SLIT("Ord") SLIT("<=") +lt_PN = prelude_method SLIT("Ord") SLIT("<") +ge_PN = prelude_method SLIT("Ord") SLIT(">=") +gt_PN = prelude_method SLIT("Ord") SLIT(">") +max_PN = prelude_method SLIT("Ord") SLIT("max") +min_PN = prelude_method SLIT("Ord") SLIT("min") +tagCmp_PN = prelude_method SLIT("Ord") SLIT("_tagCmp") +lt_TAG_PN = Prel (WiredInVal ltPrimDataCon) +eq_TAG_PN = Prel (WiredInVal eqPrimDataCon) +gt_TAG_PN = Prel (WiredInVal gtPrimDataCon) +enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom") +enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo") +enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen") +enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo") +range_PN = prelude_method SLIT("Ix") SLIT("range") +index_PN = prelude_method SLIT("Ix") SLIT("index") +inRange_PN = prelude_method SLIT("Ix") SLIT("inRange") +readsPrec_PN = prelude_method SLIT("Text") SLIT("readsPrec") +showsPrec_PN = prelude_method SLIT("Text") SLIT("showsPrec") +plus_PN = prelude_method SLIT("Num") SLIT("+") +times_PN = prelude_method SLIT("Num") SLIT("*") + +false_PN = Prel (WiredInVal falseDataCon) +true_PN = Prel (WiredInVal trueDataCon) +eqH_PN = Prel (WiredInVal (primOpId IntEqOp)) +geH_PN = Prel (WiredInVal (primOpId IntGeOp)) +leH_PN = Prel (WiredInVal (primOpId IntLeOp)) +ltH_PN = Prel (WiredInVal (primOpId IntLtOp)) +minusH_PN = Prel (WiredInVal (primOpId IntSubOp)) +and_PN = prelude_val pRELUDE SLIT("&&") +not_PN = prelude_val pRELUDE SLIT("not") +append_PN = prelude_val pRELUDE_LIST SLIT("++") +map_PN = prelude_val pRELUDE_LIST SLIT("map") +compose_PN = prelude_val pRELUDE SLIT(".") +mkInt_PN = Prel (WiredInVal intDataCon) +error_PN = Prel (WiredInVal eRROR_ID) +showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std +showString_PN = prelude_val pRELUDE_TEXT SLIT("showString") +showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen") +readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen") +lex_PN = prelude_val pRELUDE_TEXT SLIT("lex") + +prelude_val m s = Imp m s [m] s +prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used... + +a_Expr = Var a_PN +b_Expr = Var b_PN +c_Expr = Var c_PN +d_Expr = Var d_PN +lt_TAG_Expr = Var lt_TAG_PN +eq_TAG_Expr = Var eq_TAG_PN +gt_TAG_Expr = Var gt_TAG_PN +false_Expr = Var false_PN +true_Expr = Var true_PN + +con2tag_Expr tycon = Var (con2tag_PN tycon) + +a_Pat = VarPatIn a_PN +b_Pat = VarPatIn b_PN +c_Pat = VarPatIn c_PN +d_Pat = VarPatIn d_PN +\end{code} + +%************************************************************************ +%* * +\subsection[TcGenDeriv-misc-utils]{Miscellaneous utility bits for deriving} +%* * +%************************************************************************ + +\begin{code} +{- UNUSED: +hasCon2TagFun :: TyCon -> Bool +hasCon2TagFun tycon + = preludeClassDerivedFor ordClassKey tycon + || isEnumerationTyConMostly tycon + +hasTag2ConFun :: TyCon -> Bool +hasTag2ConFun tycon + = isEnumerationTyCon tycon + && (preludeClassDerivedFor ixClassKey tycon + || preludeClassDerivedFor enumClassKey tycon) +-} +\end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.hi b/ghc/compiler/typecheck/TcIfaceSig.hi new file mode 100644 index 0000000..5bd2564 --- /dev/null +++ b/ghc/compiler/typecheck/TcIfaceSig.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcIfaceSig where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsBinds(Sig) +import Id(Id) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +tcInterfaceSigs :: E -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)] + {-# GHC_PRAGMA _A_ 6 _U_ 212122 _N_ _S_ "LSLLLL" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs new file mode 100644 index 0000000..a8cea95 --- /dev/null +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -0,0 +1,77 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[TcIfaceSig]{Type checking of type signatures in interface files} + +\begin{code} +#include "HsVersions.h" + +module TcIfaceSig ( tcInterfaceSigs ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import TcMonad -- typechecking monadic machinery +import AbsSyn -- the stuff being typechecked + +import AbsUniType ( splitType, splitTyArgs ) +import CmdLineOpts ( GlobalSwitch(..) ) +import E ( getE_CE, getE_TCE, nullGVE, unitGVE, + plusGVE, GVE(..), E, CE(..), TCE(..), UniqFM + ) +import Errors ( confusedNameErr ) +import Id -- mkImported +#if USE_ATTACK_PRAGMAS +import IdInfo ( workerExists ) +#endif +import Maybes ( Maybe(..) ) +import TcPragmas ( tcGenPragmas ) +import TVE ( nullTVE, TVE(..) ) +import TcPolyType ( tcPolyType ) +import UniqFM ( emptyUFM ) -- profiling, pragmas only +import Util +\end{code} + +Ultimately, type signatures in interfaces will have pragmatic +information attached, so it is a good idea to have separate code to +check them. + +As always, we do not have to worry about user-pragmas in interface +signatures. + +\begin{code} +tcInterfaceSigs :: E -> [RenamedSig] -> Baby_TcM GVE + +tcInterfaceSigs e [] = returnB_Tc nullGVE + +tcInterfaceSigs e (sig:sigs) + = tc_sig sig `thenB_Tc` \ gve1 -> + tcInterfaceSigs e sigs `thenB_Tc` \ gve2 -> + returnB_Tc (plusGVE gve1 gve2) + where + ce = getE_CE e + tce = getE_TCE e + + tc_sig (Sig name@(OtherTopId uniq full_name) ty pragmas src_loc) + = addSrcLocB_Tc src_loc ( + tcPolyType ce tce nullTVE ty `thenB_Tc` \ sigma_ty -> + + fixB_Tc ( \ rec_imported_id -> + tcGenPragmas e (Just sigma_ty) rec_imported_id pragmas + `thenB_Tc` \ id_info -> + + returnB_Tc (mkImported uniq full_name sigma_ty id_info) + ) `thenB_Tc` \ final_id -> + + returnB_Tc (unitGVE name final_id) + ) + + tc_sig (Sig odd_name _ _ src_loc) + = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr -> + case odd_name of + WiredInVal _ | sw_chkr CompilingPrelude -- OK, that's cool; ignore + -> returnB_Tc nullGVE + _ -> failB_Tc (confusedNameErr "Bad name on a type signature (a Prelude name?)" + odd_name src_loc) +\end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.hi b/ghc/compiler/typecheck/TcInstDcls.hi new file mode 100644 index 0000000..60a805e --- /dev/null +++ b/ghc/compiler/typecheck/TcInstDcls.hi @@ -0,0 +1,41 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcInstDcls where +import Bag(Bag) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsBinds(Binds, MonoBinds, Sig) +import HsDecls(InstDecl, SpecialisedInstanceSig) +import HsExpr(Expr) +import HsPat(InPat, TypecheckedPat) +import HsPragmas(InstancePragmas) +import Id(Id) +import IdInfo(SpecEnv) +import Inst(Inst) +import InstEnv(InstTemplate) +import LIE(LIE) +import Name(Name) +import PreludePS(_PackedString) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +data InstInfo = InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] +buildInstanceEnvs :: Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-} +mkInstanceRelatedIds :: E -> Bool -> InstancePragmas Name -> a -> Class -> [TyVarTemplate] -> UniType -> [(Class, UniType)] -> [Sig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Id, [(Class, UniType)], [Id]) + {-# GHC_PRAGMA _A_ 15 _U_ 222022221222122 _N_ _S_ "LLSALSLLLLLLU(ALS)LL" {_A_ 14 _U_ 22222221222122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +processInstBinds :: E -> [TyVar] -> (Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Expr Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [TyVar] -> [Inst] -> [Id] -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], MonoBinds Id TypecheckedPat) + {-# GHC_PRAGMA _A_ 7 _U_ 2222222222122 _N_ _S_ "LLLLLLS" _N_ _N_ #-} +tcInstDecls1 :: E -> UniqFM Class -> UniqFM TyCon -> [InstDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Bag InstInfo, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2221222222 _N_ _S_ "LLLS" _N_ _N_ #-} +tcInstDecls2 :: E -> Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +tcSpecInstSigs :: E -> UniqFM Class -> UniqFM TyCon -> Bag InstInfo -> [SpecialisedInstanceSig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo) + {-# GHC_PRAGMA _A_ 5 _U_ 22222222222 _N_ _S_ "LLLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs new file mode 100644 index 0000000..df2bbd4 --- /dev/null +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -0,0 +1,1079 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcInstDecls]{Typechecking instance declarations} + +\begin{code} +#include "HsVersions.h" + +module TcInstDcls ( + tcInstDecls1, tcInstDecls2, + tcSpecInstSigs, + buildInstanceEnvs, processInstBinds, + mkInstanceRelatedIds, + InstInfo(..) + ) where + +IMPORT_Trace -- ToDo:rm debugging +import Outputable +import Pretty + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( newDicts, newMethod, newLocalWithGivenTy, + newClassOpLocals, copyTyVars, + applyTcSubstAndCollectTyVars + ) +import AbsSyn -- the stuff being typechecked + +import AbsUniType +import BackSubst ( applyTcSubstToBinds ) +import Bag ( emptyBag, unitBag, unionBags, bagToList ) +import CE ( lookupCE, CE(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import GenSpecEtc ( checkSigTyVars ) +import E ( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E ) +import Errors ( dupInstErr, derivingWhenInstanceExistsErr, + preludeInstanceErr, nonBoxedPrimCCallErr, + specInstUnspecInstNotFoundErr, + Error(..), UnifyErrContext(..) + ) +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Id -- lots of things +import IdInfo -- ditto +import Inst ( Inst, InstOrigin(..) ) +import InstEnv +import Maybes ( catMaybes, mkLookupFun, maybeToBool, Maybe(..) ) +import Name ( getTagFromClassOpName ) +import NameTypes ( fromPrelude ) +import LIE ( nullLIE, mkLIE, unMkLIE, plusLIE, LIE ) +import ListSetOps ( minusList ) +import TCE ( TCE(..), UniqFM ) +import TVE ( mkTVE, TVE(..) ) +import Spec ( specTy ) +import TcContext ( tcContext ) +import TcGRHSs ( tcGRHSsAndBinds ) +import TcMatches ( tcMatchesFun ) +import TcMonoType ( tcInstanceType ) +import TcPragmas ( tcDictFunPragmas, tcGenPragmas ) +import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas ) +import Unify ( unifyTauTy ) +import Unique ( cCallableClassKey, cReturnableClassKey ) +import Util +\end{code} + +Typechecking instance declarations is done in two passes. The first +pass, made by @tcInstDecls1@, +collects information to be used in the second pass. + +This pre-processed info includes the as-yet-unprocessed bindings +inside the instance declaration. These are type-checked in the second +pass, when the class-instance envs and GVE contain all the info from +all the instance and value decls. Indeed that's the reason we need +two passes over the instance decls. + + instance c => k (t tvs) where b + +\begin{code} +data InstInfo + = InstInfo + Class -- Class, k + [TyVarTemplate] -- Type variables, tvs + UniType -- The type at which the class is being + -- instantiated + ThetaType -- inst_decl_theta: the original context from the + -- instance declaration. It constrains (some of) + -- the TyVarTemplates above + ThetaType -- dfun_theta: the inst_decl_theta, plus one + -- element for each superclass; the "Mark + -- Jones optimisation" + Id -- The dfun id + [Id] -- Constant methods (either all or none) + RenamedMonoBinds -- Bindings, b + Bool -- True <=> local instance decl + FAST_STRING -- Name of module where this instance was + -- defined. + SrcLoc -- Source location assoc'd with this instance's defn + [RenamedSig] -- User pragmas recorded for generating specilaised instances +\end{code} + + +Here is the overall algorithm. Assume that + +\begin{enumerate} +\item +$LIE_c$ is the LIE for the context of class $c$ +\item +$betas_bar$ is the free variables in the class method type, excluding the + class variable +\item +$LIE_cop$ is the LIE constraining a particular class method +\item +$tau_cop$ is the tau type of a class method +\item +$LIE_i$ is the LIE for the context of instance $i$ +\item +$X$ is the instance constructor tycon +\item +$gammas_bar$ is the set of type variables of the instance +\item +$LIE_iop$ is the LIE for a particular class method instance +\item +$tau_iop$ is the tau type for this instance of a class method +\item +$alpha$ is the class variable +\item +$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$ +\item +$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$ +\end{enumerate} + +ToDo: Update the list above with names actually in the code. + +\begin{enumerate} +\item +First, make the LIEs for the class and instance contexts, which means +instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC', +and make LIElistI and LIEI. +\item +Then process each method in turn. +\item +order the instance methods according to the ordering of the class methods +\item +express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error +\item +Create final dictionary function from bindings generated already +\begin{pseudocode} +df = lambda inst_tyvars + lambda LIEI + let Bop1 + Bop2 + ... + Bopn + and dbinds_super + in +\end{pseudocode} +Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn, +and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. +\end{enumerate} + +\begin{code} +tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo) + +tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag + +tcInstDecls1 e ce tce (inst_decl : rest) + = tc_inst_1 inst_decl `thenNF_Tc` \ infos1 -> + tcInstDecls1 e ce tce rest `thenNF_Tc` \ infos2 -> + returnNF_Tc (infos1 `unionBags` infos2) + where + tc_inst_1 (InstDecl context class_name ty binds from_here modname imod uprags pragmas src_loc) + = + -- Prime error recovery and substitution pruning + recoverTc emptyBag ( + addSrcLocTc src_loc ( + + let + clas = lookupCE ce class_name -- Renamer ensures this can't fail + + for_ccallable_or_creturnable + = class_name == cCallableClass || class_name == cReturnableClass + where + cCallableClass = PreludeClass cCallableClassKey bottom + cReturnableClass = PreludeClass cReturnableClassKey bottom + bottom = panic "for_ccallable_etc" + + -- Make some new type variables, named as in the instance type + ty_names = extractMonoTyNames (==) ty + (tve,inst_tyvars,_) = mkTVE ty_names + in + -- Check the instance type, including its syntactic constraints + babyTcMtoTcM (tcInstanceType ce tce tve from_here src_loc ty) + `thenTc` \ inst_ty -> + + -- DEAL WITH THE INSTANCE CONTEXT + babyTcMtoTcM (tcContext ce tce tve context) `thenTc` \ theta -> + + -- SOME BORING AND TURGID CHECKING: + let + inst_for_function_type = isFunType inst_ty + -- sigh; it happens; must avoid tickling inst_tycon + + inst_tycon_maybe = getUniDataTyCon_maybe inst_ty + + inst_tycon = case inst_tycon_maybe of + Just (xx,_,_) -> xx + Nothing -> panic "tcInstDecls1:inst_tycon" + in + ------------------------------------------------------------- + -- It is illegal for a normal user's module to declare an + -- instance for a Prelude-class/Prelude-type instance: + checkTc (from_here -- really an inst decl in this module + && fromPreludeCore clas -- prelude class + && (inst_for_function_type -- prelude type + || fromPreludeCore inst_tycon) + && not (fromPrelude modname) -- we aren't compiling a Prelude mod + ) + (preludeInstanceErr clas inst_ty src_loc) `thenTc_` + + ------------------------------------------------------------- + -- It is obviously illegal to have an explicit instance + -- for something that we are also planning to `derive'. + -- Note that an instance decl coming in from outside + -- is probably just telling us about the derived instance + -- (ToDo: actually check, if possible), so we mustn't flag + -- it as an error. + checkTc (from_here + && not inst_for_function_type + && clas `derivedFor` inst_tycon) + (derivingWhenInstanceExistsErr clas inst_tycon) `thenTc_` + + ------------------------------------------------------------- + -- A user declaration of a _CCallable/_CReturnable instance + -- must be for a "boxed primitive" type. + getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> + checkTc (for_ccallable_or_creturnable + && from_here -- instance defined here + && not (sw_chkr CompilingPrelude) -- which allows anything + && (inst_for_function_type || -- a *function*??? hah! + not (maybeToBool (maybeBoxedPrimType inst_ty)))) -- naughty, naughty + (nonBoxedPrimCCallErr clas inst_ty src_loc) `thenTc_` + + -- END OF TURGIDITY; back to real fun + ------------------------------------------------------------- + + if (not inst_for_function_type && clas `derivedFor` inst_tycon) then + -- Don't use this InstDecl; tcDeriv will make the + -- InstInfo to be used in later processing. + returnTc emptyBag + + else + -- Make the dfun id and constant-method ids + mkInstanceRelatedIds e + from_here pragmas src_loc + clas inst_tyvars inst_ty theta uprags + `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + + returnTc ( unitBag ( + InstInfo clas inst_tyvars inst_ty theta + dfun_theta dfun_id const_meth_ids + binds from_here modname src_loc uprags + )) + )) +\end{code} + + +Common bit of code shared with @tcDeriving@: +\begin{code} +mkInstanceRelatedIds e + from_here inst_pragmas locn + clas + inst_tyvars inst_ty inst_decl_theta uprags + = getUniqueTc `thenNF_Tc` \ uniq -> + let + (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas + + super_class_theta = super_classes `zip` (repeat inst_ty) + + + dfun_theta = case inst_decl_theta of + + [] -> [] -- If inst_decl_theta is empty, then we don't + -- want to have any dict arguments, so that we can + -- expose the constant methods. + + other -> inst_decl_theta ++ super_class_theta + -- Otherwise we pass the superclass dictionaries to + -- the dictionary function; the Mark Jones optimisation. + + dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty) + in + fixNF_Tc ( \ rec_dfun_id -> + babyTcMtoNF_TcM ( + tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas + ) `thenNF_Tc` \ dfun_id_info -> + + returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here dfun_id_info) + ) `thenNF_Tc` \ dfun_id -> + + -- Make the constant-method ids, if there are no type variables involved + (if not (null inst_tyvars) -- ToDo: could also do this if theta is null... + then + returnNF_Tc [] + else + let + inline_mes = [ getTagFromClassOpName v | (InlineSig v _ _) <- uprags ] + + mk_const_meth op uniq + = mkConstMethodId + uniq + clas op inst_ty + meth_ty from_here info + where + is_elem = isIn "mkInstanceRelatedIds" + + info = if tag `is_elem` inline_mes + then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways) + else noIdInfo + + tenv = [(class_tyvar, inst_ty)] + tag = getClassOpTag op + op_ty = getClassOpLocalType op + meth_ty = instantiateTy tenv op_ty + -- If you move to a null-theta version, you need a + -- mkForallTy inst_tyvars here + + mk_constm_w_info (op, u, (name, prags)) -- ToDo: chk name? + = fixNF_Tc ( \ rec_constm_id -> + + babyTcMtoNF_TcM (tcGenPragmas e (Just meth_ty) rec_constm_id prags) + `thenNF_Tc` \ id_info -> + + returnNF_Tc (mkConstMethodId u clas op inst_ty meth_ty + from_here id_info) + ) + where + tenv = [(class_tyvar, inst_ty)] + op_ty = getClassOpLocalType op + meth_ty = instantiateTy tenv op_ty + + in + getUniquesTc (length class_ops) `thenNF_Tc` \ constm_uniqs -> + (case inst_pragmas of + ConstantInstancePragma _ name_pragma_pairs -> + mapNF_Tc mk_constm_w_info (zip3 class_ops constm_uniqs name_pragma_pairs) + + other_inst_pragmas -> + returnNF_Tc (zipWith mk_const_meth class_ops constm_uniqs) + ) + ) `thenNF_Tc` \ const_meth_ids -> + + returnTc (dfun_id, dfun_theta, const_meth_ids) +\end{code} + + +%************************************************************************ +%* * +\subsection{Converting instance info into suitable InstEnvs} +%* * +%************************************************************************ + +\begin{code} +buildInstanceEnvs :: Bag InstInfo + -> TcM InstanceMapper + +buildInstanceEnvs info + = let + cmp :: InstInfo -> InstInfo -> TAG_ + (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `cmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _) + = if c1 == c2 then EQ_ else if c1 < c2 then LT_ else GT_ + + info_by_class = equivClasses cmp (bagToList info) + in + mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries -> + let + class_lookup_maybe_fn + :: Class + -> Maybe (ClassInstEnv, (ClassOp -> SpecEnv)) + class_lookup_fn + :: InstanceMapper + + class_lookup_maybe_fn = mkLookupFun (==) inst_env_entries + + class_lookup_fn c + = case class_lookup_maybe_fn c of + Nothing -> (nullMEnv, \ o -> nullSpecEnv) + Just xx -> xx + in + returnTc class_lookup_fn +\end{code} + +\begin{code} +buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class + -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv))) + +buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest) + = let + ops = getClassOps clas + no_of_ops = length ops + in + foldlTc addClassInstance + (nullMEnv, nOfThem no_of_ops nullSpecEnv) + inst_infos `thenTc` \ (class_inst_env, op_inst_envs) -> + let + class_op_maybe_fn :: ClassOp -> Maybe SpecEnv + class_op_fn :: ClassOp -> SpecEnv + + class_op_maybe_fn = mkLookupFun (==) (ops `zip` op_inst_envs) + -- They compare by ClassOp tags + class_op_fn op + = case class_op_maybe_fn op of + Nothing -> nullSpecEnv + Just xx -> xx + in + returnTc (clas, (class_inst_env, class_op_fn)) +\end{code} + +\begin{code} +addClassInstance + :: (ClassInstEnv, [SpecEnv]) + -> InstInfo + -> TcM (ClassInstEnv, [SpecEnv]) -- One SpecEnv for each class op + +addClassInstance + (class_inst_env, op_spec_envs) + (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta dfun_id const_meth_ids _ _ _ src_loc _) + = -- Insert into the class_inst_env first + checkMaybeErrTc (addClassInst clas class_inst_env inst_ty dfun_id inst_tyvars dfun_theta src_loc) + dupInstErr `thenTc` \ class_inst_env' -> + let + -- Adding the classop instances can't fail if the class instance itself didn't + op_spec_envs' = case const_meth_ids of + [] -> op_spec_envs + other -> zipWith add_const_meth op_spec_envs const_meth_ids + in + returnTc (class_inst_env', op_spec_envs') + where + add_const_meth spec_env meth_id + = addOneToSpecEnv spec_env (SpecInfo (Just inst_ty:nothings) 1 meth_id) + where + (const_meth_tyvars,_) = splitForalls (getIdUniType meth_id) + nothings = [Nothing | _ <- const_meth_tyvars] + -- This only works if the constant method id only has its local polymorphism. + -- If you want to have constant methods for + -- instance Foo (a,b,c) where + -- op x = ... + -- then the constant method will be polymorphic in a,b,c, and + -- the SpecInfo will need to be elaborated. +\end{code} + + +%************************************************************************ +%* * +\subsection{Type-checking instance declarations, pass 2} +%* * +%************************************************************************ + +\begin{code} +tcInstDecls2 :: E + -> Bag InstInfo + -> NF_TcM (LIE, TypecheckedBinds) + +tcInstDecls2 e inst_decls + = let + -- Get type variables free in environment. Sadly, there may be + -- some, because of the dreaded monomorphism restriction + free_tyvars = tvOfE e + in + tcInstDecls2_help e free_tyvars (bagToList inst_decls) + +tcInstDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds) + +tcInstDecls2_help e free_tyvars (inst_decl:inst_decls) + = tcInstDecl2 e free_tyvars inst_decl `thenNF_Tc` \ (lie1, binds1) -> + tcInstDecls2_help e free_tyvars inst_decls `thenNF_Tc` \ (lie2, binds2) -> + returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2) +\end{code} + + +======= New documentation starts here (Sept 92) ============== + +The main purpose of @tcInstDecl2@ is to return a @Binds@ which defines +the dictionary function for this instance declaration. For example +\begin{verbatim} + instance Foo a => Foo [a] where + op1 x = ... + op2 y = ... +\end{verbatim} +might generate something like +\begin{verbatim} + dfun.Foo.List dFoo_a = let op1 x = ... + op2 y = ... + in + Dict [op1, op2] +\end{verbatim} + +HOWEVER, if the instance decl has no type variables, then it returns a +bigger @Binds@ with declarations for each method. For example +\begin{verbatim} + instance Foo Int where + op1 x = ... + op2 y = ... +\end{verbatim} +might produce +\begin{verbatim} + dfun.Foo.Int = Dict [Foo.op1.Int, Foo.op2.Int] + Foo.op1.Int x = ... + Foo.op2.Int y = ... +\end{verbatim} +This group may be mutually recursive, because (for example) there may +be no method supplied for op2 in which case we'll get +\begin{verbatim} + Foo.op2.Int = default.Foo.op2 dfun.Foo.Int +\end{verbatim} +that is, the default method applied to the dictionary at this type. + +\begin{code} +tcInstDecl2 :: E + -> [TyVar] -- Free in the environment + -> InstInfo + -> NF_TcM (LIE, TypecheckedBinds) +\end{code} + +First comes the easy case of a non-local instance decl. + +\begin{code} +tcInstDecl2 e free_tyvars (InstInfo _ _ _ _ _ _ _ _ False{-not this module-} _ _ _) + = returnNF_Tc (nullLIE, EmptyBinds) +\end{code} + +Now the case of a general local instance. For an instance declaration, say, + + instance (C1 a, C2 b) => C (T a b) where + ... + +where the {\em immediate} superclasses of C are D1, D2, we build a dictionary +function whose type is + + (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b) + +Notice that we pass it the superclass dictionaries at the instance type; this +is the ``Mark Jones optimisation''. The stuff before the "=>" here +is the @dfun_theta@ below. + +\begin{code} +tcInstDecl2 + e free_tyvars + (InstInfo clas template_tyvars inst_ty_tmpl inst_decl_theta dfun_theta + dfun_id const_meth_ids monobinds True{-from here-} _ locn _) + = let + origin = InstanceDeclOrigin locn + in + recoverTc (nullLIE, EmptyBinds) ( + addSrcLocTc locn ( + pruneSubstTc free_tyvars ( + + -- Get the class signature + let (class_tyvar, + super_classes, sc_sel_ids, + class_ops, op_sel_ids, defm_ids) = getClassBigSig clas + in + -- Prime error recovery and substitution pruning. Instantiate + -- dictionaries from the specified instance context. These + -- dicts will be passed into the dictionary-construction + -- function. + copyTyVars template_tyvars `thenNF_Tc` \ (inst_env, inst_tyvars, inst_tyvar_tys) -> + let + inst_ty = instantiateTy inst_env inst_ty_tmpl + + inst_decl_theta' = instantiateThetaTy inst_env inst_decl_theta + dfun_theta' = instantiateThetaTy inst_env dfun_theta + sc_theta' = super_classes `zip` (repeat inst_ty) + in + newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts' -> + newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts' -> + newDicts origin inst_decl_theta' `thenNF_Tc` \ inst_decl_dicts' -> + let + sc_dicts'_ids = map mkInstId sc_dicts' + dfun_arg_dicts'_ids = map mkInstId dfun_arg_dicts' + in + -- Instantiate the dictionary being constructed + -- and the dictionary-construction function + newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ [this_dict] -> + let + this_dict_id = mkInstId this_dict + in + -- Instantiate method variables + listNF_Tc [ newMethodId sel_id inst_ty origin locn + | sel_id <- op_sel_ids + ] `thenNF_Tc` \ method_ids -> + let + method_insts = catMaybes (map isInstId_maybe method_ids) + -- Extract Insts from those method ids which have them (most do) + -- See notes on newMethodId + in + -- Collect available dictionaries + let avail_insts = -- These insts are in scope; quite a few, eh? + [this_dict] ++ + method_insts ++ + dfun_arg_dicts' + in + processInstBinds e free_tyvars + (makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty) + inst_tyvars avail_insts method_ids monobinds + `thenTc` \ (insts_needed, method_mbinds) -> + -- Complete the binding group + let this_dict_bind + = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids) + dict_and_method_binds + = this_dict_bind `AndMonoBinds` method_mbinds + in + -- Check the overloading constraints of the methods and superclasses + -- The global tyvars must be a fixed point of the substitution + applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars -> + tcSimplifyAndCheck + True -- Top level + real_free_tyvars -- Global tyvars + inst_tyvars -- Local tyvars + avail_insts + (sc_dicts' ++ insts_needed) -- Need to get defns for all these + (BindSigCtxt method_ids) + `thenTc` \ (const_insts, super_binds) -> + + -- Check that we *could* construct the superclass dictionaries, + -- even though we are *actually* going to pass the superclass dicts in; + -- the check ensures that the caller will never have a problem building + -- them. + tcSimplifyAndCheck + False -- Doesn't matter; more efficient this way + real_free_tyvars -- Global tyvars + inst_tyvars -- Local tyvars + inst_decl_dicts' -- The instance dictionaries available + sc_dicts' -- The superclass dicationaries reqd + SuperClassSigCtxt + `thenTc_` + -- Ignore the result; we're only doing + -- this to make sure it can be done. + + -- Create the dictionary function binding itself + let inst_binds + = AbsBinds + inst_tyvars + dfun_arg_dicts'_ids + ((this_dict_id,dfun_id) : (method_ids `zip` const_meth_ids)) + -- const_meth_ids will often be empty + super_binds + (RecBind dict_and_method_binds) + in + + -- Back-substitute + applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds -> + + returnTc (mkLIE const_insts, final_inst_binds) + ))) +\end{code} + +@mkMethodId@ manufactures an id for a local method. +It's rather turgid stuff, because there are two cases: + + (a) For methods with no local polymorphism, we can make an Inst of the + class-op selector function and a corresp InstId; + which is good because then other methods which call + this one will do so directly. + + (b) For methods with local polymorphism, we can't do this. For example, + + class Foo a where + op :: (Num b) => a -> b -> a + + Here the type of the class-op-selector is + + forall a b. (Foo a, Num b) => a -> b -> a + + The locally defined method at (say) type Float will have type + + forall b. (Num b) => Float -> b -> Float + + and the one is not an instance of the other. + + So for these we just make a local (non-Inst) id with a suitable type. + +How disgusting. + +\begin{code} +newMethodId sel_id inst_ty origin loc + = let (sel_tyvars,sel_theta,sel_tau) = splitType (getIdUniType sel_id) + (_:meth_theta) = sel_theta -- The local theta is all except the + -- first element of the context + in + case sel_tyvars of + -- Ah! a selector for a class op with no local polymorphism + -- Build an Inst for this + [clas_tyvar] -> newMethod origin sel_id [inst_ty] `thenNF_Tc` \ inst -> + returnNF_Tc (mkInstId inst) + + -- Ho! a selector for a class op with local polymorphism. + -- Just make a suitably typed local id for this + (clas_tyvar:local_tyvars) -> + let + method_ty = instantiateTy [(clas_tyvar,inst_ty)] + (mkSigmaTy local_tyvars meth_theta sel_tau) + in + getUniqueTc `thenNF_Tc` \ uniq -> + returnNF_Tc (mkUserLocal (getOccurrenceName sel_id) uniq method_ty loc) +\end{code} + +This function makes a default method which calls the global default method, at +the appropriate instance type. + +See the notes under default decls in TcClassDcl.lhs. + +\begin{code} +makeInstanceDeclDefaultMethodExpr + :: InstOrigin + -> Id + -> [ClassOp] + -> [Id] + -> UniType + -> Int + -> NF_TcM TypecheckedExpr + +makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty tag + = let + (tyvar_tmpls, local_theta, _) = splitType (getClassOpLocalType class_op) + in + copyTyVars tyvar_tmpls `thenNF_Tc` \ (inst_env, tyvars, tys) -> + let + inst_theta = instantiateThetaTy inst_env local_theta + in + newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts -> + let + local_dicts = map mkInstId local_dict_insts + in + returnNF_Tc ( + mkTyLam tyvars ( + mkDictLam local_dicts ( + mkDictApp (mkTyApp (Var defm_id) + (inst_ty : tys)) + (this_dict_id:local_dicts))) + ) + where + idx = tag - 1 + class_op = class_ops !! idx + defm_id = defm_ids !! idx +\end{code} + + +%************************************************************************ +%* * +\subsection{Processing each method} +%* * +%************************************************************************ + +@processInstBinds@ returns a @MonoBinds@ which binds +all the method ids (which are passed in). It is used + - both for instance decls, + - and to compile the default-method declarations in a class decl. + +Any method ids which don't have a binding have a suitable default +binding created for them. The actual right-hand side used is +created using a function which is passed in, because the right thing to +do differs between instance and class decls. + +\begin{code} +processInstBinds + :: E + -> [TyVar] -- Free in envt + + -> (Int -> NF_TcM TypecheckedExpr) -- Function to make + -- default method + + -> [TyVar] -- Tyvars for this instance decl + + -> [Inst] -- available Insts + + -> [Id] -- Local method ids + -- (instance tyvars are free + -- in their types), + -- in tag order + -> RenamedMonoBinds + + -> TcM ([Inst], -- These are required + TypecheckedMonoBinds) + +processInstBinds e free_tyvars mk_method_expr inst_tyvars + avail_insts method_ids monobinds + = + -- Process the explicitly-given method bindings + processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids monobinds + `thenTc` (\ (tags, insts_needed_in_methods, method_binds) -> + + -- Find the methods not handled, and make default method bindings for them. + let unmentioned_tags = [1.. length method_ids] `minusList` tags + in + makeDefaultMethods mk_method_expr unmentioned_tags method_ids + `thenNF_Tc` (\ default_monobinds -> + + returnTc (insts_needed_in_methods, + method_binds `AndMonoBinds` default_monobinds) + )) +\end{code} + +\begin{code} +processInstBinds1 + :: E + -> [TyVar] -- Global free tyvars + -> [TyVar] -- Tyvars for this instance decl + -> [Inst] -- available Insts + -> [Id] -- Local method ids (instance tyvars are free), + -- in tag order + -> RenamedMonoBinds + -> TcM ([Int], -- Class-op tags accounted for + [Inst], -- These are required + TypecheckedMonoBinds) + +processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids EmptyMonoBinds + = returnTc ([], [], EmptyMonoBinds) + +processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) + = processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb1 + `thenTc` \ (op_tags1,dicts1,method_binds1) -> + processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb2 + `thenTc` \ (op_tags2,dicts2,method_binds2) -> + returnTc (op_tags1 ++ op_tags2, + dicts1 ++ dicts2, + AndMonoBinds method_binds1 method_binds2) +\end{code} + +\begin{code} +processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind + = + -- Find what class op is being defined here. The complication is + -- that we could have a PatMonoBind or a FunMonoBind. If the + -- former, it should only bind a single variable, or else we're in + -- trouble (I'm not sure what the static semantics of methods + -- defined in a pattern binding with multiple patterns is!) + -- Renamer has reduced us to these two cases. + let + (op,locn) = case mbind of + FunMonoBind op _ locn -> (op, locn) + PatMonoBind (VarPatIn op) _ locn -> (op, locn) + + origin = InstanceDeclOrigin locn + in + addSrcLocTc locn ( + + -- Make a method id for the method + let tag = getTagFromClassOpName op + method_id = method_ids !! (tag-1) + method_ty = getIdUniType method_id + in + specTy origin method_ty `thenNF_Tc` \ (method_tyvars, method_dicts, method_tau) -> + + -- Build the result + case (method_tyvars, method_dicts) of + + ([],[]) -> -- The simple case; no local polymorphism or overloading in the method + + -- Type check the method itself + tcMethodBind e method_id method_tau mbind `thenTc` \ (mbind', lieIop) -> + + -- Make sure that the instance tyvars havn't been + -- unified with each other or with the method tyvars. + -- The global tyvars must be a fixed point of the substitution + applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars -> + checkSigTyVars real_free_tyvars inst_tyvars method_tau method_tau + (MethodSigCtxt op method_tau) `thenTc_` + + returnTc ([tag], unMkLIE lieIop, mbind') + + other -> -- It's a locally-polymorphic and/or overloaded method; UGH! + + -- Make a new id for (a) the local, non-overloaded method + -- and (b) the locally-overloaded method + -- The latter is needed just so we can return an AbsBinds wrapped + -- up inside a MonoBinds. + newLocalWithGivenTy op method_tau `thenNF_Tc` \ local_meth_id -> + newLocalWithGivenTy op method_ty `thenNF_Tc` \ copy_meth_id -> + + -- Typecheck the method + tcMethodBind e local_meth_id method_tau mbind `thenTc` \ (mbind', lieIop) -> + + -- Make sure that the instance tyvars haven't been + -- unified with each other or with the method tyvars. + -- The global tyvars must be a fixed point of the substitution + applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars -> + checkSigTyVars real_free_tyvars (method_tyvars ++ inst_tyvars) method_tau method_tau + (MethodSigCtxt op method_tau) `thenTc_` + + -- Check the overloading part of the signature. + -- Simplify everything fully, even though some + -- constraints could "really" be left to the next + -- level out. The case which forces this is + -- + -- class Foo a where { op :: Bar a => a -> a } + -- + -- Here we must simplify constraints on "a" to catch all + -- the Bar-ish things. + tcSimplifyAndCheck + False -- Not top level + real_free_tyvars + (inst_tyvars ++ method_tyvars) + (method_dicts ++ avail_insts) + (unMkLIE lieIop) + (MethodSigCtxt op method_ty) `thenTc` \ (f_dicts, dict_binds) -> + + returnTc ([tag], + f_dicts, + VarMonoBind method_id + (Let + (AbsBinds + method_tyvars + (map mkInstId method_dicts) + [(local_meth_id, copy_meth_id)] + dict_binds + (NonRecBind mbind')) + (Var copy_meth_id))) + ) +\end{code} + +\begin{code} +tcMethodBind :: E -> Id -> UniType -> RenamedMonoBinds + -> TcM (TypecheckedMonoBinds, LIE) + +tcMethodBind e meth_id meth_ty (FunMonoBind name matches locn) + = addSrcLocTc locn ( + tcMatchesFun e name meth_ty matches `thenTc` \ (rhs', lie) -> + returnTc (FunMonoBind meth_id rhs' locn, lie) + ) + +tcMethodBind e meth_id meth_ty (PatMonoBind pat grhss_and_binds locn) + -- pat is sure to be a (VarPatIn op) + = addSrcLocTc locn ( + tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, rhs_ty) -> + unifyTauTy meth_ty rhs_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_` + returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie) + ) +\end{code} + + +Creates bindings for the default methods, being the application of the +appropriate global default method to the type of this instance decl. + +\begin{code} +makeDefaultMethods + :: (Int -> NF_TcM TypecheckedExpr) -- Function to make + -- default method + -> [Int] -- Tags for methods required + -> [Id] -- Method names to bind, in tag order + -> NF_TcM TypecheckedMonoBinds + + +makeDefaultMethods mk_method_expr [] method_ids + = returnNF_Tc EmptyMonoBinds + +makeDefaultMethods mk_method_expr (tag:tags) method_ids + = mk_method_expr tag `thenNF_Tc` \ rhs -> + makeDefaultMethods mk_method_expr tags method_ids `thenNF_Tc` \ meth_binds -> + + returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds) + where + method_id = method_ids !! (tag-1) +\end{code} + +%************************************************************************ +%* * +\subsection{Type-checking specialise instance pragmas} +%* * +%************************************************************************ + +\begin{code} +tcSpecInstSigs :: E -> CE -> TCE + -> Bag InstInfo -- inst decls seen (declared and derived) + -> [RenamedSpecialisedInstanceSig] -- specialise instance upragmas + -> TcM (Bag InstInfo) -- new, overlapped, inst decls + +tcSpecInstSigs e ce tce inst_infos [] + = returnTc emptyBag + +tcSpecInstSigs e ce tce inst_infos sigs + = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper -> + tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos -> + returnTc spec_inst_infos + where + tc_inst_spec_sigs inst_mapper [] + = returnNF_Tc emptyBag + tc_inst_spec_sigs inst_mapper (sig:sigs) + = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig -> + tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs -> + returnNF_Tc (info_sig `unionBags` info_sigs) + +tcSpecInstSig :: E -> CE -> TCE + -> Bag InstInfo + -> InstanceMapper + -> RenamedSpecialisedInstanceSig + -> NF_TcM (Bag InstInfo) + +tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc) + = recoverTc emptyBag ( + addSrcLocTc src_loc ( + let + clas = lookupCE ce class_name -- Renamer ensures this can't fail + + -- Make some new type variables, named as in the specialised instance type + ty_names = extractMonoTyNames (==) ty + (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names + in + babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) + `thenTc` \ inst_ty -> + let + tycon = case getUniDataTyCon_maybe inst_ty of + Just (tc,_,_) -> tc + Nothing -> panic "tcSpecInstSig:inst_tycon" + + maybe_unspec_inst = lookup_unspec_inst clas tycon inst_infos + in + -- Check that we have a local instance declaration to specialise + checkMaybeTc maybe_unspec_inst + (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_` + + -- Create tvs to substitute for tmpls while simplifying the context + copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) -> + let + Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta + _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst + + subst = case matchTy unspec_inst_ty inst_ty of + Just subst -> subst + Nothing -> panic "tcSpecInstSig:matchTy" + + subst_theta = instantiateThetaTy subst unspec_theta + subst_tv_theta = instantiateThetaTy tv_e subst_theta + + mk_spec_origin clas ty + = InstanceSpecOrigin inst_mapper clas ty src_loc + in + tcSimplifyThetas mk_spec_origin subst_tv_theta + `thenTc` \ simpl_tv_theta -> + let + simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ] + + tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys + tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv + in + mkInstanceRelatedIds e True{-from here-} NoInstancePragmas src_loc + clas inst_tmpls inst_ty simpl_theta uprag + `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> + + getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> + (if sw_chkr SpecialiseTrace then + pprTrace "Specialised Instance: " + (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta, + if null simpl_theta then ppNil else ppStr "=>", + ppr PprDebug clas, + pprParendUniType PprDebug inst_ty], + ppCat [ppStr " derived from:", + if null unspec_theta then ppNil else ppr PprDebug unspec_theta, + if null unspec_theta then ppNil else ppStr "=>", + ppr PprDebug clas, + pprParendUniType PprDebug unspec_inst_ty]]) + else id) ( + + returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta + dfun_theta dfun_id const_meth_ids + binds True{-from here-} mod src_loc uprag)) + ))) + + +lookup_unspec_inst clas tycon inst_infos + = case filter match_info (bagToList inst_infos) of + [] -> Nothing + (info:_) -> Just info + where + match_info (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _) + = from_here && clas == inst_clas && inst_ty_matches_tycon + where + inst_ty_matches_tycon = case (getUniDataTyCon_maybe inst_ty) of + Just (inst_tc,tys,_) -> tycon == inst_tc && all isTyVarTemplateTy tys + Nothing -> False + +\end{code} diff --git a/ghc/compiler/typecheck/TcMatches.hi b/ghc/compiler/typecheck/TcMatches.hi new file mode 100644 index 0000000..d286122 --- /dev/null +++ b/ghc/compiler/typecheck/TcMatches.hi @@ -0,0 +1,23 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcMatches where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsMatches(Match) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcMatch :: E -> Match Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Match Id TypecheckedPat, LIE, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +tcMatchesCase :: E -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22222122 _N_ _S_ "LS" _N_ _N_ #-} +tcMatchesFun :: E -> Name -> UniType -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE) + {-# GHC_PRAGMA _A_ 4 _U_ 2222222222 _N_ _S_ "LLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs new file mode 100644 index 0000000..b7037aa --- /dev/null +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -0,0 +1,221 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[TcMatches]{Typecheck some @Matches@} + +\begin{code} +#include "HsVersions.h" + +module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( mkIdsWithOpenTyVarTys ) +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( mkFunTy ) +import AbsUniType ( isTyVarTy, maybeUnpackFunTy ) +import E ( E, growE_LVE, LVE(..), GVE(..) ) +#if USE_ATTACK_PRAGMAS +import CE +import TCE +#endif +import Errors ( varyingArgsErr, Error(..), UnifyErrContext(..) ) +import LIE ( LIE, plusLIE ) +import Maybes ( Maybe(..) ) +import TcGRHSs ( tcGRHSsAndBinds ) +import TcPat ( tcPat ) +import Unify ( unifyTauTy, unifyTauTyList ) +import Util +\end{code} + +@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a +@FunMonoBind@. The second argument is the name of the function, which +is used in error messages. It checks that all the equations have the +same number of arguments before using @tcMatches@ to do the work. + +\begin{code} +tcMatchesFun :: E -> Name + -> UniType -- Expected type + -> [RenamedMatch] + -> TcM ([TypecheckedMatch], LIE) + +tcMatchesFun e fun_name expected_ty matches@(first_match:_) + = -- Set the location to that of the first equation, so that + -- any inter-equation error messages get some vaguely + -- sensible location. Note: we have to do this odd + -- ann-grabbing, because we don't always have annotations in + -- hand when we call tcMatchesFun... + + addSrcLocTc (get_Match_loc first_match) ( + + -- Check that they all have the same no of arguments + checkTc (not (all_same (noOfArgs matches))) + (varyingArgsErr fun_name matches) `thenTc_` + + -- ToDo: Don't use "expected" stuff if there ain't a type signature + -- because inconsistency between branches + -- may show up as something wrong with the (non-existent) type signature + + -- We need to substitute so that we can see as much about the type as possible + applyTcSubstToTy expected_ty `thenNF_Tc` \ expected_ty' -> + tcMatchesExpected e expected_ty' (\ m -> FunMonoBindsCtxt fun_name [m]) matches + + ) + where + all_same :: [Int] -> Bool + all_same [] = True -- Should never happen (ToDo: panic?) + all_same [x] = True + all_same (x:xs) = all ((==) x) xs +\end{code} + +@tcMatchesCase@ doesn't do the argument-count check because the +parser guarantees that each equation has exactly one argument. + +\begin{code} +tcMatchesCase :: E -> [RenamedMatch] + -> TcM ([TypecheckedMatch], LIE, UniType) + +tcMatchesCase e matches + = + + -- Typecheck them + tcMatches e matches `thenTc` \ (matches', lie, tys@(first_ty:_)) -> + + -- Set the location to that of the first equation, so that + -- any inter-equation error messages get some vaguely sensible location + addSrcLocTc (get_Match_loc (head matches)) ( + unifyTauTyList tys (CaseBranchesCtxt matches) + ) `thenTc_` + + returnTc (matches', lie, first_ty) +\end{code} + + +\begin{code} +tcMatchesExpected :: E + -> UniType + -> (RenamedMatch -> UnifyErrContext) + -> [RenamedMatch] + -> TcM ([TypecheckedMatch], LIE) + +tcMatchesExpected e expected_ty err_ctxt_fn [match] + = addSrcLocTc (get_Match_loc match) ( + tcMatchExpected e expected_ty (err_ctxt_fn match) match + ) `thenTc` \ (match', lie) -> + returnTc ([match'], lie) + +tcMatchesExpected e expected_ty err_ctxt_fn ms@(match1 : matches) + = addSrcLocTc (get_Match_loc match1) ( + tcMatchExpected e expected_ty (err_ctxt_fn match1) match1 + ) `thenTc` \ (match1', lie1) -> + tcMatchesExpected e expected_ty err_ctxt_fn matches `thenTc` \ (matches', lie2) -> + returnTc (match1' : matches', plusLIE lie1 lie2) + +tcMatches :: E -> [RenamedMatch] -> TcM ([TypecheckedMatch], LIE, [UniType]) + +tcMatches e [match] + = tcMatch e match `thenTc` \ (match', lie, ty) -> + returnTc ([match'], lie, [ty]) + +tcMatches e ms@(match1 : matches) + = addSrcLocTc (get_Match_loc match1) ( + tcMatch e match1 + ) `thenTc` \ (match1', lie1, match1_ty) -> + tcMatches e matches `thenTc` \ (matches', lie2, matches_ty) -> + returnTc (match1' : matches', plusLIE lie1 lie2, match1_ty : matches_ty) +\end{code} + +\begin{code} +tcMatchExpected + :: E + -> UniType -- This gives the expected + -- result-type of the Match. Early unification + -- with this guy gives better error messages + -> UnifyErrContext + -> RenamedMatch + -> TcM (TypecheckedMatch,LIE) + -- NB No type returned, because it was passed + -- in instead! + +tcMatchExpected e expected_ty err_ctxt the_match@(PatMatch pat match) + = case maybeUnpackFunTy expected_ty of + + Nothing -> -- Not a function type (eg type variable) + -- So use tcMatch instead + tcMatch e the_match `thenTc` \ (match', lie_match, match_ty) -> + unifyTauTy match_ty expected_ty err_ctxt `thenTc_` + returnTc (match', lie_match) + + Just (arg_ty,rest_ty) -> -- It's a function type! + let binders = collectPatBinders pat + in + mkIdsWithOpenTyVarTys binders `thenNF_Tc` \ lve -> + let e' = growE_LVE e lve + in + tcPat e' pat `thenTc` \ (pat', lie_pat, pat_ty) -> + + unifyTauTy arg_ty pat_ty err_ctxt `thenTc_` + tcMatchExpected e' rest_ty err_ctxt match `thenTc` \ (match', lie_match) -> + returnTc (PatMatch pat' match', + plusLIE lie_pat lie_match) + +tcMatchExpected e expected_ty err_ctxt (GRHSMatch grhss_and_binds) + = tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) -> + unifyTauTy grhss_ty expected_ty err_ctxt `thenTc_` + returnTc (GRHSMatch grhss_and_binds', lie) + +tcMatch :: E + -> RenamedMatch + -> TcM (TypecheckedMatch,LIE,UniType) + +tcMatch e (PatMatch pat match) + = let binders = collectPatBinders pat + in + mkIdsWithOpenTyVarTys binders `thenNF_Tc` \ lve -> + let e' = growE_LVE e lve + in + tcPat e' pat `thenTc` \ (pat', lie_pat, pat_ty) -> + tcMatch e' match `thenTc` \ (match', lie_match, match_ty) -> + +-- We don't do this any more, do we? +-- applyTcSubstToTy pat_ty `thenNF_Tc`\ pat_ty' -> + + returnTc (PatMatch pat' match', + plusLIE lie_pat lie_match, + mkFunTy pat_ty match_ty) + +tcMatch e (GRHSMatch grhss_and_binds) + = tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds', lie, grhss_ty) -> + returnTc (GRHSMatch grhss_and_binds', lie, grhss_ty) +\end{code} + + +@noOfArgs@ takes a @[RenamedMatch]@ and returns a list telling how +many arguments were used in each of the equations. This is used to +report a sensible error message when different equations have +different numbers of arguments. + +\begin{code} +noOfArgs :: [RenamedMatch] -> [Int] + +noOfArgs ms = map args_in_match ms + where + args_in_match :: RenamedMatch -> Int + args_in_match (GRHSMatch _) = 0 + args_in_match (PatMatch _ match) = 1 + args_in_match match +\end{code} + +@get_Match_loc@ takes a @RenamedMatch@ and returns the +source-location gotten from the GRHS inside. +THis is something of a nuisance, but no more. + +\begin{code} +get_Match_loc :: RenamedMatch -> SrcLoc + +get_Match_loc (PatMatch _ m) = get_Match_loc m +get_Match_loc (GRHSMatch (GRHSsAndBindsIn (g:_) _)) + = get_GRHS_loc g + where + get_GRHS_loc (OtherwiseGRHS _ locn) = locn + get_GRHS_loc (GRHS _ _ locn) = locn +\end{code} diff --git a/ghc/compiler/typecheck/TcModule.hi b/ghc/compiler/typecheck/TcModule.hi new file mode 100644 index 0000000..380e399 --- /dev/null +++ b/ghc/compiler/typecheck/TcModule.hi @@ -0,0 +1,68 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcModule where +import AbsSyn(Module) +import Bag(Bag) +import CE(CE(..)) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import E(E) +import ErrUtils(Error(..)) +import FiniteMap(FiniteMap) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsMatches(Match) +import HsPat(InPat, RenamedPat(..), TypecheckedPat) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TCE(TCE(..)) +import TcInstDcls(InstInfo) +import TcMonad(TcResult) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type CE = UniqFM Class +data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type RenamedPat = InPat Name +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +type TCE = UniqFM TyCon +data InstInfo {-# GHC_PRAGMA InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] #-} +data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +tcModule :: E -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [[Labda UniType]], E, PprStyle -> Int -> Bool -> PrettyRep) + {-# GHC_PRAGMA _A_ 9 _U_ 221222120 _N_ _S_ "LLU(LAALSLLLLLLLL)LLLU(ALL)LA" {_A_ 8 _U_ 22122212 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs new file mode 100644 index 0000000..15213ff --- /dev/null +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -0,0 +1,279 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcModule]{Typechecking a whole module} + +\begin{code} +#include "HsVersions.h" + +module TcModule ( + tcModule, + + -- to make the interface self-sufficient... + Module, Bag, CE(..), E, Binds, FixityDecl, Expr, InPat, + RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, TcResult, + Name, ProtoName, SrcLoc, Subst, TCE(..), UniqFM, + Error(..), Pretty(..), PprStyle, PrettyRep, InstInfo + ) where + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +-- OLD: +--import AbsPrel ( stringTy, +-- eqStringId, neStringId, ltStringId, +-- leStringId, geStringId, gtStringId, +-- maxStringId, minStringId, tagCmpStringId, +-- dfunEqStringId, dfunOrdStringId, +-- pRELUDE_CORE +-- IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) +-- ) +--#if USE_ATTACK_PRAGMAS +--import PrelVals ( string_cmp_id ) -- shouldn't even be visible, really +--#endif +import BackSubst ( applyTcSubstToBinds ) +import Bag ( unionBags, bagToList, emptyBag, listToBag ) +import CE ( nullCE, checkClassCycles, lookupCE, CE(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import E +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import InstEnv +import LIE ( unMkLIE, plusLIE, LIE ) +import Name ( Name(..) ) +import RenameAuxFuns ( GlobalNameFuns(..), GlobalNameFun(..), ProtoName, Maybe ) +import SrcLoc ( mkBuiltinSrcLoc, SrcLoc ) +import TCE ( checkTypeCycles, TCE(..), UniqFM ) +import TcBinds ( tcTopBindsAndThen ) +import TcClassDcl ( tcClassDecls1, tcClassDecls2, ClassInfo ) +import TcDefaults ( tcDefaults ) +import TcDeriv ( tcDeriving ) +import TcIfaceSig ( tcInterfaceSigs ) +import TcInstDcls ( tcInstDecls1, tcInstDecls2, tcSpecInstSigs, buildInstanceEnvs, InstInfo(..) ) +import TcSimplify ( tcSimplifyTop ) +import TcTyDecls ( tcTyDecls ) +import Unique -- some ClassKey stuff +import UniqFM ( emptyUFM ) -- profiling, pragmas only +import Util + +import Pretty -- Debugging +\end{code} + +\begin{code} +tcModule :: E -- initial typechecker environment + -> GlobalNameFuns -- final renamer info (to do derivings) + -> RenamedModule -- input + -> TcM ((TypecheckedBinds, -- binds from class decls; does NOT + -- include default-methods bindings + TypecheckedBinds, -- binds from instance decls; INCLUDES + -- class default-methods binds + TypecheckedBinds, -- binds from value decls + [(Inst, TypecheckedExpr)]), + + ([RenamedFixityDecl], -- things for the interface generator + [Id], -- to look at... + CE, + TCE, + Bag InstInfo), + + FiniteMap TyCon [[Maybe UniType]], + -- source tycon specialisation requests + +--UNUSED: E, -- environment of total accumulated info + E, -- environment of info due to this module only + PprStyle -> Pretty) -- -ddump-deriving info (passed upwards) + +tcModule e1 renamer_name_funs + (Module mod_name exports imports_should_be_empty fixities + tydecls ty_sigs classdecls instdecls specinst_sigs + default_decls valdecls sigs src_loc) + + = addSrcLocTc src_loc ( -- record where we're starting + + -- Tie the knot for inteface-file value declaration signatures + -- This info is only used inside the knot for type-checking the + -- pragmas, which is done lazily [ie failure just drops the pragma + -- without having any global-failure effect]. + + fixTc (\ ~(rec_gve_sigs, _, _, _, _, _, _, _, _, _) -> + let + e2 = plusE_GVE e1 rec_gve_sigs + in + + -- The knot for instance information. This isn't used at all + -- till we type-check value declarations. + fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _, _, _, _) -> + + -- The knot for TyCons and Classes + fixTc ( \ ~(_, rec_tce, rec_ce, rec_datacons_gve, rec_ops_gve, _, _) -> + let + e3 = e2 + `plusE_GVE` rec_datacons_gve + `plusE_GVE` rec_ops_gve + `plusE_TCE` rec_tce + `plusE_CE` rec_ce + in + -- DO THE TYPE DECLS + -- Including the pragmas: {-# ABSTRACT TypeSyn #-} + -- {-# SPECIALIZE data DataType ... #-} + let + (absty_sigs, specdata_sigs) = partition is_absty_sig ty_sigs + is_absty_sig (AbstractTypeSig _ _) = True + is_absty_sig (SpecDataSig _ _ _) = False + + is_abs_syn :: Name -> Bool -- a lookup fn for abs synonyms + is_abs_syn n + = n `is_elem` [ tc | (AbstractTypeSig tc _) <- absty_sigs ] + where + is_elem = isIn "tcModule" + + get_spec_sigs :: Name -> [RenamedDataTypeSig] + get_spec_sigs n + = [ sig | sig@(SpecDataSig tc _ _) <- specdata_sigs, n == tc] + in + babyTcMtoTcM (tcTyDecls e3 is_abs_syn get_spec_sigs tydecls) + `thenTc` \ (tce, datacons_gve, tycon_specs) -> + + -- DO THE CLASS DECLS + tcClassDecls1 e3 rec_inst_mapper classdecls + `thenTc` \ (class_info, ce, ops_gve) -> + + -- End of TyCon/Class knot + -- Augment whatever TCE/GVE/CE stuff was in orig_e + returnTc (e3, tce, ce, datacons_gve, ops_gve, class_info, tycon_specs) + + -- End of inner fixTc + ) `thenTc` ( \ (e3, tce_here, ce_here, _, _, class_info, tycon_specs) -> + -- The "here" things are the extra decls defined in this + -- module or its imports; but not including whatever was + -- in the incoming e. + + -- Grab completed tce/ce and check for type/class cycles + -- The tce/ce are now stable and lookable-at, with the + -- exception of the instance information inside classes + let + ce3 = getE_CE e3 + tce3 = getE_TCE e3 + in + checkMaybeErrTc (checkTypeCycles tce3) id `thenTc_` + checkMaybeErrTc (checkClassCycles ce3) id `thenTc_` + + -- Now instance declarations + tcInstDecls1 e3 ce3 tce3 instdecls `thenNF_Tc` \ decl_inst_info -> + + -- Handle "derived" instances; note that we only do derivings + -- for things in this module; we ignore deriving decls from + -- interfaces! We pass fixities, because they may be used in + -- doing Text. + + tcDeriving mod_name renamer_name_funs decl_inst_info tce3 fixities + `thenTc` \ (deriv_inst_info, extra_deriv_binds, ddump_deriv) -> + + let + inst_info = deriv_inst_info `unionBags` decl_inst_info + in + -- Handle specialise instance pragmas +-- getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> +-- (if sw_chkr GlasgowExts then + tcSpecInstSigs e3 ce3 tce3 inst_info specinst_sigs +-- else +-- returnTc emptyBag) + `thenTc` \ spec_inst_info -> + let + full_inst_info = inst_info `unionBags` spec_inst_info + in + -- OK, now do the inst-mapper stuff + buildInstanceEnvs full_inst_info `thenTc` \ all_insts_mapper -> + + returnTc (all_insts_mapper, e3, ce_here, tce_here, class_info, tycon_specs, + full_inst_info, extra_deriv_binds, ddump_deriv) + + -- End of outer fixTc + )) `thenTc` ( \ (_, e3, ce_here, tce_here, class_info, tycon_specs, + full_inst_info, extra_deriv_binds, ddump_deriv) -> + + -- Default declarations + tcDefaults e3 default_decls `thenTc` \ defaulting_tys -> + setDefaultingTys defaulting_tys ( -- for the iface sigs... + + -- Interface type signatures + + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + + babyTcMtoTcM (tcInterfaceSigs e3 sigs) `thenTc` \ gve_sigs -> + + returnTc (gve_sigs, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys, + full_inst_info, extra_deriv_binds, ddump_deriv) + + -- End of extremely outer fixTc + ))) `thenTc` \ (_, e3, ce_here, tce_here, class_info, tycon_specs, defaulting_tys, + full_inst_info, extra_deriv_binds, ddump_deriv) -> + + setDefaultingTys defaulting_tys ( -- to the end... + + -- Value declarations next. + -- We also typecheck any extra binds that came out of the "deriving" process + -- Nota bene + tcTopBindsAndThen + e3 + (\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing)) + (valdecls `ThenBinds` extra_deriv_binds) + (\ e4 -> + -- Second pass over instance declarations, + -- to compile the bindings themselves. + tcInstDecls2 e4 full_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> + tcClassDecls2 e4 class_info `thenNF_Tc` \ (lie_clasdecls, class_binds) -> + returnTc ( (EmptyBinds, (inst_binds, class_binds, e4)), + lie_instdecls `plusLIE` lie_clasdecls, + () ) + ) + + `thenTc` \ ((val_binds, (inst_binds, class_binds, e4)), lie_alldecls, _) -> + + -- Deal with constant or ambiguous InstIds. How could + -- there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism + -- restriction, and no subsequent decl instantiates its + -- type. (Usually, ambiguous type variables are resolved + -- during the generalisation step.) + + tcSimplifyTop (unMkLIE lie_alldecls) `thenTc` \ const_inst_binds -> + + -- Backsubstitution. Monomorphic top-level decls may have + -- been instantiated by subsequent decls, and the final + -- simplification step may have instantiated some + -- ambiguous types. So, sadly, we need to back-substitute + -- over the whole bunch of bindings. + + applyTcSubstToBinds val_binds `thenNF_Tc` \ val_binds' -> + applyTcSubstToBinds inst_binds `thenNF_Tc` \ inst_binds' -> + applyTcSubstToBinds class_binds `thenNF_Tc` \ class_binds' -> + + -- ToDo: probably need to back-substitute over all + -- stuff in 'e4'; we do so here over the Ids, + -- which is probably enough. WDP 95/06 + mapNF_Tc applyTcSubstToId (getE_GlobalVals e4) + `thenNF_Tc` \ if_global_ids -> + + -- FINISHED AT LAST + returnTc ( + (class_binds', inst_binds', val_binds', const_inst_binds), + + -- the next collection is just for mkInterface + (fixities, if_global_ids, ce_here, tce_here, full_inst_info), + + tycon_specs, + +--UNUSED: e4, + + -- and... TCE needed for code generation; rest needed for interpreter. + -- ToDo: still wrong: needs isLocallyDeclared run over everything + mkE tce_here {-gve_here lve-} ce_here, + -- NB: interpreter would probably need the gve_here stuff + ddump_deriv + ))) +\end{code} diff --git a/ghc/compiler/typecheck/TcMonad.hi b/ghc/compiler/typecheck/TcMonad.hi new file mode 100644 index 0000000..1b78564 --- /dev/null +++ b/ghc/compiler/typecheck/TcMonad.hi @@ -0,0 +1,218 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcMonad where +import Bag(Bag) +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import ErrsTc(UnifyErrContext) +import FiniteMap(FiniteMap) +import HsBinds(Binds) +import HsExpr(ArithSeqInfo, Expr, Qual, TypecheckedExpr(..)) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat, TypecheckedPat) +import HsTypes(PolyType) +import Id(Id, IdDetails, applySubstToId) +import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo) +import Inst(Inst, InstOrigin, OverloadedLit, applySubstToInst) +import InstEnv(InstTemplate) +import Maybes(Labda, MaybeErr) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import ProtoName(ProtoName) +import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..)) +import RenameMonad4(Rn4M(..)) +import SimplEnv(UnfoldingDetails) +import SplitUniq(SUniqSM(..), SplitUniqSupply, getSUnique, getSUniques, splitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst, applySubstToThetaTy, applySubstToTy, applySubstToTyVar) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType) +import Unique(Unique, UniqueSupply, mkUniqueGrimily) +infixr 9 `thenNF_Tc` +infixr 9 `thenTc` +infixr 9 `thenTc_` +type Baby_TcM a = (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a +data Baby_TcResult a {-# GHC_PRAGMA BabyTcFailed (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | BabyTcSucceeded a (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +type NF_TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) +type TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a +data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-} +data UnifyErrContext + {-# GHC_PRAGMA PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType #-} +type TypecheckedExpr = Expr Id TypecheckedPat +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type GlobalNameFun = ProtoName -> Labda Name +type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name) +type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep)) +type SUniqSM a = SplitUniqSupply -> a +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +addSrcLocB_Tc :: SrcLoc -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a + {-# GHC_PRAGMA _A_ 6 _U_ 212220 _N_ _S_ "LSLLLA" {_A_ 5 _U_ 21222 _N_ _N_ _F_ _IF_ARGS_ 1 5 XXXXX 5 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u2 [ u3, u4, u5, u1 ] _N_} _F_ _IF_ARGS_ 1 6 XXXXXX 5 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u1 ] _N_ #-} +addSrcLocTc :: SrcLoc -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 8 _U_ 21222220 _N_ _S_ "LSLLLLLA" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_ #-} +applySubstToId :: Subst -> Id -> (Subst, Id) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LSU(LLU(S)LLLLLLL)S)" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +applySubstToInst :: Subst -> Inst -> (Subst, Inst) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +applyTcSubstToId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1002020 _N_ _S_ "U(LSU(LLU(S)LLLLLLL)S)AALALA" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +applyTcSubstToInst :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1002020 _N_ _S_ "SAALALA" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: Inst) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> case _APP_ _ORIG_ Inst applySubstToInst [ u3, u0 ] of { _ALG_ _TUP_2 (u7 :: Subst) (u8 :: Inst) -> _!_ _TUP_3 [Inst, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u7, u5]; _NO_DEFLT_ } _N_ #-} +applyTcSubstToInsts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: [Inst]) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ TcMonad mapNF_Tc { Inst } { Inst } [ _ORIG_ TcMonad applyTcSubstToInst, u0 ] _N_ #-} +applyTcSubstToTy :: UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _S_ "SAALALA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: UniType) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> case _APP_ _ORIG_ Subst applySubstToTy [ u3, u0 ] of { _ALG_ _TUP_2 (u7 :: Subst) (u8 :: UniType) -> _!_ _TUP_3 [UniType, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u7, u5]; _NO_DEFLT_ } _N_ #-} +applyTcSubstToTyVar :: TyVar -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _S_ "LAALALA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: TyVar) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> case _APP_ _ORIG_ Subst applySubstToTyVar [ u3, u0 ] of { _ALG_ _TUP_2 (u7 :: Subst) (u8 :: UniType) -> _!_ _TUP_3 [UniType, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u7, u5]; _NO_DEFLT_ } _N_ #-} +applyTcSubstToTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: [TyVar]) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ TcMonad mapNF_Tc { TyVar } { UniType } [ _ORIG_ TcMonad applyTcSubstToTyVar, u0 ] _N_ #-} +applyTcSubstToTys :: [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: [UniType]) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ TcMonad mapNF_Tc { UniType } { UniType } [ _ORIG_ TcMonad applyTcSubstToTy, u0 ] _N_ #-} +babyTcMtoNF_TcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1202222 _N_ _S_ "SLALLLL" {_A_ 6 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +babyTcMtoTcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 7 _U_ 1202222 _N_ _S_ "SLALLLL" {_A_ 6 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +checkB_Tc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult () + {-# GHC_PRAGMA _A_ 6 _U_ 120020 _N_ _S_ "EL" _N_ _N_ #-} +checkMaybeErrTc :: MaybeErr b a -> (a -> PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b + {-# GHC_PRAGMA _A_ 2 _U_ 11222222 _N_ _S_ "SL" _N_ _N_ #-} +checkMaybeTc :: Labda a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 8 _U_ 12002020 _N_ _S_ "SL" _F_ _IF_ARGS_ 1 8 CXXXXXXX 10 _/\_ u0 -> \ (u1 :: Labda u0) (u2 :: PprStyle -> Int -> Bool -> PrettyRep) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> case u1 of { _ALG_ _ORIG_ Maybes Ni (u9 :: u0) -> _!_ _ORIG_ TcMonad TcSucceeded [u0] [u9, u5, u7]; _ORIG_ Maybes Hamna -> _APP_ _TYAPP_ _TYAPP_ _TYAPP_ _TYAPP_ _TYAPP_ _WRKR_ _ORIG_ TcMonad failTc { (GlobalSwitch -> Bool) } { [UniType] } { SplitUniqSupply } { SrcLoc } { u0 } [ u2, u5, u7 ]; _NO_DEFLT_ } _N_ #-} +checkMaybesTc :: [Labda a] -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a] + {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "SL" _N_ _N_ #-} +checkTc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 8 _U_ 12002020 _N_ _S_ "EL" _N_ _N_ #-} +extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 9 _U_ 222221222 _N_ _N_ _N_ _N_ #-} +failB_Tc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult d + {-# GHC_PRAGMA _A_ 5 _U_ 20020 _N_ _S_ "LAALA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 4 5 XXXXX 6 _/\_ u0 u1 u2 u3 -> \ (u4 :: PprStyle -> Int -> Bool -> PrettyRep) (u5 :: u0) (u6 :: u1) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: u2) -> let {(u9 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ u7, u4 ]} in _!_ _ORIG_ TcMonad BabyTcFailed [u3] [u9] _N_ #-} +failTc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Subst -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> TcResult e + {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _S_ "LAALALA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 5 7 XXXXXXX 7 _/\_ u0 u1 u2 u3 u4 -> \ (u5 :: PprStyle -> Int -> Bool -> PrettyRep) (u6 :: u0) (u7 :: u1) (u8 :: Subst) (u9 :: u2) (ua :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (ub :: u3) -> let {(uc :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ ua, u5 ]} in _!_ _ORIG_ TcMonad TcFailed [u4] [u8, uc] _N_ #-} +fixB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a + {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _S_ "SLLLL" _N_ _N_ #-} +fixNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _S_ "SLLLLLL" _N_ _N_ #-} +fixTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _S_ "SLLLLLL" _N_ _N_ #-} +foldlTc :: (b -> a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> b -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b + {-# GHC_PRAGMA _A_ 3 _U_ 221222222 _N_ _S_ "LLS" _N_ _N_ #-} +getDefaultingTys :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 022020 _N_ _S_ "ALLALA" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: [UniType]) (u1 :: Subst) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_3 [[UniType], Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _TUP_3 [[UniType], Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u2, u4] _N_ #-} +getSUnique :: SplitUniqSupply -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getSUniques :: Int -> SplitUniqSupply -> [Unique] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)L" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSrcLocB_Tc :: a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult c + {-# GHC_PRAGMA _A_ 4 _U_ 0022 _N_ _S_ "AALL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 3 2 XX 3 _/\_ u0 u1 u2 -> \ (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: u2) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [u2] [u4, u3] _N_} _F_ _IF_ARGS_ 3 4 XXXX 3 _/\_ u0 u1 u2 -> \ (u3 :: u0) (u4 :: u1) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: u2) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [u2] [u6, u5] _N_ #-} +getSrcLocTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (SrcLoc, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 002022 _N_ _S_ "AALALL" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: Subst) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u2 :: SrcLoc) -> _!_ _TUP_3 [SrcLoc, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u2, u0, u1] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _TUP_3 [SrcLoc, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u5, u2, u4] _N_ #-} +getSwitchCheckerB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (GlobalSwitch -> Bool) + {-# GHC_PRAGMA _A_ 4 _U_ 2020 _N_ _S_ "LALA" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [(GlobalSwitch -> Bool)] [u0, u1] _N_} _F_ _IF_ARGS_ 0 4 XXXX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: SplitUniqSupply) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u3 :: SrcLoc) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [(GlobalSwitch -> Bool)] [u0, u2] _N_ #-} +getSwitchCheckerTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (GlobalSwitch -> Bool, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 202020 _N_ _S_ "LALALA" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: Subst) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_3 [(GlobalSwitch -> Bool), Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _TUP_3 [(GlobalSwitch -> Bool), Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u2, u4] _N_ #-} +getTyVarUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 001020 _N_ _S_ "AALALA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getTyVarUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1001020 _N_ _S_ "LAALALA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getUniqueB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult Unique + {-# GHC_PRAGMA _A_ 4 _U_ 0120 _N_ _S_ "ALLA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 4 XCXX 8 \ (u0 :: GlobalSwitch -> Bool) (u1 :: SplitUniqSupply) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u3 :: SrcLoc) -> let {(u8 :: Unique) = case u1 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u4 :: Int) (u5 :: SplitUniqSupply) (u6 :: SplitUniqSupply) -> case u4 of { _ALG_ I# (u7 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u7]; _NO_DEFLT_ }; _NO_DEFLT_ }} in _!_ _ORIG_ TcMonad BabyTcSucceeded [Unique] [u8, u2] _N_ #-} +getUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 002120 _N_ _S_ "AALLLA" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 6 XXXCXX 9 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> let {(ua :: Unique) = case u3 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u9]; _NO_DEFLT_ }; _NO_DEFLT_ }} in _!_ _TUP_3 [Unique, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [ua, u2, u4] _N_ #-} +getUniquesB_Tc :: Int -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [Unique] + {-# GHC_PRAGMA _A_ 5 _U_ 10220 _N_ _S_ "LALLA" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 5 CXXXX 8 \ (u0 :: Int) (u1 :: GlobalSwitch -> Bool) (u2 :: SplitUniqSupply) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: SrcLoc) -> let {(u6 :: [Unique]) = case u0 of { _ALG_ I# (u5 :: Int#) -> _APP_ _WRKR_ _ORIG_ SplitUniq getSUniques [ u5, u2 ]; _NO_DEFLT_ }} in _!_ _ORIG_ TcMonad BabyTcSucceeded [[Unique]] [u6, u3] _N_ #-} +getUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1002220 _N_ _S_ "LAALLLA" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 CXXXXXX 9 \ (u0 :: Int) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> let {(u8 :: [Unique]) = case u0 of { _ALG_ I# (u7 :: Int#) -> _APP_ _WRKR_ _ORIG_ SplitUniq getSUniques [ u7, u4 ]; _NO_DEFLT_ }} in _!_ _TUP_3 [[Unique], Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u3, u5] _N_ #-} +initTc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> MaybeErr a (Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +listNF_Tc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([a], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SLLLLLL" _N_ _N_ #-} +listTc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a] + {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SLLLLLL" _N_ _N_ #-} +lookupInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, [Inst]) + {-# GHC_PRAGMA _A_ 7 _U_ 2002220 _N_ _S_ "SAALLLA" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupNoBindInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [Inst] + {-# GHC_PRAGMA _A_ 7 _U_ 2002120 _N_ _S_ "SAALLLA" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mapAndUnzipTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (b, c)) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([b], [c]) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +mapB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [b] + {-# GHC_PRAGMA _A_ 2 _U_ 212222 _N_ _S_ "LS" _N_ _N_ #-} +mapNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (b, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([b], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +mapTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [b] + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +noFailTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 1222222 _N_ _S_ "SLLLLLL" _N_ _N_ #-} +pruneSubstTc :: [TyVar] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 8 _U_ 01222222 _N_ _S_ "ASLLLLLL" {_A_ 7 _U_ 1222222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u2 :: GlobalSwitch -> Bool) (u3 :: [UniType]) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _APP_ u1 [ u2, u3, u4, u5, u6, u7 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: [TyVar]) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u6, u7, u8 ] _N_ #-} +recoverIgnoreErrorsB_Tc :: e -> (b -> c -> Bag a -> d -> Baby_TcResult e) -> b -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> Baby_TcResult e + {-# GHC_PRAGMA _A_ 6 _U_ 112222 _N_ _N_ _N_ _N_ #-} +recoverQuietlyTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 21221222 _N_ _N_ _N_ _N_ #-} +recoverTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 21221222 _N_ _S_ "LSLLLLLL" _N_ _N_ #-} +returnB_Tc :: a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a + {-# GHC_PRAGMA _A_ 5 _U_ 20020 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [u0] [u1, u4] _N_ #-} +returnNF_Tc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: [UniType]) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _!_ _TUP_3 [u0, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u4, u6] _N_ #-} +returnTc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: [UniType]) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _!_ _ORIG_ TcMonad TcSucceeded [u0] [u1, u4, u6] _N_ #-} +rn4MtoTcM :: (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((a, Bag (PprStyle -> Int -> Bool -> PrettyRep)), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 21202220 _N_ _S_ "LLLALLLA" {_A_ 6 _U_ 212222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +setDefaultingTys :: [UniType] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a + {-# GHC_PRAGMA _A_ 8 _U_ 21202222 _N_ _S_ "LSLALLLL" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: [UniType]) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _APP_ u2 [ u3, u1, u4, u5, u6, u7 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: [UniType]) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u1, u5, u6, u7, u8 ] _N_ #-} +splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-} +applySubstToThetaTy :: Subst -> [(Class, UniType)] -> (Subst, [(Class, UniType)]) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +applySubstToTy :: Subst -> UniType -> (Subst, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +applySubstToTyVar :: Subst -> TyVar -> (Subst, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +mkUniqueGrimily :: Int# -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-} +thenB_Tc :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b + {-# GHC_PRAGMA _A_ 6 _U_ 112122 _N_ _S_ "SLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u0) (u3 :: u0 -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u1) (u4 :: GlobalSwitch -> Bool) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> case u5 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u8 :: Int) (u9 :: SplitUniqSupply) (ua :: SplitUniqSupply) -> case _APP_ u2 [ u4, u9, u6, u7 ] of { _ALG_ _ORIG_ TcMonad BabyTcFailed (ub :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad BabyTcFailed [u1] [ub]; _ORIG_ TcMonad BabyTcSucceeded (uc :: u0) (ud :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ uc, u4, ua, ud, u7 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +thenB_Tc_ :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b + {-# GHC_PRAGMA _A_ 6 _U_ 112122 _N_ _S_ "SLLU(ALL)LL" _N_ _N_ #-} +thenNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b + {-# GHC_PRAGMA _A_ 8 _U_ 11222122 _N_ _S_ "SSLLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (u0, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: u0 -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> u1) (u4 :: GlobalSwitch -> Bool) (u5 :: [UniType]) (u6 :: Subst) (u7 :: SplitUniqSupply) (u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u9 :: SrcLoc) -> case u7 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, ub, u8, u9 ] of { _ALG_ _TUP_3 (ud :: u0) (ue :: Subst) (uf :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ ud, u4, u5, ue, uc, uf, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +thenTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b + {-# GHC_PRAGMA _A_ 8 _U_ 11222122 _N_ _S_ "SLLLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: u0 -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u1) (u4 :: GlobalSwitch -> Bool) (u5 :: [UniType]) (u6 :: Subst) (u7 :: SplitUniqSupply) (u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u9 :: SrcLoc) -> case u7 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, ub, u8, u9 ] of { _ALG_ _ORIG_ TcMonad TcFailed (ud :: Subst) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad TcFailed [u1] [ud, ue]; _ORIG_ TcMonad TcSucceeded (uf :: u0) (ug :: Subst) (uh :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ uf, u4, u5, ug, uc, uh, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +thenTc_ :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b + {-# GHC_PRAGMA _A_ 8 _U_ 11222122 _N_ _S_ "SLLLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u1) (u4 :: GlobalSwitch -> Bool) (u5 :: [UniType]) (u6 :: Subst) (u7 :: SplitUniqSupply) (u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u9 :: SrcLoc) -> case u7 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, ub, u8, u9 ] of { _ALG_ _ORIG_ TcMonad TcFailed (ud :: Subst) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad TcFailed [u1] [ud, ue]; _ORIG_ TcMonad TcSucceeded (uf :: u0) (ug :: Subst) (uh :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ u4, u5, ug, uc, uh, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +uniqSMtoBabyTcM :: (SplitUniqSupply -> a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a + {-# GHC_PRAGMA _A_ 5 _U_ 10220 _N_ _S_ "LALLA" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 6 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: SplitUniqSupply) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> let {(u4 :: u0) = _APP_ u1 [ u2 ]} in _!_ _ORIG_ TcMonad BabyTcSucceeded [u0] [u4, u3] _N_} _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: GlobalSwitch -> Bool) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> let {(u6 :: u0) = _APP_ u1 [ u3 ]} in _!_ _ORIG_ TcMonad BabyTcSucceeded [u0] [u6, u4] _N_ #-} + diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs new file mode 100644 index 0000000..48cc7d9 --- /dev/null +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -0,0 +1,718 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcMonad]{@TcMonad@: monad machinery for the typechecker} + +\begin{code} +#include "HsVersions.h" + +module TcMonad ( + TcM(..), TcResult{-abstract-}, + thenTc, thenTc_, returnTc, failTc, checkTc, + listTc, mapTc, mapAndUnzipTc, + fixTc, foldlTc, initTc, + recoverTc, recoverQuietlyTc, + + NF_TcM(..), + thenNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc, + fixNF_Tc, noFailTc, + + Baby_TcM(..), Baby_TcResult{-abstract-}, + returnB_Tc, thenB_Tc, thenB_Tc_, + failB_Tc, recoverIgnoreErrorsB_Tc, + fixB_Tc, mapB_Tc, + babyTcMtoTcM, babyTcMtoNF_TcM, + getUniqueB_Tc, getUniquesB_Tc, + addSrcLocB_Tc, getSrcLocB_Tc, + getSwitchCheckerB_Tc, checkB_Tc, + uniqSMtoBabyTcM, + + getSwitchCheckerTc, + getDefaultingTys, setDefaultingTys, + getUniquesTc, getUniqueTc, + rn4MtoTcM, + + getTyVarUniquesTc, getTyVarUniqueTc, + + applyTcSubstToTy, applyTcSubstToTys, +--UNUSED: applyTcSubstToThetaTy, + applyTcSubstToTyVar, applyTcSubstToTyVars, + applyTcSubstToId, + applyTcSubstToInst, applyTcSubstToInsts, + extendSubstTc, pruneSubstTc, + + addSrcLocTc, getSrcLocTc, + checkMaybeTc, checkMaybesTc, + checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc, + + lookupInst_Tc, lookupNoBindInst_Tc, + + -- and to make the interface self-sufficient ... + UniqueSupply, SplitUniqSupply, + Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..), + PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon, + Class, UniType, TauType(..), ThetaType(..), SigmaType(..), + UnifyErrContext, Unique, Expr, + TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst, + GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..), + GlobalNameFun(..), Name, ProtoName + + IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques) + IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily) + IF_ATTACK_PRAGMAS(COMMA applySubstToId) + IF_ATTACK_PRAGMAS(COMMA applySubstToInst) + IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy) + IF_ATTACK_PRAGMAS(COMMA applySubstToTy) + IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar) + ) where + +import AbsSyn +import AbsUniType ( TyVar, TyVarTemplate, TyCon, Class, UniType, + TauType(..), ThetaType(..), SigmaType(..) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Bag ( Bag, snocBag, emptyBag, isEmptyBag ) +import CmdLineOpts ( GlobalSwitch ) +import Errors ( noInstanceErr, unifyErr, pprBagOfErrors, + Error(..), UnifyErrInfo(..), UnifyErrContext(..) + ) +import FiniteMap ( emptyFM, FiniteMap ) +import Id ( applySubstToId ) +import Inst ( applySubstToInst ) +import InstEnv ( lookupInst, lookupNoBindInst, Inst ) +import Maybes ( Maybe(..), MaybeErr(..) ) +import Pretty +import RenameMonad4 ( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) ) +import SrcLoc ( mkUnknownSrcLoc ) +import Subst +import Unify +import SplitUniq +import Unique +import Util + +infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc` +\end{code} + +%************************************************************************ +%* * +\subsection[TcM-TcM]{Plain @TcM@ monadery} +%* * +%************************************************************************ + +The following @TcM@ is of the garden variety which can fail, and does +as soon as possible. + +\begin{code} +-- internal use only... +type InTcM output + = (GlobalSwitch -> Bool) -- so we can chk cmd-line switches + -> [UniType] -- types used for defaulting; down only + -> Subst -- substitution; threaded + -> SplitUniqSupply -- threaded + -> Bag Error -- threaded + -> SrcLoc -- only passed downwards + -> output + +data TcResult result + = TcSucceeded result + Subst + (Bag Error) + | TcFailed Subst + (Bag Error) + +type TcM result + = InTcM (TcResult result) + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenTc #-} +{-# INLINE thenTc_ #-} +{-# INLINE returnTc #-} +#endif + +thenTc :: TcM a -> (a -> TcM b) -> TcM b +thenTc_ :: TcM a -> TcM b -> TcM b + +thenTc expr cont sw_chkr dtys subst us errs src_loc + = case splitUniqSupply us of { (s1, s2) -> + case (expr sw_chkr dtys subst s1 errs src_loc) of + TcFailed subst errs -> TcFailed subst errs + TcSucceeded result subst2 errs2 + -> cont result sw_chkr dtys subst2 s2 errs2 src_loc + } + +thenTc_ expr cont sw_chkr dtys subst us errs src_loc + = case splitUniqSupply us of { (s1, s2) -> + case (expr sw_chkr dtys subst s1 errs src_loc) of + TcFailed subst errs -> TcFailed subst errs + TcSucceeded _ subst2 errs2 + -> cont sw_chkr dtys subst2 s2 errs2 src_loc + } + +returnTc :: a -> TcM a +returnTc result sw_chkr dtys subst us errs src_loc + = TcSucceeded result subst errs + +failTc err sw_chkr dtys subst us errs src_loc + = TcFailed subst (errs `snocBag` err) +\end{code} + +@recoverTc@ recovers from an error, by providing a value to use +instead. It is also lazy, in that it always succeeds immediately; the +thing inside is only even looked at when you pull on the errors, or on +the value returned. + +@recoverQuietlyTc@ doesn't even report the errors found---it is used +when looking at pragmas. + +\begin{code} +recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a + +recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc + = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of + TcSucceeded result subst_out errs_out -> + (result, combineSubstUndos subst_out, errs_out) + + TcFailed subst_out errs_out -> + (use_this_if_err, undoSubstUndos subst_out, errs_out) + -- Note that we return the *undone* substitution + -- and the *incoming* UniqueSupply + +recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc + = (r2, s2, e2) + where + (r2, s2, e2) + = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of + TcSucceeded result subst_out errs_out -> + (result, combineSubstUndos subst_out, errs_out) + + TcFailed subst_out errs_out -> + (use_this_if_err, undoSubstUndos subst_out, errs_in) + -- Note that we return the *undone* substitution, + -- the *incoming* UniqueSupply, and the *incoming* errors +\end{code} + +The following @TcM@ checks a condition and fails with the given error +message. + +\begin{code} +checkTc :: Bool -> Error -> TcM () + +checkTc True err = failTc err +checkTc False err = returnTc () + +listTc :: [TcM a] -> TcM [a] + +listTc [] = returnTc [] +listTc (x:xs) + = x `thenTc` \ r -> + listTc xs `thenTc` \ rs -> + returnTc (r:rs) + +mapTc :: (a -> TcM b) -> [a] -> TcM [b] +mapTc f [] = returnTc [] +mapTc f (x:xs) + = f x `thenTc` \ r -> + mapTc f xs `thenTc` \ rs -> + returnTc (r:rs) + +mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c]) + +mapAndUnzipTc f [] = returnTc ([], []) +mapAndUnzipTc f (x:xs) + = f x `thenTc` \ (r1, r2) -> + mapAndUnzipTc f xs `thenTc` \ (rs1, rs2) -> + returnTc (r1:rs1, r2:rs2) + +foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a +foldlTc f a [] = returnTc a +foldlTc f a (b:bs) = f a b `thenTc` \ a2 -> + foldlTc f a2 bs + +fixTc :: (x -> TcM x) -> TcM x +fixTc m sw_chkr dtys subst us errs src_loc + = lim + where + lim = m result sw_chkr dtys subst us errs src_loc + result = case lim of + TcSucceeded result _ _ -> result +#ifdef DEBUG + TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs) +#endif +\end{code} + +And the machinery to start things up: + +\begin{code} +aRRAY_SIZE :: Int +aRRAY_SIZE = 511 + +initTc :: (GlobalSwitch -> Bool) + -> SplitUniqSupply + -> TcM result + -> MaybeErr result (Bag Error) + +initTc sw_chkr us tc + = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of + TcFailed _ errs -> Failed errs + TcSucceeded result subst2 errs + -> if isEmptyBag errs then + Succeeded result + else + Failed errs + +init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh +\end{code} + + +%************************************************************************ +%* * +\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery} +%* * +%************************************************************************ + +This is a no-fail version of a TcM. + +\begin{code} +-- ToDo: re-order fields to match TcM? +type NF_TcM result = InTcM (result, Subst, Bag Error) + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenNF_Tc #-} +{-# INLINE returnNF_Tc #-} +#endif + +thenNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b +\end{code} + +In particular, @thenNF_Tc@ has all of these types: +\begin{pseudocode} +thenNF_Tc :: NF_TcM a -> (a -> TcM b) -> TcM b +thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b +\end{pseudocode} + +\begin{code} +thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc + = case splitUniqSupply us of { (s1, s2) -> + case (expr sw_chkr dtys subst s1 errs src_loc) of + (result, subst2, errs2) + -> cont result sw_chkr dtys subst2 s2 errs2 src_loc + } + +returnNF_Tc :: a -> NF_TcM a +returnNF_Tc result sw_chkr dtys subst us errs src_loc + = (result, subst, errs) + +listNF_Tc :: [NF_TcM a] -> NF_TcM [a] +listNF_Tc [] = returnNF_Tc [] +listNF_Tc (x:xs) + = x `thenNF_Tc` \ r -> + listNF_Tc xs `thenNF_Tc` \ rs -> + returnNF_Tc (r:rs) + +mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b] +mapNF_Tc f [] = returnNF_Tc [] +mapNF_Tc f (x:xs) + = f x `thenNF_Tc` \ r -> + mapNF_Tc f xs `thenNF_Tc` \ rs -> + returnNF_Tc (r:rs) + +fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a +fixNF_Tc m sw_chkr dtys subst us errs src_loc + = lim + where + lim = m result sw_chkr dtys subst us errs src_loc + (result, _, _) = lim +\end{code} + +@noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}. You use it +when you are darn sure that the TcM won't actually fail! + +\begin{code} +noFailTc :: TcM a -> NF_TcM a + +noFailTc expr sw_chkr dtys subst us errs src_loc + = case (expr sw_chkr dtys subst us errs src_loc) of + TcFailed _ _ -> panic "Failure in noFailTc!" + TcSucceeded result subst errs + -> (result, subst, errs) +\end{code} + +%************************************************************************ +%* * +\subsection[TcM-uniq-extract]{Extractings Uniques from the monad} +%* * +%************************************************************************ + +These functions extract uniques from the monad. There are two unique +supplies embedded in the monad. +\begin{itemize} +\item +normal unique supply +\item +special unique supply for TyVars (these index the substitution) +\end{itemize} + +\begin{code} +getUniquesTc :: Int -> NF_TcM [Unique] +getUniquesTc n sw_chkr dtys subst us errs src_loc + = case (getSUniques n us) of { uniques -> + (uniques, subst, errs) } + +-- This simpler version is often adequate: + +getUniqueTc :: NF_TcM Unique +getUniqueTc sw_chkr dtys subst us errs src_loc + = case (getSUnique us) of { unique -> + (unique, subst, errs) } + +rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error) + +rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc + = let + (rn_result, rn_errs) + = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc + -- laziness may be good for you (see below) + in + ((rn_result, rn_errs), subst, errs) + +-- Special uniques for TyVars extracted from the substitution + +getTyVarUniquesTc :: Int -> NF_TcM [Unique] +getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc + = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc + where + (subst2, uniques) = getSubstTyVarUniques n subst + +getTyVarUniqueTc :: NF_TcM Unique +getTyVarUniqueTc sw_chkr dtys subst us errs src_loc + = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc + where + (subst2, unique) = getSubstTyVarUnique subst +\end{code} + +%************************************************************************ +%* * +\subsection[TcM-extract]{Extractings other things from the monad} +%* * +%************************************************************************ + +These are functions which extract things from the monad. + +Extending and applying the substitution. + +ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in +a number of places where only the sequenced substitution is required. +A lighter weight sequence substitution monad would be more appropriate +with TcMonad interface functions defined here. + +\begin{code} +getTcSubst :: NF_TcM Subst +applyTcSubstToTy :: TauType -> NF_TcM TauType +--UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType +applyTcSubstToTyVar :: TyVar -> NF_TcM TauType +applyTcSubstToId :: Id -> NF_TcM Id +applyTcSubstToInst :: Inst -> NF_TcM Inst + +getTcSubst sw_chkr dtys subst us errs src_loc + = returnNF_Tc subst sw_chkr dtys subst us errs src_loc + +applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc + = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) -> + returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc + } + +{- UNUSED: +applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc + = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) -> + returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc + } +-} + +applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc + = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) -> + returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc + } + +applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc + = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) -> + returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc + } + +applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc + = case (applySubstToInst subst inst) of { (subst2, new_inst) -> + returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc + } + +applyTcSubstToTyVars :: [TyVar] -> NF_TcM [UniType] +applyTcSubstToTys :: [TauType] -> NF_TcM [TauType] + +applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars +applyTcSubstToTys tys = mapNF_Tc applyTcSubstToTy tys +applyTcSubstToInsts insts = mapNF_Tc applyTcSubstToInst insts +\end{code} + +\begin{code} +extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM () + +extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc + = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) -> + case extend_result of + SubstOK -> + TcSucceeded () new_subst errs + + OccursCheck tyvar ty -> + TcFailed new_subst + (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc)) + + AlreadyBound ty1 -> + -- This should only happen in the case of a call to + -- extendSubstTc from the unifier! The way things are now + -- we can't check for the AlreadyBound case in other calls + -- to extendSubstTc, but we're confident it never shows up. + -- Ugh! + unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc + } +\end{code} + + +@pruneSubstTc@ does nothing with an array substitution implementation!!! +\begin{code} +pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept + -> TcM a -- Type-check this + -> TcM a -- Return same result but pruned subst + +pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc + = m sw_chkr dtys subst uniqs errs src_loc +\end{code} + +\begin{code} +getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool) +getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr +\end{code} + +\begin{code} +getDefaultingTys :: NF_TcM [UniType] +getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys + +setDefaultingTys :: [UniType] -> TcM a -> TcM a +setDefaultingTys dtys action sw_chkr _ subst us errs src_loc + = action sw_chkr dtys subst us errs src_loc +\end{code} + +\begin{code} +addSrcLocTc :: SrcLoc -> TcM a -> TcM a +addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc + = expr sw_chkr dtys subst us errs new_locn + +getSrcLocTc :: NF_TcM SrcLoc +getSrcLocTc sw_chkr dtys subst us errs src_loc + = (src_loc, subst, errs) +\end{code} + +%************************************************************************ +%* * +\subsection[TcM-check]{Error-detecting functions} +%* * +%************************************************************************ + +The following TcM checks a Maybe type and fails with the given +error message. + +\begin{code} +checkMaybeTc :: Maybe val -> Error -> TcM val +checkMaybeTc (Just result) err = returnTc result +checkMaybeTc Nothing err = failTc err + +checkMaybesTc :: [Maybe val] -> Error -> TcM [val] +checkMaybesTc [] err = returnTc [] +checkMaybesTc (Nothing:xs) err = failTc err +checkMaybesTc ((Just v):xs) err + = checkMaybesTc xs err `thenTc` \ xs2 -> + returnTc (v:xs2) + +checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val +checkMaybeErrTc (Succeeded result) errfun = returnTc result +checkMaybeErrTc (Failed err) errfun = failTc (errfun err) + +{- UNUSED: +checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val] + +checkMaybeErrsTc [] err_fun = returnTc [] +checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err) +checkMaybeErrsTc ((Succeeded v):xs) err_fun + = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 -> + returnTc (v:xs2) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[TcM-Insts]{Looking up instances} +%* * +%************************************************************************ + +\begin{code} +lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst]) + +lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc + = case (lookupInst uniqs inst) of + Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst)) + + Just (expr, insts) -> TcSucceeded (expr, insts) subst errs + +lookupNoBindInst_Tc :: Inst -> TcM [Inst] + +lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc + = case (lookupNoBindInst uniqs inst) of + Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst)) + + Just insts -> TcSucceeded insts subst errs +\end{code} + + + + + + + +%************************************************************************ +%* * +\subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang} +%* * +%************************************************************************ + +The "baby" Tc monad doesn't pass around the substitution. +That means you can't use it to type-check bindings, but you can use +if for everything else (interfaces, type decls, first pass of class and +instance decls etc). + +Less importantly, it doesn't pass around the list of default decls either. + + +Type declarations +~~~~~~~~~~~~~~~~~ + +\begin{code} +type Baby_TcM result + = (GlobalSwitch -> Bool) + -> SplitUniqSupply + -> Bag Error -- threaded + -> SrcLoc -- only passed downwards + -> Baby_TcResult result + +data Baby_TcResult result + = BabyTcFailed (Bag Error) + + | BabyTcSucceeded result (Bag Error) +\end{code} + + +Standard plumbing +~~~~~~~~~~~~~~~~~ + +\begin{code} +thenB_Tc :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b +returnB_Tc :: a -> Baby_TcM a + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE thenB_Tc #-} +{-# INLINE returnB_Tc #-} +#endif + +thenB_Tc a b sw us errs loc + = case (splitUniqSupply us) of { (s1, s2) -> + case (a sw s1 errs loc) of + BabyTcFailed errs2 -> BabyTcFailed errs2 + BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc + } + +returnB_Tc result sw us errs loc = BabyTcSucceeded result errs +failB_Tc err sw us errs loc = BabyTcFailed (errs `snocBag` err) + +recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc + = BabyTcSucceeded result errs + where + result = case try_this sw us emptyBag loc of + BabyTcSucceeded result errs_from_branch -> result + BabyTcFailed errs_from_branch -> return_on_failure + +fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a +fixB_Tc k sw us errs loc + = result + where + result = k val sw us errs loc + val = case result of + BabyTcSucceeded val errs -> val + BabyTcFailed errs -> panic "fixB_Tc failed" + +babyTcMtoTcM :: Baby_TcM a -> TcM a +babyTcMtoTcM m sw_chkr dtys subst us errs src_loc + = case m sw_chkr us errs src_loc of + BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2 + BabyTcFailed errs2 -> TcFailed subst errs2 + +babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a +babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc + = case m sw_chkr us errs src_loc of + BabyTcSucceeded result errs2 -> (result, subst, errs2) + BabyTcFailed errs2 -> panic "babyTcMtoNF_TcM" +\end{code} + +\begin{code} +uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a + +uniqSMtoBabyTcM u_action sw us errs loc + = let + u_result = u_action us + -- at least one use *needs* this laziness + in + BabyTcSucceeded u_result errs +\end{code} + +\begin{code} +thenB_Tc_ m k = m `thenB_Tc` \ _ -> + k + +mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b] +mapB_Tc f [] = returnB_Tc [] +mapB_Tc f (x:xs) = f x `thenB_Tc` \ fx -> + mapB_Tc f xs `thenB_Tc` \ fxs -> + returnB_Tc (fx:fxs) +\end{code} + + +Primitives +~~~~~~~~~~ + +\begin{code} +getUniqueB_Tc :: Baby_TcM Unique +getUniquesB_Tc :: Int -> Baby_TcM [Unique] + +getUniqueB_Tc sw us errs loc + = case (getSUnique us) of { unique -> + BabyTcSucceeded unique errs } + +getUniquesB_Tc n sw us errs loc + = case (getSUniques n us) of { uniques -> + BabyTcSucceeded uniques errs } + +addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a +addSrcLocB_Tc new_locn m sw us errs loc + = m sw us errs new_locn + +getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs + +getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool) +getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs +\end{code} + + +Useful functions +~~~~~~~~~~~~~~~~ + +\begin{code} +checkB_Tc :: Bool -> Error -> Baby_TcM () + +checkB_Tc True err = failB_Tc err +checkB_Tc False err = returnB_Tc () +\end{code} diff --git a/ghc/compiler/typecheck/TcMonadFns.hi b/ghc/compiler/typecheck/TcMonadFns.hi new file mode 100644 index 0000000..301a099 --- /dev/null +++ b/ghc/compiler/typecheck/TcMonadFns.hi @@ -0,0 +1,95 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcMonadFns where +import Bag(Bag) +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import ErrUtils(Error(..)) +import ErrsTc(UnifyErrContext) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsExpr(ArithSeqInfo, Expr) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat, TypecheckedPat) +import Id(Id, IdDetails) +import IdInfo(IdInfo, SpecEnv, SpecInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import InstEnv(InstTemplate) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludeGlaST(_MutableArray) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique, UniqueSupply) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data UnifyErrContext + {-# GHC_PRAGMA PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-} +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-} +data OverloadedLit {-# GHC_PRAGMA OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-} +data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +applyTcSubstAndCollectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222122 _N_ _S_ "S" _N_ _N_ #-} +applyTcSubstAndExpectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 1222122 _N_ _S_ "S" _N_ _N_ #-} +copyTyVars :: [TyVarTemplate] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([(TyVarTemplate, UniType)], [TyVar], [UniType]), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-} +mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> [(Name, Id)] + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "SSL" _N_ _N_ #-} +mkIdsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-} +mkIdsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-} +newClassOpLocals :: [(TyVarTemplate, UniType)] -> [ClassOp] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22002122 _N_ _S_ "LLAALU(AAS)LL" {_A_ 6 _U_ 222122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newDict :: InstOrigin -> Class -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newDicts :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22002120 _N_ _S_ "LLAALU(ALA)LA" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newLocalWithGivenTy :: Name -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 8 _U_ 22002120 _N_ _S_ "LLAALU(ALA)LA" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newLocalsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-} +newLocalsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-} +newMethod :: InstOrigin -> Id -> [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newOpenTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 002120 _N_ _S_ "AALU(AAA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newPolyTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 6 _U_ 002120 _N_ _S_ "AALU(AAA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newPolyTyVarTys :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 7 _U_ 2002120 _N_ _S_ "LAALU(AAA)LA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newSpecId :: Id -> [Labda UniType] -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +newSpecPragmaId :: Name -> UniType -> Labda SpecInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcMonadFns.lhs b/ghc/compiler/typecheck/TcMonadFns.lhs new file mode 100644 index 0000000..32c8044 --- /dev/null +++ b/ghc/compiler/typecheck/TcMonadFns.lhs @@ -0,0 +1,243 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcMonadFns]{Auxilliary functions for typechecker monad} + +\begin{code} +#include "HsVersions.h" + +module TcMonadFns ( + newDict, newDicts, newMethod, newOverloadedLit, + + copyTyVars, + newOpenTyVarTy, newPolyTyVarTy, + newPolyTyVarTys, + +--UNUSED: newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy, + newLocalWithGivenTy, + newSpecPragmaId, newSpecId, + newClassOpLocals, + newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys, + + mkIdsWithOpenTyVarTys, mkIdsWithPolyTyVarTys, + mkIdsWithGivenTys, + + applyTcSubstAndCollectTyVars, + applyTcSubstAndExpectTyVars, + + -- and to make the interface self-sufficient... + Bag, Class, Binds, MonoBinds, TypecheckedPat, Id, Inst, SpecInfo, + OverloadedLit, InstOrigin, TcResult, Name, SrcLoc, Subst, Maybe, + Error(..), TyVar, UniType, UnifyErrContext, UniqueSupply, + PprStyle, Pretty(..), PrettyRep + ) where + +import TcMonad -- the underlying monadery +import AbsSyn + +import AbsUniType +import Id ( mkId, mkUserLocal, mkSpecPragmaId, mkSpecId, Id, DictVar(..) ) +import IdInfo +import Inst ( mkDict, mkMethod, mkLitInst, + Inst(..), -- .. for pragmas + OverloadedLit, InstOrigin + ) +import Maybes ( Maybe(..) ) +import E ( LVE(..) ) +import Errors ( Error(..), UnifyErrInfo ) +import Unique ( Unique, UniqueSupply ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[TcMonadFns-newNameThings]{Making new things from the name supply} +%* * +%************************************************************************ + +@newPolyTyVars@ takes list of ``old'' template type vars, and manufactures +a list of freshly-uniqued type vars. + +\begin{code} +copyTyVars :: [TyVarTemplate] -- Old type vars + -> NF_TcM + ([(TyVarTemplate,TauType)],--Old-to-new assoc list + [TyVar], -- New type vars + [TauType]) -- New type vars wrapped in a UniTyVar + +copyTyVars old_tyvars + = getTyVarUniquesTc (length old_tyvars) `thenNF_Tc` \ new_uniqs -> + returnNF_Tc (instantiateTyVarTemplates old_tyvars new_uniqs) + +newOpenTyVarTys :: Int -> NF_TcM [UniType] +newOpenTyVarTys n + = getTyVarUniquesTc n `thenNF_Tc` \ new_uniqs -> + returnNF_Tc [mkTyVarTy (mkOpenSysTyVar u) | u <- new_uniqs] + +newPolyTyVarTys :: Int -> NF_TcM [UniType] +newPolyTyVarTys n + = getTyVarUniquesTc n `thenNF_Tc` \ new_uniqs -> + returnNF_Tc [mkTyVarTy (mkPolySysTyVar u) | u <- new_uniqs] + +newOpenTyVarTy, newPolyTyVarTy :: NF_TcM UniType +newOpenTyVarTy + = getTyVarUniqueTc `thenNF_Tc` \ new_uniq -> + returnNF_Tc (mkTyVarTy (mkOpenSysTyVar new_uniq)) + +newPolyTyVarTy + = getTyVarUniqueTc `thenNF_Tc` \ new_uniq -> + returnNF_Tc (mkTyVarTy (mkPolySysTyVar new_uniq)) +\end{code} + +The functions @newDicts@, @newMethod@, and @newOverloadedLit@ build +new @Inst@s. + +\begin{code} +newDicts :: InstOrigin -> ThetaType -> NF_TcM [Inst] +newDicts orig theta + = getUniquesTc (length theta) `thenNF_Tc` \ new_uniqs -> + returnNF_Tc (zipWith mk_dict_var new_uniqs theta) + where + mk_dict_var u (clas, ty) = mkDict u clas ty orig + +newDict :: InstOrigin -> Class -> UniType -> NF_TcM Inst +newDict orig clas ty + = getUniqueTc `thenNF_Tc` \ new_uniq -> + returnNF_Tc (mkDict new_uniq clas ty orig) + +newMethod :: InstOrigin -> Id -> [UniType] -> NF_TcM Inst +newMethod orig id tys + = getUniqueTc `thenNF_Tc` \ new_uniq -> + returnNF_Tc (mkMethod new_uniq id tys orig) + +newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> NF_TcM Inst +newOverloadedLit orig lit ty + = getUniqueTc `thenNF_Tc` \ new_uniq -> + returnNF_Tc (mkLitInst new_uniq lit ty orig) +\end{code} + +Make a fresh batch of locals, derived from name, each typed with a fresh +type variable, and return an LVE of them. +\begin{itemize} + +\item @mkIdsWithTyVarTys@ uses the supplied names directly (including their + uniques), and generates a @TopId@ or @Local@ depending on whether + the name is a @FullName@ or not. + +\item @mkIdsWithGivenTys@ does as above, but the types are supplied. +\end{itemize} + +\begin{code} +mkIdsWithPolyTyVarTys, mkIdsWithOpenTyVarTys :: [Name] -> NF_TcM LVE +mkIdsWithPolyTyVarTys names + = let + no_of_names = length names + in + newPolyTyVarTys no_of_names `thenNF_Tc` \ tys -> + returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo)) + +mkIdsWithOpenTyVarTys names + = let + no_of_names = length names + in + newOpenTyVarTys no_of_names `thenNF_Tc` \ tys -> + returnNF_Tc (mkIdsWithGivenTys names tys (nOfThem no_of_names noIdInfo)) + +mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> LVE + -- not monadic any more (WDP 94/05) + -- Not done w/ zips/etc for "efficiency" (?) +mkIdsWithGivenTys [] [] _ = [] +mkIdsWithGivenTys (name:names) (ty:tys) (id_info:id_infos) + = (name, mkId name ty id_info) : mkIdsWithGivenTys names tys id_infos + +newLocalsWithOpenTyVarTys, newLocalsWithPolyTyVarTys :: [Name] -> NF_TcM [Id] +newLocalsWithOpenTyVarTys = new_locals_given_tyvar_fun newOpenTyVarTys +newLocalsWithPolyTyVarTys = new_locals_given_tyvar_fun newPolyTyVarTys + +new_locals_given_tyvar_fun new_tyvar_fun names + = new_tyvar_fun no_of_names `thenNF_Tc` \ tys -> + getUniquesTc no_of_names `thenNF_Tc` \ uniqs -> + let ids = zipWith3 mk_local names uniqs tys in + returnNF_Tc ids + where + no_of_names = length names + mk_local name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty + (getSrcLoc name) +\end{code} + +@newLocal*@ creates a new unique local variable with the given +string and type. @newLocals@ is similar, but works on lists of strings +and types. + +\begin{code} +{- UNUSED: +newLocalWithOpenTyVarTy, newLocalWithPolyTyVarTy :: Name -> NF_TcM Id + +newLocalWithOpenTyVarTy name + = newOpenTyVarTy `thenNF_Tc` \ ty -> + newLocalWithGivenTy name ty + +newLocalWithPolyTyVarTy name + = newPolyTyVarTy `thenNF_Tc` \ ty -> + newLocalWithGivenTy name ty +-} + +newLocalWithGivenTy :: Name -> UniType -> NF_TcM Id +newLocalWithGivenTy name ty + = getUniqueTc `thenNF_Tc` \ uniq -> + returnNF_Tc (mkUserLocal (getOccurrenceName name) uniq ty (getSrcLoc name)) + +newSpecPragmaId :: Name -> UniType -> Maybe SpecInfo -> NF_TcM Id +newSpecPragmaId name ty specinfo + = getUniqueTc `thenNF_Tc` \ uniq -> + returnNF_Tc (mkSpecPragmaId (getOccurrenceName name) uniq ty specinfo (getSrcLoc name)) + +newSpecId :: Id -> [Maybe UniType] -> UniType -> NF_TcM Id +newSpecId unspec spec_tys ty + = getUniqueTc `thenNF_Tc` \ uniq -> + returnNF_Tc (mkSpecId uniq unspec spec_tys ty noIdInfo) +\end{code} + +ToDo: This @newClassOpLocals@ is used only to make new ClassOps. Pretty yukky. + +\begin{code} +newClassOpLocals :: [(TyVarTemplate, TauType)] + -- The class type variable mapped to + -- the instance type (an InstTyEnv) + -> [ClassOp] -- The class ops + -> NF_TcM [Id] -- Suitable Ids for the polymorphic + -- methods +newClassOpLocals inst_env ops + = getSrcLocTc `thenNF_Tc` \ src_loc -> + getUniquesTc (length ops) `thenNF_Tc` \ uniqs -> + returnNF_Tc (zipWith (new_local src_loc) ops uniqs) + where + new_local src_loc op uniq + = mkUserLocal (getClassOpString op) + uniq + (instantiateTy inst_env (getClassOpLocalType op)) + src_loc +\end{code} + +%************************************************************************ +%* * +Back-substitution functions. These just apply the current +substitution to their argument(s). +%* * +%************************************************************************ + +@applyTcSubstAndCollectTyVars@ applies a substitution to a list of type +variables, takes the free type vars of the resulting types, and +returns all of them as list without duplications. + +\begin{code} +applyTcSubstAndCollectTyVars :: [TyVar] -> NF_TcM [TyVar] +applyTcSubstAndCollectTyVars tyvars + = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (extractTyVarsFromTys tys) + +applyTcSubstAndExpectTyVars :: [TyVar] -> NF_TcM [TyVar] +applyTcSubstAndExpectTyVars tyvars + = applyTcSubstToTyVars tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (map (getTyVar "applyTcSubstAndExpectTyVars") tys) +\end{code} diff --git a/ghc/compiler/typecheck/TcMonoBnds.hi b/ghc/compiler/typecheck/TcMonoBnds.hi new file mode 100644 index 0000000..abe09ba --- /dev/null +++ b/ghc/compiler/typecheck/TcMonoBnds.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcMonoBnds where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsBinds(MonoBinds) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcMonoBinds :: E -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (MonoBinds Id TypecheckedPat, LIE) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcMonoBnds.lhs b/ghc/compiler/typecheck/TcMonoBnds.lhs new file mode 100644 index 0000000..c5bb5ba --- /dev/null +++ b/ghc/compiler/typecheck/TcMonoBnds.lhs @@ -0,0 +1,130 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcMonoBinds]{TcMonoBinds} + +\begin{code} +#include "HsVersions.h" + +module TcMonoBnds ( tcMonoBinds ) where + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( mkPrimIoTy, unitTy, mkListTy, mkFunTy ) +import AbsUniType ( applyNonSynTyCon, applySynTyCon ) +import CmdLineOpts ( GlobalSwitch(..) ) +import E ( growE_LVE, lookupE_Binder, getE_TCE, E, GVE(..), LVE(..) ) +#if USE_ATTACK_PRAGMAS +import CE +#endif +import TCE +import Errors ( UnifyErrContext(..) ) -- notably PatMonoBindsCtxt +import Id ( getIdUniType, Id ) +import LIE ( nullLIE, plusLIE, LIE ) +import NameTypes ( FullName ) +import TcGRHSs ( tcGRHSsAndBinds ) +import TcMatches ( tcMatchesFun ) +import TcPat ( tcPat ) +import Unify ( unifyTauTy ) +import Unique ( dialogueTyConKey, iOTyConKey ) +import Util +\end{code} + +\begin{code} +tcMonoBinds :: E -> RenamedMonoBinds -> TcM (TypecheckedMonoBinds, LIE) + +tcMonoBinds e EmptyMonoBinds = returnTc (EmptyMonoBinds, nullLIE) + +tcMonoBinds e (AndMonoBinds mb1 mb2) + = tcMonoBinds e mb1 `thenTc` \ (mb1a, lie1) -> + tcMonoBinds e mb2 `thenTc` \ (mb2a, lie2) -> + returnTc (AndMonoBinds mb1a mb2a, plusLIE lie1 lie2) + +tcMonoBinds e (PatMonoBind pat grhss_and_binds locn) + -- much like tcMatches of GRHSMatch + = addSrcLocTc locn ( + + -- LEFT HAND SIDE + tcPat e pat `thenTc` \ (pat2, lie_pat, pat_ty) -> + + -- BINDINGS AND THEN GRHSS + tcGRHSsAndBinds e grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) -> + + unifyTauTy pat_ty grhss_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_` + + (case pat of + VarPatIn fun -> chk_main_or_mainIOish_type e fun pat_ty + _ -> returnTc (panic "chk_main_or_mainIOish_type (pat)") + ) `thenTc_` + + -- Check for primitive types in the pattern (no can do) +{- does not work here + checkTc (any_con_w_prim_arg pat2) + (error "Can't have primitive type in a pattern binding") `thenTc_` +-} + + -- RETURN + returnTc (PatMonoBind pat2 grhss_and_binds2 locn, + plusLIE lie_pat lie) + ) + +tcMonoBinds e (FunMonoBind name matches locn) + = addSrcLocTc locn ( + let id = lookupE_Binder e name in + + tcMatchesFun e name (getIdUniType id) matches `thenTc` \ (matches', lie) -> + + chk_main_or_mainIOish_type e name (getIdUniType id) `thenTc_` + + returnTc (FunMonoBind id matches' locn, lie) + ) + +chk_main_or_mainIOish_type :: E -> Name -> UniType -> TcM () + + -- profoundly ugly checking that ... + -- Main.main :: Dialogue -- Haskell 1.2 + -- Main.main :: IO () -- Haskell 1.3 + -- Main.mainPrimIO :: PrimIO () -- Glasgow extension + +chk_main_or_mainIOish_type e name chk_ty + = getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> + let + tce = getE_TCE e + haskell_1_3 = sw_chkr Haskell_1_3 + +{-OLD: response_tc = lookupTCE tce (PreludeTyCon responseTyConKey bottom 0 True) + request_tc = lookupTCE tce (PreludeTyCon requestTyConKey bottom 0 True) + response_ty = applyNonSynTyCon response_tc [] + request_ty = applyNonSynTyCon request_tc [] + dialogue_ty = (mkListTy response_ty) `mkFunTy` (mkListTy request_ty) +-} + dialogue_tc = lookupTCE tce (PreludeTyCon dialogueTyConKey bottom 0 False) + dialogue_ty = applySynTyCon dialogue_tc [] + + io_tc = lookupTCE tce (PreludeTyCon iOTyConKey bottom 1 False) + io_tup0_ty = applySynTyCon io_tc [unitTy] + + bottom = panic "chk_main_or..." + in + if is_a_particular_thing SLIT("Main") SLIT("main") name then + if haskell_1_3 then + unifyTauTy io_tup0_ty chk_ty (MatchCtxt io_tup0_ty chk_ty) + else + unifyTauTy dialogue_ty chk_ty (MatchCtxt dialogue_ty chk_ty) + + else if is_a_particular_thing SLIT("Main") SLIT("mainPrimIO") name then + let + ioprim_ty = mkPrimIoTy unitTy + in + unifyTauTy ioprim_ty chk_ty (MatchCtxt ioprim_ty chk_ty) + else + returnTc bottom + where + is_a_particular_thing :: FAST_STRING -> FAST_STRING -> Name -> Bool + + is_a_particular_thing mod_wanted nm_wanted (OtherTopId _ full_name) + = let (mod, nm) = getOrigName full_name + in mod == mod_wanted && nm == nm_wanted + is_a_particular_thing _ _ _ = False +\end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.hi b/ghc/compiler/typecheck/TcMonoType.hi new file mode 100644 index 0000000..deb19fa --- /dev/null +++ b/ghc/compiler/typecheck/TcMonoType.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcMonoType where +import Bag(Bag) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import HsTypes(MonoType) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +tcInstanceType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> Bool -> SrcLoc -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType + {-# GHC_PRAGMA _A_ 6 _U_ 2221212122 _N_ _S_ "LLLLLS" _N_ _N_ #-} +tcMonoType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType + {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs new file mode 100644 index 0000000..9c68a7d --- /dev/null +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -0,0 +1,186 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcMonoType]{Typechecking user-specified @MonoTypes@} + +\begin{code} +#include "HsVersions.h" + +module TcMonoType ( tcMonoType, tcInstanceType ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +#ifndef DPH +import AbsPrel ( mkListTy, mkTupleTy, mkFunTy ) +#else +import AbsPrel ( mkListTy, mkTupleTy, mkFunTy, mkProcessorTy, mkPodTy ) +#endif {- Data Parallel Haskell -} +import AbsUniType ( applySynTyCon, applyNonSynTyCon, mkDictTy, + getTyConArity, isSynTyCon, isTyVarTemplateTy, + getUniDataTyCon_maybe, maybeUnpackFunTy + IF_ATTACK_PRAGMAS(COMMA pprTyCon COMMA pprUniType) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import UniType ( UniType(..) ) -- ******** CHEATING **** could be undone +import TyCon --( TyCon(..) ) -- ditto, only more so + +import CE ( lookupCE, CE(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Errors ( confusedNameErr, tyConArityErr, instTypeErr, + Error(..) + ) +import Maybes ( Maybe(..) ) +import TcPolyType ( tcPolyType ) +import TCE ( lookupTCE, TCE(..), UniqFM ) +import TVE ( lookupTVE, TVE(..) ) +import Util +\end{code} + +\begin{code} +tcMonoType :: CE -> TCE -> TVE -> RenamedMonoType -> Baby_TcM UniType + +tcMonoType rec_ce rec_tce tve (MonoTyVar name) + = returnB_Tc (lookupTVE tve name) + +tcMonoType rec_ce rec_tce tve (ListMonoTy ty) + = tcMonoType rec_ce rec_tce tve ty `thenB_Tc` \ tau_ty -> + returnB_Tc (mkListTy tau_ty) + +tcMonoType rec_ce rec_tce tve (TupleMonoTy tys) + = mapB_Tc (tcPolyType rec_ce rec_tce tve) tys `thenB_Tc` \ tau_tys -> + returnB_Tc (mkTupleTy (length tau_tys) tau_tys) + +tcMonoType rec_ce rec_tce tve (FunMonoTy ty1 ty2) + = tcMonoType rec_ce rec_tce tve ty1 `thenB_Tc` \ tau_ty1 -> + tcMonoType rec_ce rec_tce tve ty2 `thenB_Tc` \ tau_ty2 -> + returnB_Tc (mkFunTy tau_ty1 tau_ty2) + +tcMonoType rec_ce rec_tce tve (MonoTyCon name@(WiredInTyCon tycon) tys) + = let + arity = getTyConArity tycon + is_syn_tycon = isSynTyCon tycon + in + tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys + +tcMonoType rec_ce rec_tce tve (MonoTyCon name@(PreludeTyCon _ _ arity is_data_tycon) tys) + = tcMonoType_help rec_ce rec_tce tve name + (lookupTCE rec_tce name) + arity (not is_data_tycon) tys + + +tcMonoType rec_ce rec_tce tve (MonoTyCon name@(OtherTyCon _ _ arity is_data_tycon _) tys) + = tcMonoType_help rec_ce rec_tce tve name + (lookupTCE rec_tce name) + arity (not is_data_tycon) tys + +tcMonoType rec_ce rec_tce tve (MonoTyCon bad_name tys) + = getSrcLocB_Tc `thenB_Tc` \ locn -> + failB_Tc (confusedNameErr + "Bad name for a type constructor (a class, or a Prelude name?)" + bad_name locn) + +-- two for unfoldings only: +tcMonoType rec_ce rec_tce tve (MonoDict c ty) + = tcMonoType rec_ce rec_tce tve ty `thenB_Tc` \ new_ty -> + let + clas = lookupCE rec_ce c + in + returnB_Tc (mkDictTy clas new_ty) + +tcMonoType rec_ce rec_tce tve (MonoTyVarTemplate tv_tmpl) + = returnB_Tc (lookupTVE tve tv_tmpl) + +#ifdef DPH +tcMonoType ce tce tve (MonoTyProc tys ty) + = tcMonoTypes ce tce tve tys `thenB_Tc` \ tau_tys -> + tcMonoType ce tce tve ty `thenB_Tc` \ tau_ty -> + returnB_Tc (mkProcessorTy tau_tys tau_ty) + +tcMonoType ce tce tve (MonoTyPod ty) + = tcMonoType ce tce tve ty `thenB_Tc` \ tau_ty -> + returnB_Tc (mkPodTy tau_ty) +#endif {- Data Parallel Haskell -} + +#ifdef DEBUG +tcMonoType rec_ce rec_tce tve bad_ty + = pprPanic "tcMonoType:" (ppr PprShowAll bad_ty) +#endif +\end{code} + +\begin{code} +tcMonoType_help rec_ce rec_tce tve name tycon arity is_syn_tycon tys + = tcMonoTypes rec_ce rec_tce tve tys `thenB_Tc` \ tau_tys -> + let cur_arity = length tys in + getSrcLocB_Tc `thenB_Tc` \ loc -> + + checkB_Tc (arity /= cur_arity) + (tyConArityErr name arity cur_arity loc) `thenB_Tc_` + + returnB_Tc (if is_syn_tycon then + applySynTyCon tycon tau_tys + else + applyNonSynTyCon tycon tau_tys) + +-- also not exported +tcMonoTypes rec_ce rec_tce tve monotypes + = mapB_Tc (tcMonoType rec_ce rec_tce tve) monotypes +\end{code} + +@tcInstanceType@ checks the type {\em and} its syntactic constraints: +it must normally look like: @instance Foo (Tycon a b c ...) ...@ +(We're checking the @Tycon a b c ...@ part here...) + +The exceptions to this syntactic checking: (1)~if the @GlasgowExts@ +flag is on, or (2)~the instance is imported (they must have been +compiled elsewhere). In these cases, we let them go through anyway. + +We can also have instances for functions: @instance Foo (a -> b) ...@. + +\begin{code} +tcInstanceType :: CE -> TCE -> TVE + -> Bool{-True <=> from this module-} -> SrcLoc + -> RenamedMonoType + -> Baby_TcM UniType + +tcInstanceType ce tce tve from_here locn mono_ty + = tcMonoType ce tce tve mono_ty `thenB_Tc` \ tau_ty -> + let + (naughty, unkosher) = bad_shape tau_ty + in + getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr -> + checkB_Tc + (if not from_here || sw_chkr GlasgowExts then -- no "shape" checking + naughty + else + naughty || unkosher + ) + (instTypeErr tau_ty locn) `thenB_Tc_` + returnB_Tc tau_ty + where + -- "naughty" if the type is really unacceptable, no + -- matter what (e.g., a type synonym); "unkosher" if + -- the Haskell report forbids it, but we allow it through + -- under -fglasgow-exts. + + bad_shape ty + = if (is_syn_type ty) then + (True, bottom) + else case (getUniDataTyCon_maybe ty) of + Just (_,tys,_) -> (False, not (all isTyVarTemplateTy tys)) + Nothing -> case maybeUnpackFunTy ty of + Just (t1, t2) -> (False, + not (all isTyVarTemplateTy [t1, t2])) + Nothing -> (True, bottom) + where + bottom = panic "bad_shape" + + is_syn_type ty -- ToDo: move to AbsUniType (or friend)? + = case ty of + UniSyn _ _ _ -> True + _ -> False +\end{code} diff --git a/ghc/compiler/typecheck/TcParQuals.lhs b/ghc/compiler/typecheck/TcParQuals.lhs new file mode 100644 index 0000000..7c28472 --- /dev/null +++ b/ghc/compiler/typecheck/TcParQuals.lhs @@ -0,0 +1,97 @@ +% Filename: %M% +% Version : %I% +% Date : %G% +% +\section[TcParQuals]{TcParQuals} + +\begin{code} +module TcParQuals ( tcParQuals , tcPidPats , tcPidExprs ) where + +#include "HsVersions.h" + +import TcMonad -- typechecking monad machinery +import TcMonadFns +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( boolTy, mkProcessorTy, mkPodTy , + toDomainId, fromDomainId + ) +import AbsUniType +import Id ( mkInstId ) +import Inst ( InstOrigin(..) ) +import E +import LIE +import TcExpr ( tcExpr , tcExprs ) +import TcPat ( tcPat , tcPats ) +import Unify +import Util +\end{code} + + +\begin{code} +tcParQuals :: E -> RenamedParQuals -> TcM (TypecheckedParQuals,LIE) +tcParQuals e (AndParQuals quals1 quals2) + = (tcParQuals e quals1) `thenTc` (\ (quals1',lie1) -> + (tcParQuals e quals2) `thenTc` (\ (quals2',lie2) -> + returnTc (AndParQuals quals1' quals2', lie1 `plusLIE` lie2) )) + +tcParQuals e (ParFilter expr) + = (tcExpr e expr) `thenTc` (\ (expr',lie,ty) -> + (unifyTauTy ty boolTy (ParFilterCtxt expr)) `thenTc_` + returnTc (ParFilter expr',lie) ) + +tcParQuals e (DrawnGenIn pats pat expr) + = (tcPidPats e pats) `thenTc` (\ (pats',convs,lie1,patsTy) -> + (tcPat e pat) `thenTc` (\ (pat' ,patTy, lie2) -> + (tcExpr e expr) `thenTc` (\ (expr',lie3,exprTy) -> + (unifyTauTy exprTy + (mkPodTy (mkProcessorTy patsTy patTy)) + (DrawnCtxt pats pat expr)) `thenTc_` + returnTc (DrawnGenOut pats' convs pat' expr', + plusLIE (plusLIE lie1 lie2) lie3 ) ))) + +tcParQuals e (IndexGen exprs pat expr) + = (tcPidExprs e exprs) `thenTc` (\ (exprs',lie1,exprsTy) -> + (tcPat e pat) `thenTc` (\ (pat',patTy, lie2) -> + (tcExpr e expr) `thenTc` (\ (expr',lie3,exprTy) -> + (unifyTauTy exprTy + (mkPodTy (mkProcessorTy exprsTy patTy)) + (IndexCtxt exprs pat expr)) `thenTc_` + returnTc (IndexGen exprs' pat' expr', + plusLIE (plusLIE lie1 lie2) lie3) ))) + +\end{code} + +\begin{code} +tcPidExprs:: E -> [RenamedExpr] -> TcM ([TypecheckedExpr],LIE,[TauType]) +tcPidExprs e exprs + = tcExprs e exprs `thenTc` (\ (exprs',lie,tys)-> + getSrcLocTc `thenNF_Tc` (\ loc -> + listNF_Tc (map (getFromDomain loc) tys) `thenNF_Tc` (\ fromDomains -> + returnTc (zipWith mkConversion fromDomains exprs', + mkLIE fromDomains `plusLIE` lie,tys) + ))) + where + getFromDomain loc ty + = newMethod (OccurrenceOf toDomainId loc) fromDomainId [ty] + + mkConversion fromDom expr + = App (Var (mkInstId fromDom)) expr +\end{code} + +\begin{code} +tcPidPats ::E ->[RenamedPat]->TcM ([TypecheckedPat], -- Expression + [TypecheckedExpr], -- Conversion fns + LIE, + [UniType]) +tcPidPats e pats + = tcPats e pats `thenTc` (\ (pats',tys,lie)-> + getSrcLocTc `thenNF_Tc` (\ loc -> + listNF_Tc (map (getToDomain loc) tys) `thenNF_Tc` (\ toDomains -> + returnTc (pats',map mkConversion toDomains, + mkLIE toDomains `plusLIE` lie,tys) + ))) + where + getToDomain loc ty= newMethod (OccurrenceOf toDomainId loc) toDomainId [ty] + mkConversion toDom= Var (mkInstId toDom) +\end{code} diff --git a/ghc/compiler/typecheck/TcPat.hi b/ghc/compiler/typecheck/TcPat.hi new file mode 100644 index 0000000..12e7ba3 --- /dev/null +++ b/ghc/compiler/typecheck/TcPat.hi @@ -0,0 +1,17 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcPat where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsPat(InPat, TypecheckedPat) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcPat :: E -> InPat Name -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (TypecheckedPat, LIE, UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs new file mode 100644 index 0000000..0bf3c31 --- /dev/null +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -0,0 +1,389 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcPat]{Typechecking patterns} + +\begin{code} +#include "HsVersions.h" + +module TcPat ( + tcPat +#ifdef DPH + , tcPats +#endif + ) where + +import TcMonad -- typechecking monad machinery +import TcMonadFns ( newOpenTyVarTy, newPolyTyVarTy, + newPolyTyVarTys, copyTyVars, newMethod, + newOverloadedLit + ) +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, charTy, stringTy, mkListTy, + mkTupleTy, addrTy, addrPrimTy, --OLD: eqStringId + PrimOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +#ifdef DPH + ,mkProcessorTy, toDomainId +#endif {- Data Parallel Haskell -} + ) +import AbsUniType ( instantiateTauTy, applyTyCon, InstTyEnv(..) + IF_ATTACK_PRAGMAS(COMMA instantiateTy) + ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Id ( mkInstId, getIdUniType, getDataConSig, + getInstantiatedDataConSig, Id, DataCon(..) + ) +import Inst +import E ( lookupE_Binder, lookupE_Value, + lookupE_ClassOpByKey, E, + LVE(..), TCE(..), UniqFM, CE(..) + -- TCE and CE for pragmas only + ) +import Errors ( dataConArityErr, Error(..), UnifyErrContext(..) + ) +import LIE ( nullLIE, plusLIE, mkLIE, LIE ) +import Unify +import Unique -- some ClassKey stuff +import Util + +#ifdef DPH +import TcParQuals +#endif {- Data Parallel Haskell -} +\end{code} + +The E passed in already contains bindings for all the variables in +the pattern, usually to fresh type variables (but maybe not, if there +were type signatures present). + +\begin{code} +tcPat :: E -> RenamedPat -> TcM (TypecheckedPat, LIE, UniType) +\end{code} + +%************************************************************************ +%* * +\subsection{Variables, wildcards, lazy pats, as-pats} +%* * +%************************************************************************ + +\begin{code} +tcPat e (VarPatIn name) + = let + id = lookupE_Binder e name + in + returnTc (VarPat id, nullLIE, getIdUniType id) + +tcPat e (LazyPatIn pat) + = tcPat e pat `thenTc` \ (pat', lie, ty) -> + returnTc (LazyPat pat', lie, ty) + +tcPat e pat_in@(AsPatIn name pat) + = let + id = lookupE_Binder e name + in + tcPat e pat `thenTc` \ (pat', lie, ty) -> + unifyTauTy (getIdUniType id) ty (PatCtxt pat_in) `thenTc_` + returnTc (AsPat id pat', lie, ty) + +tcPat e (WildPatIn) + = newOpenTyVarTy `thenNF_Tc` \ tyvar_ty -> + returnTc (WildPat tyvar_ty, nullLIE, tyvar_ty) +\end{code} + +%************************************************************************ +%* * +\subsection{Explicit lists and tuples} +%* * +%************************************************************************ + +\begin{code} +tcPat e pat_in@(ListPatIn pats) + = tcPats e pats `thenTc` \ (pats', lie, tys) -> + newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> + + unifyTauTyList (tyvar_ty:tys) (PatCtxt pat_in) `thenTc_` + + returnTc (ListPat tyvar_ty pats', lie, mkListTy tyvar_ty) + +tcPat e pat_in@(TuplePatIn pats) + = let + arity = length pats + in + tcPats e pats `thenTc` \ (pats', lie, tys) -> + + -- We have to unify with fresh polymorphic type variables, to + -- make sure we record that the tuples can only contain boxed + -- types. + newPolyTyVarTys arity `thenNF_Tc` \ tyvar_tys -> + + unifyTauTyLists tyvar_tys tys (PatCtxt pat_in) `thenTc_` + + -- possibly do the "make all tuple-pats irrefutable" test: + getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> + let + unmangled_result = TuplePat pats' + + -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) + -- so that we can experiment with lazy tuple-matching. + -- This is a pretty odd place to make the switch, but + -- it was easy to do. + possibly_mangled_result + = if sw_chkr IrrefutableTuples + then LazyPat unmangled_result + else unmangled_result + + -- ToDo: IrrefutableEverything + in + returnTc (possibly_mangled_result, lie, mkTupleTy arity tys) +\end{code} + +%************************************************************************ +%* * +\subsection{Other constructors} +%* * +%************************************************************************ + +Constructor patterns are a little fun: +\begin{itemize} +\item +typecheck the arguments +\item +look up the constructor +\item +specialise its type (ignore the translation this produces) +\item +check that the context produced by this specialisation is empty +\item +get the arguments out of the function type produced from specialising +\item +unify them with the types of the patterns +\item +back substitute with the type of the result of the constructor +\end{itemize} + +ToDo: exploit new representation of constructors to make this more +efficient? + +\begin{code} +tcPat e pat_in@(ConPatIn name pats) + = let + con_id = lookupE_Value e name + in + tcPats e pats `thenTc` \ (pats', lie, tys) -> + + matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty -> + + returnTc (ConPat con_id data_ty pats', lie, data_ty) + +tcPat e pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... + = let + con_id = lookupE_Value e op + in + tcPats e [pat1, pat2] `thenTc` \ ([pat1',pat2'], lie, tys) -> + -- ToDo: there exists a less ugly way, no doubt... + + matchConArgTys con_id tys (\ ty -> PatCtxt pat_in) `thenTc` \ data_ty -> + + returnTc (ConOpPat pat1' con_id pat2' data_ty, lie, data_ty) +\end{code} + +%************************************************************************ +%* * +\subsection{Non-overloaded literals} +%* * +%************************************************************************ + +\begin{code} +tcPat e (LitPatIn lit@(CharLit str)) + = returnTc (LitPat lit charTy, nullLIE, charTy) + +tcPat e (LitPatIn lit@(StringLit str)) + = getSrcLocTc `thenNF_Tc` \ loc -> + let + origin = LiteralOrigin lit loc + eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") + in + newMethod origin eq_id [stringTy] `thenNF_Tc` \ eq -> + let + comp_op = App (Var (mkInstId eq)) (Lit lit) + in + returnTc (NPat lit stringTy comp_op, mkLIE [eq], stringTy) + +{- OLD: +tcPat e (LitPatIn lit@(StringLit str)) + = returnTc (NPat lit stringTy comp_op, nullLIE, stringTy) + where + comp_op = App (Var eqStringId) (Lit lit) +-} + +tcPat e (LitPatIn lit@(IntPrimLit _)) + = returnTc (LitPat lit intPrimTy, nullLIE, intPrimTy) +tcPat e (LitPatIn lit@(CharPrimLit _)) + = returnTc (LitPat lit charPrimTy, nullLIE, charPrimTy) +tcPat e (LitPatIn lit@(StringPrimLit _)) + = returnTc (LitPat lit addrPrimTy, nullLIE, addrPrimTy) +tcPat e (LitPatIn lit@(FloatPrimLit _)) + = returnTc (LitPat lit floatPrimTy, nullLIE, floatPrimTy) +tcPat e (LitPatIn lit@(DoublePrimLit _)) + = returnTc (LitPat lit doublePrimTy, nullLIE, doublePrimTy) +\end{code} + +%************************************************************************ +%* * +\subsection{Overloaded patterns: int literals and \tr{n+k} patterns} +%* * +%************************************************************************ + +\begin{code} +tcPat e (LitPatIn lit@(IntLit i)) + = getSrcLocTc `thenNF_Tc` \ loc -> + let + origin = LiteralOrigin lit loc + in + newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> + let + from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") + from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") + eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") + in + newOverloadedLit origin + (OverloadedIntegral i from_int from_integer) + tyvar_ty `thenNF_Tc` \ over_lit -> + + newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + + returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) + (Var (mkInstId over_lit))), + mkLIE [over_lit, eq], + tyvar_ty) + +tcPat e (LitPatIn lit@(FracLit f)) + = getSrcLocTc `thenNF_Tc` \ loc -> + let + origin = LiteralOrigin lit loc + in + newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> + let + eq_id = lookupE_ClassOpByKey e eqClassKey SLIT("==") + from_rational = lookupE_ClassOpByKey e fractionalClassKey SLIT("fromRational") + in + newOverloadedLit origin + (OverloadedFractional f from_rational) + tyvar_ty `thenNF_Tc` \ over_lit -> + + newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + + returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) + (Var (mkInstId over_lit))), + mkLIE [over_lit, eq], + tyvar_ty) + +tcPat e (LitPatIn lit@(LitLitLitIn s)) + = error "tcPat: can't handle ``literal-literal'' patterns" +{- + = getSrcLocTc `thenNF_Tc` \ loc -> + let + origin = LiteralOrigin lit loc + in + newPolyTyVarTy `thenNF_Tc` \ tyvar_ty -> + let + eq_id = lookupE_ClassOpByKey e eqClassKey "==" + in + newOverloadedLit origin + (OverloadedLitLit s) + tyvar_ty `thenNF_Tc` \ over_lit -> + + newMethod origin eq_id [tyvar_ty] `thenNF_Tc` \ eq -> + + returnTc (NPat lit tyvar_ty (App (Var (mkInstId eq)) + (Var (mkInstId over_lit))), + mkLIE [over_lit, eq], + tyvar_ty) +-} + +tcPat e (NPlusKPatIn name lit@(IntLit k)) + = getSrcLocTc `thenNF_Tc` \ loc -> + let + origin = LiteralOrigin lit loc + + local = lookupE_Binder e name + local_ty = getIdUniType local + + ge_id = lookupE_ClassOpByKey e ordClassKey SLIT(">=") + minus_id = lookupE_ClassOpByKey e numClassKey SLIT("-") + from_int = lookupE_ClassOpByKey e numClassKey SLIT("fromInt") + from_integer = lookupE_ClassOpByKey e numClassKey SLIT("fromInteger") + in + newOverloadedLit origin + (OverloadedIntegral k from_int from_integer) + local_ty `thenNF_Tc` \ over_lit -> + + newMethod origin ge_id [local_ty] `thenNF_Tc` \ ge -> + newMethod origin minus_id [local_ty] `thenNF_Tc` \ minus -> + + returnTc (NPlusKPat local lit local_ty + (Var (mkInstId over_lit)) + (Var (mkInstId ge)) + (Var (mkInstId minus)), + mkLIE [over_lit, ge, minus], + local_ty) + +tcPat e (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an IntLit" + +#ifdef DPH +tcPat e (ProcessorPatIn pats pat) + = tcPidPats e pats `thenTc` \ (pats',convs, lie, tys)-> + tcPat e pat `thenTc` \ (pat', ty, lie') -> + returnTc (ProcessorPat pats' convs pat', + plusLIE lie lie', + mkProcessorTy tys ty) +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection{Lists of patterns} +%* * +%************************************************************************ + +\begin{code} +tcPats :: E -> [RenamedPat] -> TcM ([TypecheckedPat], LIE, [UniType]) + +tcPats e [] = returnTc ([], nullLIE, []) + +tcPats e (pat:pats) + = tcPat e pat `thenTc` \ (pat', lie, ty) -> + tcPats e pats `thenTc` \ (pats', lie', tys) -> + + returnTc (pat':pats', plusLIE lie lie', ty:tys) +\end{code} + +@matchConArgTys@ grabs the signature of the data constructor, and +unifies the actual args against the expected ones. + +\begin{code} +matchConArgTys :: Id -> [UniType] -> (UniType -> UnifyErrContext) -> TcM UniType + +matchConArgTys con_id arg_tys err_ctxt + = let + no_of_args = length arg_tys + (sig_tyvars, sig_theta, sig_tys, _) = getDataConSig con_id + -- Ignore the sig_theta; overloaded constructors only + -- behave differently when called, not when used for + -- matching. + con_arity = length sig_tys + in + getSrcLocTc `thenNF_Tc` \ loc -> + checkTc (con_arity /= no_of_args) + (dataConArityErr con_id con_arity no_of_args loc) `thenTc_` + + copyTyVars sig_tyvars `thenNF_Tc` \ (inst_env, _, new_tyvar_tys) -> + let + (_,inst_arg_tys,inst_result_ty) = getInstantiatedDataConSig con_id new_tyvar_tys + in + unifyTauTyLists arg_tys inst_arg_tys (err_ctxt inst_result_ty) `thenTc_` + returnTc inst_result_ty +\end{code} diff --git a/ghc/compiler/typecheck/TcPolyType.hi b/ghc/compiler/typecheck/TcPolyType.hi new file mode 100644 index 0000000..158d223 --- /dev/null +++ b/ghc/compiler/typecheck/TcPolyType.hi @@ -0,0 +1,17 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcPolyType where +import Bag(Bag) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import HsTypes(PolyType) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +tcPolyType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> PolyType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType + {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcPolyType.lhs b/ghc/compiler/typecheck/TcPolyType.lhs new file mode 100644 index 0000000..7dd3973 --- /dev/null +++ b/ghc/compiler/typecheck/TcPolyType.lhs @@ -0,0 +1,110 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[TcPolyType]{Typechecking user-specified @PolyTypes@} + +\begin{code} +module TcPolyType ( tcPolyType ) where + +#include "HsVersions.h" + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +import AbsUniType ( mkTyVarTemplateTy, mkSysTyVarTemplate, mkSigmaTy, + mkForallTy, SigmaType(..) + ) +import CE ( CE(..) ) +import Maybes ( Maybe(..) ) +import TCE ( TCE(..), UniqFM ) +import TVE -- ( mkTVE, plusTVE, unitTVE, lookupTVE_NoFail, TVE(..) ) +import TcContext ( tcContext ) +import TcMonoType ( tcMonoType ) +import Util +\end{code} + +The TVE passed into @tcPolyType@ binds type variables which are +in scope; in practice this is always either empty (ordinary type sigs) +or a singleton (class signatures). @tcPolyType@ generates a type which +is polymorphic in all the {\em other} type varaibles mentioned in the +type. + +Very Important Note: when we have a type signature in an interface, say +\begin{verbatim} + f :: a -> b -> a +\end{verbatim} +which of the following polytypes do we return? +\begin{verbatim} + forall a b. a -> b -> a +--or + forall b a. a -> b -> a +\end{verbatim} + +It makes a difference, because it affects the order in which f takes +its type arguments. Now this makes a difference in two ways: +\begin{itemize} +\item +It's essential to get it right if an inlining for f is also exported +by the interface. +\item +It's essential to get it right if the interface tells that there's a specialised +version of f, because specialisations are known by their function-name/type-arg +combinations. +\end{itemize} + +By convention, the foralls on a type read in from somewhere (notably interfaces) +are + {\em in alphabetical order of their type variables} + +When printing types we make sure that we assign print-names to the forall'd type +variables which are also in alphabetical order. + +\begin{code} +tcPolyType :: CE -> TCE -> TVE -> RenamedPolyType -> Baby_TcM UniType + +tcPolyType ce tce tve (ForAllTy tvs ty) + = let + new_tv_tmpls_w_uniqs = map tc_uf_tyvar_template tvs + new_tv_tmpls = map snd new_tv_tmpls_w_uniqs + new_tve + = foldr plusTVE tve + [ unitTVE u (mkTyVarTemplateTy tv) + | (u, tv) <- new_tv_tmpls_w_uniqs ] + in + tcMonoType ce tce new_tve ty `thenB_Tc` \ new_ty -> + returnB_Tc (mkForallTy new_tv_tmpls new_ty) + where + tc_uf_tyvar_template (Short u _) = (u, mkSysTyVarTemplate u SLIT("a")) + +tcPolyType ce tce tve (OverloadedTy ctxt ty) = tc_poly ce tce tve ctxt ty +tcPolyType ce tce tve (UnoverloadedTy ty) = tc_poly ce tce tve [] ty + +tc_poly ce tce tve ctxt ty + = let -- BUILD THE NEW TVE + used_tyvar_names = extractMonoTyNames (==) ty + poly_tyvar_names = drop_tyvars_if_in_TVE used_tyvar_names + + -- Sort them into alphabetical order; see notes above. + sorted_tyvar_names = sortLt lt_by_string poly_tyvar_names + + (local_tve, tyvars, _) = mkTVE sorted_tyvar_names + new_tve = plusTVE tve local_tve + in + -- TYPE CHECK THE CONTEXT AND MONOTYPE + tcContext ce tce new_tve ctxt `thenB_Tc` \ theta -> + tcMonoType ce tce new_tve ty `thenB_Tc` \ tau_ty -> + + -- BUILD THE POLYTYPE AND RETURN + returnB_Tc (mkSigmaTy tyvars theta tau_ty) + where + drop_tyvars_if_in_TVE [] = [] + drop_tyvars_if_in_TVE (n:ns) + = let rest = drop_tyvars_if_in_TVE ns + in + case (lookupTVE_NoFail tve n) of + Just _ -> rest -- drop it + Nothing -> n : rest + + lt_by_string :: Name -> Name -> Bool + lt_by_string a b = getOccurrenceName a < getOccurrenceName b +\end{code} diff --git a/ghc/compiler/typecheck/TcPragmas.hi b/ghc/compiler/typecheck/TcPragmas.hi new file mode 100644 index 0000000..8c3238a --- /dev/null +++ b/ghc/compiler/typecheck/TcPragmas.hi @@ -0,0 +1,30 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcPragmas where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsDecls(ConDecl) +import HsPragmas(ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas, TypePragmas) +import Id(Id) +import IdInfo(IdInfo, SpecEnv, SpecInfo) +import Maybes(Labda) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyCon(TyCon) +import TyVar(TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +tcClassOpPragmas :: E -> UniType -> Id -> Id -> SpecEnv -> ClassOpPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (IdInfo, IdInfo) + {-# GHC_PRAGMA _A_ 6 _U_ 2022212222 _N_ _S_ "LALLLS" {_A_ 5 _U_ 222212222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +tcDataPragmas :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> DataPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ConDecl Name], [SpecInfo]) + {-# GHC_PRAGMA _A_ 5 _U_ 200112222 _N_ _S_ "LAALU(LS)" {_A_ 4 _U_ 21212122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +tcDictFunPragmas :: E -> UniType -> Id -> InstancePragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo + {-# GHC_PRAGMA _A_ 4 _U_ 22222222 _N_ _S_ "LLLS" _N_ _N_ #-} +tcGenPragmas :: E -> Labda UniType -> Id -> GenPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo + {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-} +tcTypePragmas :: TypePragmas -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TypePragmas) -> case u0 of { _ALG_ _ORIG_ HsPragmas NoTypePragmas -> _!_ False [] []; _ORIG_ HsPragmas AbstractTySynonym -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs new file mode 100644 index 0000000..28b80c9 --- /dev/null +++ b/ghc/compiler/typecheck/TcPragmas.lhs @@ -0,0 +1,696 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% +\section[TcPragmas]{Typecheck ``pragmas'' of various kinds} + +\begin{code} +#include "HsVersions.h" + +module TcPragmas ( + tcClassOpPragmas, + tcDataPragmas, + tcDictFunPragmas, + tcGenPragmas, + tcTypePragmas + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Pretty +import Outputable + +import TcMonad -- typechecking monadic machinery +import TcMonadFns ( mkIdsWithGivenTys ) +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( PrimOp(..) -- to see CCallOp + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AbsUniType +import CE ( lookupCE, nullCE, CE(..) ) +import CmdLineOpts +import CostCentre +import E +import Errors +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Id +import IdInfo +import WwLib ( mkWwBodies ) +import InstEnv ( lookupClassInstAtSimpleType ) +import Maybes ( assocMaybe, catMaybes, Maybe(..) ) +import CoreLint ( lintUnfolding ) +import PlainCore +import TCE ( TCE(..), UniqFM ) +import TVE +import TcMonoType ( tcMonoType ) +import TcPolyType ( tcPolyType ) +import Util +import SrcLoc +\end{code} + +The basic idea is: Given an @Id@ that only lacks its @IdInfo@ +(represented as a function \tr{IdInfo -> Id}, use the pragmas given to +figure out the @IdInfo@, then give back the now-complete @Id@. + +Of course, the pragmas also need to be checked. + +%************************************************************************ +%* * +\subsection[tcClassOpPragmas]{@ClassOp@ pragmas} +%* * +%************************************************************************ + +\begin{code} +tcClassOpPragmas :: E -- Class/TyCon lookup tables + -> UniType -- global type of the class method + -> Id -- *final* ClassOpId + -> Id -- *final* DefaultMethodId + -> SpecEnv -- Instance info for this class op + -> RenamedClassOpPragmas -- info w/ which to complete, giving... + -> Baby_TcM (IdInfo, IdInfo) -- ... final info for ClassOp and DefaultMethod + +tcClassOpPragmas _ _ rec_classop_id rec_defm_id spec_infos NoClassOpPragmas + = returnB_Tc (noIdInfo `addInfo` spec_infos, noIdInfo) + +tcClassOpPragmas e global_ty + rec_classop_id rec_defm_id + spec_infos + (ClassOpPragmas classop_pragmas defm_pragmas) + = tcGenPragmas e + Nothing{-ty unknown-} rec_classop_id + classop_pragmas `thenB_Tc` \ classop_idinfo -> + + tcGenPragmas e + Nothing{-ty unknown-} rec_defm_id + defm_pragmas `thenB_Tc` \ defm_idinfo -> + + returnB_Tc (classop_idinfo `addInfo` spec_infos, defm_idinfo) +\end{code} + +%************************************************************************ +%* * +\subsection[tcInstancePragmas]{Instance-related pragmas of various sorts} +%* * +%************************************************************************ + +{\em Every} instance declaration produces a ``dictionary function'' +(dfun) of some sort; every flavour of @InstancePragmas@ gives a way to +convey information about a DictFunId. + +\begin{code} +tcDictFunPragmas + :: E -- Class/TyCon lookup tables + -> UniType -- DictFunId type + -> Id -- final DictFunId (don't touch) + -> RenamedInstancePragmas -- info w/ which to complete, giving... + -> Baby_TcM IdInfo -- ... final DictFun IdInfo + +tcDictFunPragmas _ _ final_dfun NoInstancePragmas + = returnB_Tc noIdInfo + +tcDictFunPragmas e dfun_ty final_dfun pragmas + = let + dfun_pragmas + = case pragmas of + SimpleInstancePragma x -> x + ConstantInstancePragma x _ -> x + SpecialisedInstancePragma x _ -> x + in + tcGenPragmas e (Just dfun_ty) final_dfun dfun_pragmas +\end{code} + +%************************************************************************ +%* * +\subsection[tcGenPragmas]{Basic pragmas about a value} +%* * +%************************************************************************ + +Nota bene: @tcGenPragmas@ guarantees to succeed; if it encounters +a problem, it just returns @noIdInfo@. + +\begin{code} +tcGenPragmas + :: E -- lookup table + -> Maybe UniType -- of Id, if we have it (for convenience) + -> Id -- *incomplete* Id (do not *touch*!) + -> RenamedGenPragmas -- info w/ which to complete, giving... + -> Baby_TcM IdInfo -- IdInfo for this Id + +tcGenPragmas e ty_maybe rec_final_id NoGenPragmas + = returnB_Tc noIdInfo + +tcGenPragmas e ty_maybe rec_final_id + (GenPragmas arity_maybe upd_maybe def strictness unfold specs) + = -- Guarantee success! + recoverIgnoreErrorsB_Tc noIdInfo ( + + -- OK, now we do the business + let + arity_info = get_arity arity_maybe + upd_info = get_upd upd_maybe + in + + -- If the unfolding fails to look consistent, we don't + -- want to junk *all* the IdInfo + recoverIgnoreErrorsB_Tc noInfo_UF ( + tc_unfolding e unfold + ) `thenB_Tc` \ unfold_info -> + + tc_strictness e ty_maybe rec_final_id strictness + `thenB_Tc` \ (strict_info, wrapper_unfold_info) -> + + -- Same as unfolding; if we fail, don't junk all IdInfo + recoverIgnoreErrorsB_Tc nullSpecEnv ( + tc_specs e rec_final_id ty_maybe specs + ) `thenB_Tc` \ spec_env -> + + returnB_Tc ( + noIdInfo + `addInfo` arity_info + `addInfo` upd_info + `addInfo` def + + -- The strictness info *may* imply an unfolding + -- (the "wrapper_unfold"); that info is added; if + -- there is also an explicit unfolding, it will + -- take precedence, because it is "added" later. + `addInfo` strict_info + `addInfo_UF` wrapper_unfold_info + + `addInfo_UF` unfold_info + `addInfo` spec_env + )) + where + get_arity Nothing = noInfo + get_arity (Just a) = mkArityInfo a + + get_upd Nothing = noInfo + get_upd (Just u) = (u :: UpdateInfo) +\end{code} + +Don't use the strictness info if a flag set. +\begin{code} +tc_strictness + :: E + -> Maybe UniType + -> Id -- final Id (do not *touch*) + -> ImpStrictness Name + -> Baby_TcM (StrictnessInfo, UnfoldingDetails) + +tc_strictness e ty_maybe rec_final_id info + = getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr -> + if sw_chkr IgnoreStrictnessPragmas then + returnB_Tc (noInfo, noInfo_UF) + else + do_strictness e ty_maybe rec_final_id info +\end{code} + +An easy one first: +\begin{code} +do_strictness e ty_maybe rec_final_id NoImpStrictness + = returnB_Tc (noInfo, noInfo_UF) +\end{code} + +We come to a nasty one now. We have strictness info---possibly +implying a worker---but (for whatever reason) no {\em type} +information for the wrapper. We therefore want (a)~{\em not} to +create a wrapper unfolding (we {\em cannot}) \& to be sure that one is +never asked for (!); and (b)~we want to keep the strictness/absence +info, because there's too much good stuff there to ignore completely. +We are not bothered about any pragmatic info for any alleged worker. +NB: this code applies only to {\em imported} info. So here we go: + +\begin{code} +do_strictness e Nothing rec_final_id (ImpStrictness is_bot arg_info _) + = let + strictness_info + = if is_bot + then mkBottomStrictnessInfo + else mkStrictnessInfo arg_info Nothing + in + returnB_Tc (strictness_info, noInfo_UF) + -- no unfolding: the key --^^^^^^ +\end{code} + +And, finally, the have-everthing, know-everything, do-everything +``normal case''. +\begin{code} +do_strictness e (Just wrapper_ty) rec_final_id + (ImpStrictness is_bot wrap_arg_info wrkr_pragmas) + + | is_bot -- it's a "bottoming Id" + = returnB_Tc (mkBottomStrictnessInfo, noInfo_UF) + + | not (indicatesWorker wrap_arg_info) + = -- No worker + returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF) + + | otherwise + = -- Strictness info suggests a worker. Things could still + -- go wrong if there's an abstract type involved, mind you. + let + (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty + n_wrapper_args = length wrap_arg_info + -- Don't have more args than this, else you risk + -- losing laziness!! + in + getUniquesB_Tc (length tv_tmpls) `thenB_Tc` \ tyvar_uniqs -> + getUniquesB_Tc n_wrapper_args `thenB_Tc` \ arg_uniqs -> + + let + (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls tyvar_uniqs + + inst_arg_tys = map (instantiateTy inst_env) arg_tys + (undropped_inst_arg_tys, dropped_inst_arg_tys) + = splitAt n_wrapper_args inst_arg_tys + + inst_ret_ty = glueTyArgs dropped_inst_arg_tys + (instantiateTy inst_env ret_ty) + + args = zipWith mk_arg arg_uniqs undropped_inst_arg_tys + mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc + -- ASSERT: length args = n_wrapper_args + in + + uniqSMtoBabyTcM (mkWwBodies inst_ret_ty tyvars args wrap_arg_info) + `thenB_Tc` \ result -> + case result of + + Nothing -> -- Alas, we met an abstract type + returnB_Tc (mkStrictnessInfo wrap_arg_info Nothing, noInfo_UF) + + Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) -> + + let + worker_ty = worker_ty_w_hole inst_ret_ty + in + getUniqueB_Tc `thenB_Tc` \ uniq -> + fixB_Tc ( \ rec_wrkr_id -> + + tcGenPragmas e + (Just worker_ty) + rec_wrkr_id + wrkr_pragmas `thenB_Tc` \ wrkr_id_info -> + + returnB_Tc (mkWorkerId uniq rec_final_id worker_ty + (wrkr_id_info `addInfo` worker_strictness)) + -- Note: the above will *clobber* any strictness + -- info for the worker which was read in from the + -- interface (but there usually isn't any). + + ) `thenB_Tc` \ worker_id -> + + let + wrapper_rhs = wrapper_w_hole worker_id + n_tyvars = length tyvars + arity = length args + + in + returnB_Tc ( + mkStrictnessInfo wrap_arg_info (Just worker_id), + mkUnfolding UnfoldAlways ({-pprTrace "imp wrapper:\n" (ppAboves [ppr PprDebug wrapper_rhs, ppInfo PprDebug (\x->x) worker_strictness])-} wrapper_rhs) + -- We only do this for imported things, which this is. + ) +\end{code} + +\begin{code} +tc_specs :: E + -> Id -- final Id for which these are specialisations (do not *touch*) + -> Maybe UniType + -> [([Maybe RenamedMonoType], Int, RenamedGenPragmas)] + -> Baby_TcM SpecEnv + +tc_specs e rec_main_id Nothing{-no type, we lose-} spec_pragmas + = returnB_Tc nullSpecEnv -- ToDo: msg???????? + +tc_specs e rec_main_id (Just main_ty) spec_pragmas + = mapB_Tc do_one_pragma spec_pragmas `thenB_Tc` \ spec_infos -> + returnB_Tc (mkSpecEnv spec_infos) + where + (main_tyvars, _) = splitForalls main_ty + + rec_ce = getE_CE e + rec_tce = getE_TCE e + + do_one_pragma (maybe_monotys, dicts_to_ignore, gen_prags) + = mapB_Tc (tc_ty_maybe rec_ce rec_tce) maybe_monotys + `thenB_Tc` \ maybe_tys -> + getSrcLocB_Tc `thenB_Tc` \ locn -> + getUniqueB_Tc `thenB_Tc` \ uniq -> + + checkB_Tc (length main_tyvars /= length maybe_tys) + (badSpecialisationErr "value" "wrong number of specialising types" + (length main_tyvars) maybe_tys locn) + `thenB_Tc_` + let + spec_ty = specialiseTy main_ty maybe_tys dicts_to_ignore + in + fixB_Tc ( \ rec_spec_id -> + + tcGenPragmas e (Just spec_ty) rec_spec_id gen_prags + `thenB_Tc` \ spec_id_info -> + + returnB_Tc (mkSpecId uniq rec_main_id maybe_tys spec_ty spec_id_info) + + ) `thenB_Tc` \ spec_id -> + + returnB_Tc (SpecInfo maybe_tys dicts_to_ignore spec_id) + +tc_ty_maybe rec_ce rec_tce Nothing = returnB_Tc Nothing +tc_ty_maybe rec_ce rec_tce (Just ty) + = tcMonoType rec_ce rec_tce nullTVE ty `thenB_Tc` \ new_ty -> + returnB_Tc (Just new_ty) +\end{code} + +\begin{code} +tc_unfolding e NoImpUnfolding = returnB_Tc noInfo_UF +tc_unfolding e (ImpMagicUnfolding tag) = returnB_Tc (mkMagicUnfolding tag) + +tc_unfolding e (ImpUnfolding guidance uf_core) + = tc_uf_core nullLVE nullTVE uf_core `thenB_Tc` \ core_expr -> + getSrcLocB_Tc `thenB_Tc` \ locn -> + returnB_Tc (mkUnfolding guidance (lintUnfolding locn core_expr)) + -- type-incorrect unfoldings are so painful that we + -- always lint-check them; such unfoldings can arise + -- because of by-hand mix-and-match jiggery-pokery with + -- interface files (WDP 95/05) + where + rec_ce = getE_CE e + rec_tce = getE_TCE e + + tc_uf_core :: LVE -- lookup table for local binders + -- (others: we hope we can figure them out) + -> TVE -- lookup table for tyvars + -> UnfoldingCoreExpr Name + -> Baby_TcM PlainCoreExpr + + tc_uf_core lve tve (UfCoVar v) + = tc_uf_Id lve v `thenB_Tc` \ id -> + returnB_Tc (CoVar id) + + tc_uf_core lve tve (UfCoLit l) + = returnB_Tc (CoLit l) + + tc_uf_core lve tve (UfCoCon con tys as) + = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id -> + mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys -> + mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms -> + returnB_Tc (CoCon con_id core_tys core_atoms) + + -- If a ccall, we have to patch in the types read from the pragma. + + tc_uf_core lve tve (UfCoPrim (UfCCallOp str is_casm may_gc arg_tys res_ty) app_tys as) + = ASSERT(null app_tys) + mapB_Tc (tc_uf_type tve) arg_tys `thenB_Tc` \ core_arg_tys -> + tc_uf_type tve res_ty `thenB_Tc` \ core_res_ty -> + mapB_Tc (tc_uf_type tve) app_tys `thenB_Tc` \ core_app_tys -> + mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms -> + returnB_Tc (CoPrim (CCallOp str is_casm may_gc core_arg_tys core_res_ty) + core_app_tys core_atoms) + + tc_uf_core lve tve (UfCoPrim (UfOtherOp op) tys as) + = mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ core_tys -> + mapB_Tc (tc_uf_atom lve tve) as `thenB_Tc` \ core_atoms -> + returnB_Tc (CoPrim op core_tys core_atoms) + + tc_uf_core lve tve (UfCoLam binders body) + = tc_uf_binders tve binders `thenB_Tc` \ lve2 -> + let + new_binders = map snd lve2 + new_lve = lve2 `plusLVE` lve + in + tc_uf_core new_lve tve body `thenB_Tc` \ new_body -> + returnB_Tc (CoLam new_binders new_body) + + tc_uf_core lve tve (UfCoTyLam tv body) + = let + (new_tv, uniq, new_tv_ty) = tc_uf_tyvar tv + new_tve = tve `plusTVE` (unitTVE uniq new_tv_ty) + in + tc_uf_core lve new_tve body `thenB_Tc` \ new_body -> + returnB_Tc (CoTyLam new_tv new_body) + + tc_uf_core lve tve (UfCoApp fun arg) + = tc_uf_core lve tve fun `thenB_Tc` \ new_fun -> + tc_uf_atom lve tve arg `thenB_Tc` \ new_arg -> + returnB_Tc (CoApp new_fun new_arg) + + tc_uf_core lve tve (UfCoTyApp expr ty) + = tc_uf_core lve tve expr `thenB_Tc` \ new_expr -> + tc_uf_type tve ty `thenB_Tc` \ new_ty -> + returnB_Tc (mkCoTyApp new_expr new_ty) + + tc_uf_core lve tve (UfCoCase scrut alts) + = tc_uf_core lve tve scrut `thenB_Tc` \ new_scrut -> + tc_alts alts `thenB_Tc` \ new_alts -> + returnB_Tc (CoCase new_scrut new_alts) + where + tc_alts (UfCoAlgAlts alts deflt) + = mapB_Tc tc_alg_alt alts `thenB_Tc` \ new_alts -> + tc_deflt deflt `thenB_Tc` \ new_deflt -> + returnB_Tc (CoAlgAlts new_alts new_deflt) + where + tc_alg_alt (con, params, rhs) + = tc_uf_Id lve (BoringUfId con) `thenB_Tc` \ con_id -> + tc_uf_binders tve params `thenB_Tc` \ lve2 -> + let + new_params = map snd lve2 + new_lve = lve2 `plusLVE` lve + in + tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs -> + returnB_Tc (con_id, new_params, new_rhs) + + tc_alts (UfCoPrimAlts alts deflt) + = mapB_Tc tc_prim_alt alts `thenB_Tc` \ new_alts -> + tc_deflt deflt `thenB_Tc` \ new_deflt -> + returnB_Tc (CoPrimAlts new_alts new_deflt) + where + tc_prim_alt (lit, rhs) + = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs -> + returnB_Tc (lit, new_rhs) + + tc_deflt UfCoNoDefault = returnB_Tc CoNoDefault + tc_deflt (UfCoBindDefault b rhs) + = tc_uf_binders tve [b] `thenB_Tc` \ lve2 -> + let + [new_b] = map snd lve2 + new_lve = lve2 `plusLVE` lve + in + tc_uf_core new_lve tve rhs `thenB_Tc` \ new_rhs -> + returnB_Tc (CoBindDefault new_b new_rhs) + + tc_uf_core lve tve (UfCoLet (UfCoNonRec b rhs) body) + = tc_uf_core lve tve rhs `thenB_Tc` \ new_rhs -> + tc_uf_binders tve [b] `thenB_Tc` \ lve2 -> + let + [new_b] = map snd lve2 + new_lve = lve2 `plusLVE` lve + in + tc_uf_core new_lve tve body `thenB_Tc` \ new_body -> + returnB_Tc (CoLet (CoNonRec new_b new_rhs) new_body) + + tc_uf_core lve tve (UfCoLet (UfCoRec pairs) body) + = let + (binders, rhss) = unzip pairs + in + tc_uf_binders tve binders `thenB_Tc` \ lve2 -> + let + new_binders = map snd lve2 + new_lve = lve2 `plusLVE` lve + in + mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss -> + tc_uf_core new_lve tve body `thenB_Tc` \ new_body -> + returnB_Tc (CoLet (CoRec (new_binders `zip` new_rhss)) new_body) + + tc_uf_core lve tve (UfCoSCC uf_cc body) + = tc_uf_cc uf_cc `thenB_Tc` \ new_cc -> + tc_uf_core lve tve body `thenB_Tc` \ new_body -> + returnB_Tc (CoSCC new_cc new_body) + where + tc_uf_cc (UfAutoCC id m g is_dupd is_caf) + = tc_uf_Id lve id `thenB_Tc` \ new_id -> + returnB_Tc (adjust is_caf is_dupd (mkAutoCC new_id m g IsNotCafCC)) + + tc_uf_cc (UfDictCC id m g is_dupd is_caf) + = tc_uf_Id lve id `thenB_Tc` \ new_id -> + returnB_Tc (adjust is_caf is_dupd (mkDictCC new_id m g IsNotCafCC)) + + tc_uf_cc (UfUserCC n m g d c) = returnB_Tc (adjust c d (mkUserCC n m g)) + + tc_uf_cc (UfPreludeDictsCC d) = returnB_Tc (preludeDictsCostCentre d) + tc_uf_cc (UfAllDictsCC m g d) = returnB_Tc (mkAllDictsCC m g d) + + -------- + adjust is_caf is_dupd cc + = let + maybe_cafify = if is_caf then cafifyCC else (\x->x) + maybe_dupify = if is_dupd then dupifyCC else (\x->x) + in + maybe_dupify (maybe_cafify cc) + + --------------- + tc_uf_atom lve tve (UfCoLitAtom l) + = returnB_Tc (CoLitAtom l) + + tc_uf_atom lve tve (UfCoVarAtom v) + = tc_uf_Id lve v `thenB_Tc` \ new_v -> + returnB_Tc (CoVarAtom new_v) + + --------------- + tc_uf_binders tve ids_and_tys + = let + (ids, tys) = unzip ids_and_tys + in + mapB_Tc (tc_uf_type tve) tys `thenB_Tc` \ new_tys -> + + returnB_Tc (mkIdsWithGivenTys ids new_tys (repeat noIdInfo)) + + --------------- + -- "tyvar" binders (see tcPolyType for the TyVarTemplate equiv): + + tc_uf_tyvar (Short u short_name) + = let + tyvar = mkUserTyVar u short_name + in + (tyvar, u, mkTyVarTy tyvar) + + --------------- + tc_uf_Id lve (BoringUfId v) + = case (assocMaybe lve v) of + Just xx -> returnB_Tc xx + Nothing -> case (lookupE_ValueQuietly e v) of + Just xx -> returnB_Tc xx + Nothing -> --pprTrace "lookup_Quietly: " (ppr PprDebug v) ( + failB_Tc (panic "tc_uf_Id: no lookup") + --) + -- should be recover'd from + -- ToDo: shouldn't the renamer have handled this? [wdp 94/04/29] + + tc_uf_Id lve (SuperDictSelUfId c sc) + = let + clas = lookupCE rec_ce c + super_clas = lookupCE rec_ce sc + in + returnB_Tc (getSuperDictSelId clas super_clas) + + tc_uf_Id lve (ClassOpUfId c op_name) + = let + clas = lookupCE rec_ce c + op = lookup_class_op clas op_name + in + returnB_Tc (getClassOpId clas op) + + tc_uf_Id lve (DefaultMethodUfId c op_name) + = let + clas = lookupCE rec_ce c + op = lookup_class_op clas op_name + in + returnB_Tc (getDefaultMethodId clas op) + + tc_uf_Id lve uf_id@(DictFunUfId c ty) + = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty -> + let + clas = lookupCE rec_ce c + dfun_id = case (lookupClassInstAtSimpleType clas new_ty) of + Just id -> id + Nothing -> pprPanic "tc_uf_Id:DictFunUfId:" + (ppr PprDebug (UfCoVar uf_id)) + -- The class and type are both + -- visible, so the instance should + -- jolly well be too! + in + returnB_Tc dfun_id + + tc_uf_Id lve (ConstMethodUfId c op_name ty) + = tc_uf_type nullTVE ty `thenB_Tc` \ new_ty -> + let + clas = lookupCE rec_ce c + op = lookup_class_op clas op_name + in + returnB_Tc (getConstMethodId clas op new_ty) + + tc_uf_Id lve uf_id@(SpecUfId unspec ty_maybes) + = tc_uf_Id lve unspec `thenB_Tc` \ unspec_id -> + mapB_Tc (tc_ty_maybe rec_ce rec_tce) ty_maybes + `thenB_Tc` \ maybe_tys -> + let + spec_id = lookupSpecId unspec_id maybe_tys + in + returnB_Tc spec_id + + tc_uf_Id lve (WorkerUfId unwrkr) + = tc_uf_Id lve unwrkr `thenB_Tc` \ unwrkr_id -> + let + strictness_info = getIdStrictness unwrkr_id + in + returnB_Tc (getWorkerId strictness_info) + + --------------- + lookup_class_op clas (ClassOpName _ _ _ tag) + = getClassOps clas !! (tag - 1) + + --------------------------------------------------------------------- + tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM UniType + + tc_uf_type tve ty = tcPolyType rec_ce rec_tce tve ty +\end{code} + +%************************************************************************ +%* * +\subsection[tcDataPragmas]{@data@ type pragmas} +%* * +%************************************************************************ + +The purpose of a @data@ pragma is to convey data-constructor +information that would otherwise be unknown. + +It also records specialisation information which is added to each data +constructor. This info just contains the type info for the +specialisations which exist. No specialised Ids are actually created. + +\begin{code} +tcDataPragmas :: TCE -> TVE -> TyCon -> [TyVarTemplate] + -> RenamedDataPragmas + -> Baby_TcM ([RenamedConDecl], -- any pragma condecls + [SpecInfo]) -- specialisation info from pragmas + +tcDataPragmas rec_tce tve rec_tycon new_tyvars (DataPragmas con_decls specs) + = mapB_Tc do_one_spec specs `thenB_Tc` \ spec_infos -> + returnB_Tc (con_decls, spec_infos) + where + do_one_spec maybe_monotys + = mapB_Tc (tc_ty_maybe nullCE rec_tce) maybe_monotys + `thenB_Tc` \ maybe_tys -> + getSrcLocB_Tc `thenB_Tc` \ locn -> + + checkB_Tc (length new_tyvars /= length maybe_tys) + (badSpecialisationErr "data" "wrong number of specialising types" + (length new_tyvars) maybe_tys locn) + `thenB_Tc_` + + checkB_Tc (not (all isUnboxedDataType (catMaybes maybe_tys))) + (badSpecialisationErr "data" "not all unboxed types" + (length new_tyvars) maybe_tys locn) + `thenB_Tc_` + + returnB_Tc (SpecInfo maybe_tys 0 (panic "DataPragma:SpecInfo:SpecId")) +\end{code} + +%************************************************************************ +%* * +\subsection[tcTypePragmas]{@type@ synonym pragmas} +%* * +%************************************************************************ + +The purpose of a @type@ pragma is to say that the synonym's +representation should not be used by the user. + +\begin{code} +tcTypePragmas :: TypePragmas + -> Bool -- True <=> abstract synonym, please + +tcTypePragmas NoTypePragmas = False +tcTypePragmas AbstractTySynonym = True +\end{code} + diff --git a/ghc/compiler/typecheck/TcQuals.hi b/ghc/compiler/typecheck/TcQuals.hi new file mode 100644 index 0000000..2337eec --- /dev/null +++ b/ghc/compiler/typecheck/TcQuals.hi @@ -0,0 +1,19 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcQuals where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import HsExpr(Qual) +import HsPat(InPat, TypecheckedPat) +import Id(Id) +import LIE(LIE) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +tcQuals :: E -> [Qual Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Qual Id TypecheckedPat], LIE) + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcQuals.lhs b/ghc/compiler/typecheck/TcQuals.lhs new file mode 100644 index 0000000..e66d06a --- /dev/null +++ b/ghc/compiler/typecheck/TcQuals.lhs @@ -0,0 +1,55 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% +\section[TcQuals]{TcQuals} + +\begin{code} +#include "HsVersions.h" + +module TcQuals ( tcQuals ) where + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +import AbsPrel ( boolTy, mkListTy ) +import E ( E, TCE(..), UniqFM, CE(..) ) + -- TCE and CE for pragmas only +import Errors ( UnifyErrContext(..) ) +import LIE ( LIE, plusLIE ) +import TcExpr ( tcExpr ) +import TcPat ( tcPat ) +import Unify ( unifyTauTy ) +import Util +\end{code} + +There will be at least one @Qual@. + +\begin{code} +tcQuals :: E -> [RenamedQual] -> TcM ([TypecheckedQual], LIE) + +tcQuals e [qual] + = tcQual e qual `thenTc` \ (new_qual, lie) -> + returnTc ([new_qual], lie) + +tcQuals e (qual:quals) + = tcQual e qual `thenTc` \ (new_qual, lie1) -> + tcQuals e quals `thenTc` \ (new_quals, lie2) -> + returnTc (new_qual : new_quals, lie1 `plusLIE` lie2) + +--- + +tcQual e (FilterQual expr) + = tcExpr e expr `thenTc` \ (expr', lie, ty) -> + unifyTauTy ty boolTy (FilterCtxt expr) `thenTc_` + returnTc (FilterQual expr', lie) + +tcQual e (GeneratorQual pat expr) + = tcPat e pat `thenTc` \ (pat', lie_pat, pat_ty) -> + tcExpr e expr `thenTc` \ (expr', lie_expr, expr_ty) -> + + unifyTauTy expr_ty (mkListTy pat_ty) (GeneratorCtxt pat expr) `thenTc_` + + returnTc (GeneratorQual pat' expr', lie_pat `plusLIE` lie_expr) +\end{code} + + diff --git a/ghc/compiler/typecheck/TcSimplify.hi b/ghc/compiler/typecheck/TcSimplify.hi new file mode 100644 index 0000000..1b8acff --- /dev/null +++ b/ghc/compiler/typecheck/TcSimplify.hi @@ -0,0 +1,34 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcSimplify where +import Bag(Bag) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import ErrsTc(UnifyErrContext) +import HsBinds(MonoBinds) +import HsExpr(Expr) +import HsPat(TypecheckedPat) +import Id(Id) +import Inst(Inst, InstOrigin) +import LIE(LIE) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import TyVar(TyVar) +import UniType(UniType) +bindInstsOfLocalFuns :: LIE -> [Id] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, MonoBinds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "U(S)L" {_A_ 2 _U_ 22222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +tcSimplify :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)], [Inst]) + {-# GHC_PRAGMA _A_ 4 _U_ 1111222122 _N_ _S_ "LSSS" _N_ _N_ #-} +tcSimplifyAndCheck :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)]) + {-# GHC_PRAGMA _A_ 6 _U_ 111112222122 _N_ _S_ "LSSSSL" _N_ _N_ #-} +tcSimplifyCheckThetas :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +tcSimplifyRank2 :: [TyVar] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)]) + {-# GHC_PRAGMA _A_ 3 _U_ 212222122 _N_ _S_ "LSL" _N_ _N_ #-} +tcSimplifyThetas :: (Class -> UniType -> InstOrigin) -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Class, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-} +tcSimplifyTop :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Inst, Expr Id TypecheckedPat)] + {-# GHC_PRAGMA _A_ 1 _U_ 1222122 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs new file mode 100644 index 0000000..126109a --- /dev/null +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -0,0 +1,602 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcSimplify]{TcSimplify} + +\begin{code} +#include "HsVersions.h" + +module TcSimplify ( + tcSimplify, tcSimplifyAndCheck, + tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2, + bindInstsOfLocalFuns + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import TcMonad -- typechecking monadic machinery +import TcMonadFns ( newDicts, applyTcSubstAndExpectTyVars ) +import AbsSyn -- the stuff being typechecked + +import AbsUniType ( isSuperClassOf, getTyVar, eqTyVar, ltTyVar, + instantiateThetaTy, isFunType, getUniDataTyCon, + getSuperDictSelId, InstTyEnv(..) + IF_ATTACK_PRAGMAS(COMMA isTyVarTy COMMA pprUniType) + IF_ATTACK_PRAGMAS(COMMA assocMaybe) + ) +import UniType ( UniType(..) ) -- ******* CHEATING ************ +import Disambig ( disambiguateDicts ) +import Errors ( reduceErr, genCantGenErr, Error(..) ) +import Id ( mkInstId ) +import Inst ( extractTyVarsFromInst, isTyVarDict, matchesInst, + instBindingRequired, instCanBeGeneralised, + Inst(..), -- We import the CONCRETE type, because + -- TcSimplify is allowed to see the rep + -- of Insts + InstOrigin, OverloadedLit, InstTemplate + ) +import InstEnv +import LIE +import ListSetOps ( minusList ) +import Maybes ( catMaybes, maybeToBool, Maybe(..) ) +import Util +\end{code} + + +%************************************************************************ +%* * +\subsection[tcSimplify-main]{Main entry function} +%* * +%************************************************************************ + +* May modify the substitution to bind ambiguous type variables. + +Specification +~~~~~~~~~~~~~ +(1) If an inst constrains only ``global'' type variables, (or none), + return it as a ``global'' inst. + +OTHERWISE + +(2) Simplify it repeatedly (checking for (1) of course) until it is a dict + constraining only a type variable. + +(3) If it constrains a ``local'' type variable, return it as a ``local'' inst. + Otherwise it must be ambiguous, so try to resolve the ambiguity. + + +\begin{code} +tcSimpl :: Bool -- True <=> Don't simplify const insts + -> [TyVar] -- ``Global'' type variables + -> [TyVar] -- ``Local'' type variables + -> [Inst] -- Given; these constrain only local tyvars + -> [Inst] -- Wanted + -> TcM ([Inst], -- Free + [(Inst,TypecheckedExpr)],-- Bindings + [Inst]) -- Remaining wanteds; no dups + +tcSimpl dont_squash_consts global_tvs local_tvs givens wanteds + = + -- Make sure the insts and type variables are fixed points of the substitution + applyTcSubstAndExpectTyVars global_tvs `thenNF_Tc` \ global_tvs -> + applyTcSubstAndExpectTyVars local_tvs `thenNF_Tc` \ local_tvs -> + applyTcSubstToInsts givens `thenNF_Tc` \ givens -> + applyTcSubstToInsts wanteds `thenNF_Tc` \ wanteds -> + let + is_elem1 = isIn "tcSimpl1" + is_elem2 = isIn "tcSimpl2" + in + -- Deal with duplicates and type constructors + elimTyCons + dont_squash_consts (\tv -> tv `is_elem1` global_tvs) + givens wanteds `thenTc` \ (globals, tycon_binds, locals_and_ambigs) -> + + -- Now disambiguate if necessary + let + (ambigs, unambigs) = partition (is_ambiguous local_tvs) locals_and_ambigs + (locals, cant_generalise) = partition instCanBeGeneralised unambigs + in + checkTc (not (null cant_generalise)) (genCantGenErr cant_generalise) `thenTc_` + + (if (null ambigs) then + + -- No ambiguous dictionaries. Just bash on with the results + -- of the elimTyCons + returnTc (globals, tycon_binds, locals_and_ambigs) + + else + + -- Some ambiguous dictionaries. We now disambiguate them, + -- which binds the offending type variables to suitable types in the + -- substitution, and then we retry the whole process. This + -- time there won't be any ambiguous ones. + -- There's no need to back-substitute on global and local tvs, + -- because the ambiguous type variables can't be in either. + + -- Why do we retry the whole process? Because binding a type variable + -- to a particular type might enable a short-cut simplification which + -- elimTyCons will have missed the first time. + + disambiguateDicts ambigs `thenTc_` + applyTcSubstToInsts givens `thenNF_Tc` \ givens -> + applyTcSubstToInsts wanteds `thenNF_Tc` \ wanteds -> + elimTyCons + dont_squash_consts (\tv -> tv `is_elem2` global_tvs) + givens wanteds + + ) {- End of the "if" -} `thenTc` \ (globals, tycon_binds, locals) -> + + -- Deal with superclass relationships + elimSCs givens locals `thenNF_Tc` \ (sc_binds, locals2) -> + + -- Finished + returnTc (globals, sc_binds ++ tycon_binds, locals2) + where + is_ambiguous local_tvs (Dict _ _ ty _) + = getTyVar "is_ambiguous" ty `not_elem` local_tvs + where + not_elem = isn'tIn "is_ambiguous" +\end{code} + +The main wrapper is @tcSimplify@. It just calls @tcSimpl@, but with +the ``don't-squash-consts'' flag set depending on top-level ness. For +top level defns we *do* squash constants, so that they stay local to a +single defn. This makes things which are inlined more likely to be +exportable, because their constants are "inside". Later passes will +float them out if poss, after inlinings are sorted out. + +\begin{code} +tcSimplify + :: Bool -- True <=> top level + -> [TyVar] -- ``Global'' type variables + -> [TyVar] -- ``Local'' type variables + -> [Inst] -- Wanted + -> TcM ([Inst], -- Free + [(Inst, TypecheckedExpr)],-- Bindings + [Inst]) -- Remaining wanteds; no dups + +tcSimplify top_level global_tvs local_tvs wanteds + = tcSimpl (not top_level) global_tvs local_tvs [] wanteds +\end{code} + +@tcSimplifyAndCheck@ is similar to the above, except that it checks +that there is an empty wanted-set at the end. + +It may still return some of constant insts, which have +to be resolved finally at the end. + +\begin{code} +tcSimplifyAndCheck + :: Bool -- True <=> top level + -> [TyVar] -- ``Global'' type variables + -> [TyVar] -- ``Local'' type variables + -> [Inst] -- Given + -> [Inst] -- Wanted + -> UnifyErrContext -- Context info for error + -> TcM ([Inst], -- Free + [(Inst, TypecheckedExpr)]) -- Bindings + +tcSimplifyAndCheck top_level global_tvs local_tvs givens wanteds err_ctxt + = tcSimpl (not top_level) global_tvs local_tvs givens wanteds + `thenTc` \ (free_insts, binds, wanteds') -> + checkTc (not (null wanteds')) (reduceErr wanteds' err_ctxt) + `thenTc_` + returnTc (free_insts, binds) +\end{code} + +@tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function +is not overloaded. + +\begin{code} +tcSimplifyRank2 :: [TyVar] -- ``Local'' type variables; guaranteed fixpoint of subst + -> [Inst] -- Given + -> UnifyErrContext + -> TcM ([Inst], -- Free + [(Inst, TypecheckedExpr)]) -- Bindings + +tcSimplifyRank2 local_tvs givens err_ctxt + = applyTcSubstToInsts givens `thenNF_Tc` \ givens' -> + elimTyCons False + (\tv -> not (tv `is_elem` local_tvs)) + -- This predicate claims that all + -- any non-local tyvars are global, + -- thereby postponing dealing with + -- ambiguity until the enclosing Gen + [] givens' `thenTc` \ (free, dict_binds, wanteds) -> + + checkTc (not (null wanteds)) (reduceErr wanteds err_ctxt) `thenTc_` + + returnTc (free, dict_binds) + where + is_elem = isIn "tcSimplifyRank2" +\end{code} + +@tcSimplifyTop@ deals with constant @Insts@, using the standard simplification +mechansim with the extra flag to say ``beat out constant insts''. + +\begin{code} +tcSimplifyTop :: [Inst] -> TcM [(Inst, TypecheckedExpr)] +tcSimplifyTop dicts + = tcSimpl False [] [] [] dicts `thenTc` \ (_, binds, _) -> + returnTc binds +\end{code} + +@tcSimplifyThetas@ simplifies class-type constraints formed by +@deriving@ declarations and when specialising instances. We are +only interested in the simplified bunch of class/type constraints. + +\begin{code} +tcSimplifyThetas :: (Class -> TauType -> InstOrigin) -- Creates an origin for the dummy dicts + -> [(Class, TauType)] -- Simplify this + -> TcM [(Class, TauType)] -- Result + +tcSimplifyThetas mk_inst_origin theta + = let + dicts = map mk_dummy_dict theta + in + -- Do the business (this is just the heart of "tcSimpl") + elimTyCons False (\tv -> False) [] dicts `thenTc` \ (_, _, dicts2) -> + + -- Deal with superclass relationships + elimSCs [] dicts2 `thenNF_Tc` \ (_, dicts3) -> + + returnTc (map unmk_dummy_dict dicts3) + where + mk_dummy_dict (clas, ty) + = Dict uniq clas ty (mk_inst_origin clas ty) + + uniq = panic "tcSimplifyThetas:uniq" + + unmk_dummy_dict (Dict _ clas ty _) = (clas, ty) +\end{code} + +@tcSimplifyCheckThetas@ just checks class-type constraints, essentially; +used with \tr{default} declarations. We are only interested in +whether it worked or not. + +\begin{code} +tcSimplifyCheckThetas :: InstOrigin -- context; for error msg + -> [(Class, TauType)] -- Simplify this + -> TcM () + +tcSimplifyCheckThetas origin theta + = let + dicts = map mk_dummy_dict theta + in + -- Do the business (this is just the heart of "tcSimpl") + elimTyCons False (\tv -> False) [] dicts `thenTc` \ _ -> + + returnTc () + where + mk_dummy_dict (clas, ty) + = Dict uniq clas ty origin + + uniq = panic "tcSimplifyCheckThetas:uniq" +\end{code} + + +%************************************************************************ +%* * +\subsection[elimTyCons]{@elimTyCons@} +%* * +%************************************************************************ + +\begin{code} +elimTyCons :: Bool -- True <=> Don't simplify const insts + -> (TyVar -> Bool) -- Free tyvar predicate + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM ([Inst], -- Free + [(Inst, TypecheckedExpr)], -- Bindings + [Inst] -- Remaining wanteds; no dups; + -- dicts only (no Methods) + ) +\end{code} + +The bindings returned may mention any or all of ``givens'', so the +order in which the generated binds are put together is {\em tricky}. +Case~4 of @try@ is the general case to see. + +When we do @eTC givens (wanted:wanteds)@ [some details omitted], we... + + (1) first look up @wanted@; this gives us one binding to heave in: + wanted = rhs + + (2) step (1) also gave us some @simpler_wanteds@; we simplify + these and get some (simpler-wanted-)bindings {\em that must be + in scope} for the @wanted=rhs@ binding above! + + (3) we simplify the remaining @wanteds@ (recursive call), giving + us yet more bindings. + +The final arrangement of the {\em non-recursive} bindings is + + let in + let wanted = rhs in + let ... + +\begin{code} +elimTyCons dont_squash_consts is_free_tv givens wanteds + = eTC givens wanteds + where + eTC :: [Inst] -> [Inst] + -> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst]) + + eTC _ [] = returnTc ([], [], []) + + eTC givens (wanted:wanteds) = try givens wanted wanteds + (extractTyVarsFromInst wanted) + (find_equiv givens wanted) + -- find_equiv looks in "givens" for an inst equivalent to "wanted" + -- This is used only in Case 2 below; it's like a guard which also + -- returns a result. + + try :: [Inst] -> Inst -> [Inst] -> [TyVar] -> (Maybe Inst) + -> TcM ([Inst], [(Inst, TypecheckedExpr)], [Inst]) + + -- Case 0: same as existing dict, so build a simple binding + try givens wanted wanteds tvs_of_wanted (Just this) + = eTC givens wanteds `thenTc` \ (frees, binds, wanteds') -> + let + -- Create a new binding iff it's needed + new_binds | instBindingRequired wanted = (wanted, Var (mkInstId this)):binds + | otherwise = binds + in + returnTc (frees, new_binds, wanteds') + + -- Case 1: constrains no type variables at all + -- In this case we have a quick go to see if it has an + -- instance which requires no inputs (ie a constant); if so we use + -- it; if not, we give up on the instance and just heave it out the + -- top in the free result + try givens wanted wanteds tvs_of_wanted _ | null tvs_of_wanted + = simplify_it dont_squash_consts {- If dont_squash_consts is true, + simplify only if trival -} + givens wanted wanteds + + -- Case 2: constrains free vars only, so fling it out the top in free_ids + try givens wanted wanteds tvs_of_wanted _ + | all is_free_tv tvs_of_wanted + = eTC (wanted:givens) wanteds `thenTc` \ (frees, binds, wanteds') -> + returnTc (wanted:frees, binds, wanteds') + + -- Case 3: is a dict constraining only a tyvar, + -- so return it as part of the "wanteds" result + try givens wanted wanteds tvs_of_wanted _ + | isTyVarDict wanted + = eTC (wanted:givens) wanteds `thenTc` \ (frees, binds, wanteds') -> + returnTc (frees, binds, wanted:wanteds') + + -- Case 4: is not a simple dict, so look up in instance environment + try givens wanted wanteds tvs_of_wanted _ + = simplify_it False {- Simplify even if not trivial -} + givens wanted wanteds + + simplify_it only_if_trivial givens wanted wanteds + = if not (instBindingRequired wanted) then + -- No binding required for this chap, so squash right away + lookupNoBindInst_Tc wanted `thenTc` \ simpler_wanteds -> + + eTC givens simpler_wanteds `thenTc` \ (frees1, binds1, wanteds1) -> + let + new_givens = [new_given | (new_given,rhs) <- binds1] + -- Typically binds1 is empty + in + eTC givens wanteds `thenTc` \ (frees2, binds2, wanteds2) -> + + returnTc (frees1 ++ frees2, + binds1 ++ binds2, + wanteds1 ++ wanteds2) + + else -- An binding is required for this inst + lookupInst_Tc wanted `thenTc` \ (rhs, simpler_wanteds) -> + + if (only_if_trivial && not_var rhs) then + -- Ho ho! It isn't trivial to simplify "wanted", + -- because the rhs isn't a simple variable. The flag + -- dont_squash_consts tells us to give up now and + -- just fling it out the top. + eTC (wanted:givens) wanteds `thenTc` \ (frees, binds, wanteds') -> + returnTc (wanted:frees, binds, wanteds') + else + -- Aha! Either it's easy, or dont_squash_consts is + -- False, so we must do it right here. + + eTC givens simpler_wanteds `thenTc` \ (frees1, binds1, wanteds1) -> + let + new_givens = [new_given | (new_given,rhs) <- binds1] + in + eTC (new_givens ++ [wanted] ++ wanteds1 ++ givens) wanteds + `thenTc` \ (frees2, binds2, wanteds2) -> + returnTc (frees1 ++ frees2, + binds1 ++ [(wanted, rhs)] ++ binds2, + wanteds1 ++ wanteds2) + where + not_var :: TypecheckedExpr -> Bool + not_var (Var _) = False + not_var other = True + + find_equiv :: [Inst] -> Inst -> Maybe Inst + -- Look through the argument list for an inst which is + -- equivalent to the second arg. + + find_equiv [] wanted = Nothing + find_equiv (given:givens) wanted + | wanted `matchesInst` given = Just given + | otherwise = find_equiv givens wanted +\end{code} + + +%************************************************************************ +%* * +\subsection[elimSCs]{@elimSCs@} +%* * +%************************************************************************ + +\begin{code} +elimSCs :: [Inst] -- Given; no dups + -> [Inst] -- Wanted; no dups; all dictionaries, all + -- constraining just a type variable + -> NF_TcM ([(Inst,TypecheckedExpr)], -- Bindings + [Inst]) -- Minimal wanted set + +elimSCs givens wanteds + = -- Sort the wanteds so that subclasses occur before superclasses + elimSCs_help + [dict | dict@(Dict _ _ _ _) <- givens] -- Filter out non-dictionaries + (sortSC wanteds) + +elimSCs_help :: [Inst] -- Given; no dups + -> [Inst] -- Wanted; no dups; + -> NF_TcM ([(Inst,TypecheckedExpr)],-- Bindings + [Inst]) -- Minimal wanted set + +elimSCs_help given [] = returnNF_Tc ([], []) + +elimSCs_help givens (wanted@(Dict _ wanted_class wanted_ty wanted_orig):wanteds) + = case (trySC givens wanted_class wanted_ty) of + + Nothing -> -- No superclass relnship found + elimSCs_help (wanted:givens) wanteds `thenNF_Tc` \ (binds, wanteds') -> + returnNF_Tc (binds, wanted:wanteds') + + Just (given, classes) -> -- Aha! There's a superclass relnship + + -- Build intermediate dictionaries + let + theta = [ (clas, wanted_ty) | clas <- classes ] + in + newDicts wanted_orig theta `thenNF_Tc` \ intermediates -> + + -- Deal with the recursive call + elimSCs_help (wanted : (intermediates ++ givens)) wanteds + `thenNF_Tc` \ (binds, wanteds') -> + + -- Create bindings for the wanted dictionary and the intermediates. + -- Later binds may depend on earlier ones, so each new binding is pushed + -- on the front of the accumulating parameter list of bindings + let + new_binds = mk_binds wanted wanted_class (intermediates ++ [given]) [] + in + returnNF_Tc (new_binds ++ binds, wanteds') + where + mk_binds :: Inst -- Define this + -> Class -- ...whose class is this + -> [Inst] -- In terms of this sub-class chain + -> [(Inst, TypecheckedExpr)] -- Push the binding on front of these + -> [(Inst, TypecheckedExpr)] + + mk_binds dict clas [] binds_so_far = binds_so_far + mk_binds dict clas (dict_sub@(Dict _ dict_sub_class ty _):dicts_sub) binds_so_far + = mk_binds dict_sub dict_sub_class dicts_sub (new_bind:binds_so_far) + where + new_bind = (dict, DictApp (TyApp (Var (getSuperDictSelId dict_sub_class clas)) + [ty]) + [mkInstId dict_sub]) + + +trySC :: [Inst] -- Givens + -> Class -> UniType -- Wanted + -> Maybe (Inst, [Class]) -- Nothing if no link; Just (given, classes) + -- if wanted can be given in terms of given, with + -- intermediate classes specified +trySC givens wanted_class wanted_ty + = case subclass_relns of + [] -> Nothing + ((given, classes, _): _) -> Just (given, classes) + where + subclass_relns :: [(Inst, [Class], Int)] -- Subclass of wanted, + -- intervening classes, + -- and number of intervening classes + -- Sorted with shortest link first + subclass_relns = sortLt reln_lt (catMaybes (map find_subclass_reln givens)) + + reln_lt :: (Inst, [Class], Int) -> (Inst, [Class], Int) -> Bool + (_,_,n1) `reln_lt` (_,_,n2) = n1 < n2 + + find_subclass_reln given@(Dict _ given_class given_ty _) + | wanted_ty == given_ty + = case (wanted_class `isSuperClassOf` given_class) of + + Just classes -> Just (given, + classes, + length classes) + + Nothing -> Nothing + + | otherwise = Nothing + + +sortSC :: [Inst] -- Expected to be all dicts (no MethodIds), all of + -- which constrain type variables + -> [Inst] -- Sorted with subclasses before superclasses + +sortSC dicts = sortLt lt dicts + where + (Dict _ c1 ty1 _) `lt` (Dict _ c2 ty2 _) + = tv1 `ltTyVar` tv2 || + (tv1 `eqTyVar` tv2 && maybeToBool (c2 `isSuperClassOf` c1)) + where + tv1 = getTyVar "sortSC" ty1 + tv2 = getTyVar "sortSC" ty2 +\end{code} + + +%************************************************************************ +%* * +\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@} +%* * +%************************************************************************ + +When doing a binding group, we may have @Insts@ of local functions. +For example, we might have... +\begin{verbatim} +let f x = x + 1 -- orig local function (overloaded) + f.1 = f Int -- two instances of f + f.2 = f Float + in + (f.1 5, f.2 6.7) +\end{verbatim} +The point is: we must drop the bindings for @f.1@ and @f.2@ here, +where @f@ is in scope; those @Insts@ must certainly not be passed +upwards towards the top-level. If the @Insts@ were binding-ified up +there, they would have unresolvable references to @f@. + +We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@. +For each method @Inst@ in the @init_lie@ that mentions one of the +@Ids@, we create a binding. We return the remaining @Insts@ (in an +@LIE@), as well as the @Binds@ generated. + +\begin{code} +bindInstsOfLocalFuns :: LIE -> [Id] -> NF_TcM (LIE, TypecheckedMonoBinds) + +bindInstsOfLocalFuns init_lie local_ids + = let + insts = unMkLIE init_lie + in + bind_insts insts [] EmptyMonoBinds + where + bind_insts :: [Inst] -- Insts to mangle + -> [Inst] -- accum. Insts to return + -> TypecheckedMonoBinds -- accum. Binds to return + -> NF_TcM (LIE, TypecheckedMonoBinds) + + bind_insts [] acc_insts acc_binds + = returnNF_Tc (mkLIE acc_insts, acc_binds) + + bind_insts (inst@(Method uniq id tys orig):insts) acc_insts acc_binds + | id `is_elem` local_ids + = noFailTc (lookupInst_Tc inst) `thenNF_Tc` \ (expr, dict_insts) -> + let + bind = VarMonoBind (mkInstId inst) expr + in + bind_insts insts (dict_insts ++ acc_insts) (bind `AndMonoBinds` acc_binds) + + bind_insts (some_other_inst:insts) acc_insts acc_binds + -- Either not a method, or a method instance for an id not in local_ids + = bind_insts insts (some_other_inst:acc_insts) acc_binds + + is_elem = isIn "bindInstsOfLocalFuns" +\end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.hi b/ghc/compiler/typecheck/TcTyDecls.hi new file mode 100644 index 0000000..fbccc96 --- /dev/null +++ b/ghc/compiler/typecheck/TcTyDecls.hi @@ -0,0 +1,20 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TcTyDecls where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import E(E) +import FiniteMap(FiniteMap) +import HsDecls(DataTypeSig, TyDecl) +import Id(Id) +import Maybes(Labda) +import Name(Name) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcMonad(Baby_TcResult) +import TyCon(TyCon) +import UniType(UniType) +import UniqFM(UniqFM) +tcTyDecls :: E -> (Name -> Bool) -> (Name -> [DataTypeSig Name]) -> [TyDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (UniqFM TyCon, [(Name, Id)], FiniteMap TyCon [[Labda UniType]]) + {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs new file mode 100644 index 0000000..f120a8a --- /dev/null +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -0,0 +1,280 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TcTyDecls]{Typecheck algebraic datatypes and type synonyms} + +\begin{code} +#include "HsVersions.h" + +module TcTyDecls ( tcTyDecls ) where + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +import AbsUniType ( applyTyCon, mkDataTyCon, mkSynonymTyCon, + getUniDataTyCon, isUnboxedDataType, + isTyVarTemplateTy, cmpUniTypeMaybeList, + pprMaybeTy + ) +import CE ( lookupCE, CE(..) ) +import CmdLineOpts ( GlobalSwitch(..) ) +import E ( getE_TCE, getE_CE, plusGVE, nullGVE, GVE(..), E ) +import ErrUtils ( addShortErrLocLine ) +import Errors ( confusedNameErr, specDataNoSpecErr, specDataUnboxedErr ) +import FiniteMap ( FiniteMap, emptyFM, plusFM, singletonFM ) +import IdInfo ( SpecEnv, mkSpecEnv, SpecInfo(..) ) +import Pretty +import SpecTyFuns ( specialiseConstrTys ) +import TCE -- ( nullTCE, unitTCE, lookupTCE, plusTCE, TCE(..), UniqFM ) +import TVE ( mkTVE, TVE(..) ) +import TcConDecls ( tcConDecls ) +import TcMonoType ( tcMonoType ) +import TcPragmas ( tcDataPragmas, tcTypePragmas ) +import Util +\end{code} + +We consult the @CE@/@TCE@ arguments {\em only} to build knots! + +The resulting @TCE@ has info about the type constructors in it; the +@GVE@ has info about their data constructors. + +\begin{code} +tcTyDecls :: E + -> (Name -> Bool) -- given Name, is it an abstract synonym? + -> (Name -> [RenamedDataTypeSig]) -- given Name, get specialisation pragmas + -> [RenamedTyDecl] + -> Baby_TcM (TCE, GVE, + FiniteMap TyCon [[Maybe UniType]]) + -- specialisations: + -- local data types: requsted by source pragmas + -- imported data types: from interface file + +tcTyDecls e _ _ [] = returnB_Tc (nullTCE, nullGVE, emptyFM) + +tcTyDecls e is_abs_syn get_spec_sigs (tyd: tyds) + = tc_decl tyd `thenB_Tc` \ (tce1, gve1, specs1) -> + tcTyDecls e is_abs_syn get_spec_sigs tyds + `thenB_Tc` \ (tce2, gve2, specs2) -> + let + tce3 = tce1 `plusTCE` tce2 + gve3 = gve1 `plusGVE` gve2 + specs3 = specs1 `plusFM` specs2 + in + returnB_Tc (tce3, gve3, specs3) + where + rec_ce = getE_CE e + rec_tce = getE_TCE e + + -- continued... +\end{code} + +We don't need to substitute here, because the @TCE@s +(which are at the top level) cannot contain free type variables. + +Gather relevant info: +\begin{code} + tc_decl (TyData context name@(PreludeTyCon uniq full_name arity True{-"data"-}) + tyvars con_decls derivings pragmas src_loc) + -- ToDo: context + = tc_data_decl uniq name full_name arity tyvars con_decls + derivings pragmas src_loc + + tc_decl (TyData context name@(OtherTyCon uniq full_name arity True{-"data"-} _) + tyvars con_decls derivings pragmas src_loc) + -- ToDo: context + = tc_data_decl uniq name full_name arity tyvars con_decls + derivings pragmas src_loc + + tc_decl (TyData _ bad_name _ _ _ _ src_loc) + = failB_Tc (confusedNameErr "Bad name on a datatype constructor (a Prelude name?)" + bad_name src_loc) + + tc_decl (TySynonym name@(PreludeTyCon uniq full_name arity False{-"type"-}) + tyvars mono_ty pragmas src_loc) + = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc + + tc_decl (TySynonym name@(OtherTyCon uniq full_name arity False{-"type"-} _) + tyvars mono_ty pragmas src_loc) + = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc + + tc_decl (TySynonym bad_name _ _ _ src_loc) + = failB_Tc (confusedNameErr "Bad name on a type-synonym constructor (a Prelude name?)" + bad_name src_loc) +\end{code} + +Real work for @data@ declarations: +\begin{code} + tc_data_decl uniq name full_name arity tyvars con_decls derivings pragmas src_loc + = addSrcLocB_Tc src_loc ( + let + (tve, new_tyvars, _) = mkTVE tyvars + rec_tycon = lookupTCE rec_tce name + -- We know the lookup will succeed, because we are just + -- about to put it in the outgoing TCE! + + spec_sigs = get_spec_sigs name + in + tcSpecDataSigs rec_tce spec_sigs [] `thenB_Tc` \ user_spec_infos -> + + recoverIgnoreErrorsB_Tc ([], []) ( + tcDataPragmas rec_tce tve rec_tycon new_tyvars pragmas + ) `thenB_Tc` \ (pragma_con_decls, pragma_spec_infos) -> + let + (condecls_to_use, ignore_condecl_errors_if_pragma) + = if null pragma_con_decls then + (con_decls, id) + else + if null con_decls + then (pragma_con_decls, recoverIgnoreErrorsB_Tc nullGVE) + else panic "tcTyDecls:data: user and pragma condecls!" + + specinfos_to_use + = if null pragma_spec_infos then + user_spec_infos + else + if null user_spec_infos + then pragma_spec_infos + else panic "tcTyDecls:data: user and pragma specinfos!" + + specenv_to_use = mkSpecEnv specinfos_to_use + in + ignore_condecl_errors_if_pragma + (tcConDecls rec_tce tve rec_tycon new_tyvars specenv_to_use condecls_to_use) + `thenB_Tc` \ gve -> + let + condecls = map snd gve + + derived_classes = map (lookupCE rec_ce) derivings + + new_tycon + = mkDataTyCon uniq + full_name arity new_tyvars condecls + derived_classes + (null pragma_con_decls) + -- if constrs are from pragma we are *abstract* + + spec_list + = map (\ (SpecInfo maybe_tys _ _) -> maybe_tys) specinfos_to_use + + spec_map + = if null spec_list then + emptyFM + else + singletonFM rec_tycon spec_list + in + returnB_Tc (unitTCE uniq new_tycon, gve, spec_map) + -- It's OK to return pragma condecls in gve, even + -- though some of those names should be "invisible", + -- because the *renamer* is supposed to have dealt with + -- naming/scope issues already. + ) +\end{code} + +Real work for @type@ (synonym) declarations: +\begin{code} + tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc + = addSrcLocB_Tc src_loc ( + + let (tve, new_tyvars, _) = mkTVE tyvars + in + tcMonoType rec_ce rec_tce tve mono_ty `thenB_Tc` \ expansion -> + let + -- abstractness info either comes from the interface pragmas + -- (tcTypePragmas) or from a user-pragma in this module + -- (is_abs_syn) + abstract = tcTypePragmas pragmas + || is_abs_syn name + + new_tycon = mkSynonymTyCon uniq full_name + arity new_tyvars expansion (not abstract) + in + returnB_Tc (unitTCE uniq new_tycon, nullGVE, emptyFM) + ) +\end{code} + +%************************************************************************ +%* * +\subsection{Specialisation Signatures for Data Type declarations} +%* * +%************************************************************************ + +@tcSpecDataSigs@ checks data type specialisation signatures for +validity, and returns the list of specialisation requests. + +\begin{code} +tcSpecDataSigs :: TCE + -> [RenamedDataTypeSig] + -> [(RenamedDataTypeSig,SpecInfo)] + -> Baby_TcM [SpecInfo] + +tcSpecDataSigs tce (s:ss) accum + = tc_sig s `thenB_Tc` \ info -> + tcSpecDataSigs tce ss ((s,info):accum) + where + tc_sig (SpecDataSig n ty src_loc) + = addSrcLocB_Tc src_loc ( + let + ty_names = extractMonoTyNames (==) ty + (tve,_,_) = mkTVE ty_names + fake_CE = panic "tcSpecDataSigs:CE" + in + -- Typecheck specialising type (includes arity check) + tcMonoType fake_CE tce tve ty `thenB_Tc` \ tau_ty -> + let + (_,ty_args,_) = getUniDataTyCon tau_ty + is_unboxed_or_tyvar ty = isUnboxedDataType ty || isTyVarTemplateTy ty + in + -- Check at least one unboxed type in specialisation + checkB_Tc (not (any isUnboxedDataType ty_args)) + (specDataNoSpecErr n ty_args src_loc) `thenB_Tc_` + + -- Check all types are unboxed or tyvars + -- (specific boxed types are redundant) + checkB_Tc (not (all is_unboxed_or_tyvar ty_args)) + (specDataUnboxedErr n ty_args src_loc) `thenB_Tc_` + + let + maybe_tys = specialiseConstrTys ty_args + in + returnB_Tc (SpecInfo maybe_tys 0 (panic "SpecData:SpecInfo:SpecId")) + ) + +tcSpecDataSigs tce [] accum + = -- Remove any duplicates from accumulated specinfos + getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr -> + + (if sw_chkr SpecialiseTrace && not (null duplicates) then + pprTrace "Duplicate SPECIALIZE data pragmas:\n" + (ppAboves (map specmsg sep_dups)) + else id)( + + (if sw_chkr SpecialiseTrace && not (null spec_infos) then + pprTrace "Specialising " + (ppHang (ppCat [ppr PprDebug name, ppStr "at types:"]) + 4 (ppAboves (map pp_spec spec_infos))) + + else id) ( + + returnB_Tc (spec_infos) + )) + where + spec_infos = map (snd . head) equiv + + equiv = equivClasses cmp_info accum + duplicates = filter (not . singleton) equiv + + cmp_info (_, SpecInfo tys1 _ _) (_, SpecInfo tys2 _ _) + = cmpUniTypeMaybeList tys1 tys2 + + singleton [_] = True + singleton _ = False + + sep_dups = tail (concat (map ((:) Nothing . map Just) duplicates)) + specmsg (Just (SpecDataSig _ ty locn, _)) + = addShortErrLocLine locn ( \ sty -> ppr sty ty ) PprDebug + specmsg Nothing + = ppStr "***" + + ((SpecDataSig name _ _, _):_) = accum + pp_spec (SpecInfo tys _ _) = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- tys] +\end{code} diff --git a/ghc/compiler/typecheck/Typecheck.hi b/ghc/compiler/typecheck/Typecheck.hi new file mode 100644 index 0000000..9fcfb2d --- /dev/null +++ b/ghc/compiler/typecheck/Typecheck.hi @@ -0,0 +1,64 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Typecheck where +import AbsSyn(Module) +import Bag(Bag) +import CE(CE(..)) +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import E(E) +import ErrUtils(Error(..)) +import FiniteMap(FiniteMap) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsImpExp(IE, ImportedInterface) +import HsLit(Literal) +import HsMatches(Match) +import HsPat(InPat, RenamedPat(..), TypecheckedPat) +import HsTypes(PolyType) +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Inst(Inst, InstOrigin, OverloadedLit) +import Maybes(Labda, MaybeErr) +import Name(Name) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import ProtoName(ProtoName) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import TcInstDcls(InstInfo) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique) +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +type CE = UniqFM Class +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-} +type Error = PprStyle -> Int -> Bool -> PrettyRep +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +type RenamedPat = InPat Name +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data InstInfo {-# GHC_PRAGMA InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +typecheckModule :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> MaybeErr ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [[Labda UniType]], E, PprStyle -> Int -> Bool -> PrettyRep) (Bag (PprStyle -> Int -> Bool -> PrettyRep)) + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LLLU(LAALSLLLLLLLL)" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs new file mode 100644 index 0000000..3d012df --- /dev/null +++ b/ghc/compiler/typecheck/Typecheck.lhs @@ -0,0 +1,83 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Typecheck]{Outside-world interfaces to the typechecker} + +\begin{code} +#include "HsVersions.h" + +module Typecheck ( + typecheckModule, + + -- and to make the interface self-sufficient... + Module, Bag, CE(..), Binds, FixityDecl, E, Expr, InPat, + RenamedPat(..), TypecheckedPat, Id, Inst, Maybe, MaybeErr, + Name, PprStyle, PrettyRep, ProtoName, Error(..), Pretty(..), + InstInfo, SplitUniqSupply, GlobalSwitch, UniqFM + ) where + +import TcMonad -- typechecking monad machinery +import AbsSyn -- the stuff being typechecked + +import E ( nullE, E ) +import Maybes ( MaybeErr(..) ) +import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) +import TcModule -- tcModule, and associated stuff +import Util -- for pragmas only +\end{code} + +The typechecker stuff lives inside a complicated world of @TcM@ +monadery. This module provides three interfaces into that world, one +for typechecking a module, another for typechecking an expression, and +one for typechecking an interface. This last one works as if +@typecheckModule@ was applied to the very simple module: +\begin{verbatim} +module EmptyModule where + +import InterfaceOfInterest +\end{verbatim} +This is used when we want to augment an @E@ with information from an +interface. (Used in the interpreter.) + +\begin{code} +typecheckModule :: + (GlobalSwitch -> Bool) -- cmd-line switch checker + -> SplitUniqSupply -- name supply in + -> GlobalNameFuns -- renamer info (for doing derivings) + -> RenamedModule -- input module + + -> ------- OUTPUTS ----------- + -- depends v much on whether typechecking succeeds or not! + MaybeErr + -- SUCCESS ... + (((TypecheckedBinds, -- binds from class decls; does NOT + -- include default-methods bindings + TypecheckedBinds, -- binds from instance decls; INCLUDES + -- class default-methods binds + TypecheckedBinds, -- binds from value decls + [(Inst, TypecheckedExpr)]), + + ([RenamedFixityDecl], -- things for the interface generator + [Id], -- to look at... + CE, + TCE, + Bag InstInfo), + + FiniteMap TyCon [[Maybe UniType]], + -- source tycon specialisation requests + +--UNUSED: E, -- new cumulative E (with everything) + E, -- E just for stuff from THIS module + -- NB: if you want the diff between two prev Es: i.e., + -- things in cumulative E that were added because of + -- this module's import-ery, just do: + -- bigE `minusE` thisModuleE + + PprStyle->Pretty)) -- stuff to print for -ddump-deriving + + -- FAILURE ... + (Bag Error) -- pretty-print this to find out what went wrong + +typecheckModule sw_chkr us renamer_name_funs modyule + = initTc sw_chkr us (tcModule nullE renamer_name_funs modyule) +\end{code} diff --git a/ghc/compiler/typecheck/Unify.hi b/ghc/compiler/typecheck/Unify.hi new file mode 100644 index 0000000..412dc07 --- /dev/null +++ b/ghc/compiler/typecheck/Unify.hi @@ -0,0 +1,18 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Unify where +import Bag(Bag) +import CmdLineOpts(GlobalSwitch) +import ErrsTc(UnifyErrContext) +import Pretty(PprStyle, PrettyRep) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc) +import Subst(Subst) +import TcMonad(TcResult) +import UniType(UniType) +unifyTauTy :: UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "SSL" _N_ _N_ #-} +unifyTauTyList :: [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "SL" _N_ _N_ #-} +unifyTauTyLists :: [UniType] -> [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult () + {-# GHC_PRAGMA _A_ 3 _U_ 112222222 _N_ _S_ "SSL" _N_ _N_ #-} + diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs new file mode 100644 index 0000000..cd218cb --- /dev/null +++ b/ghc/compiler/typecheck/Unify.lhs @@ -0,0 +1,360 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Unify]{Unifier} + +The unifier is now squarely in the typechecker monad (because of the +updatable substitution). + +\begin{code} +#include "HsVersions.h" + +module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) where + +IMPORT_Trace -- ToDo: rm (debugging only) +import Outputable +import Pretty + +import AbsSyn +import TcMonad + +import CmdLineOpts ( GlobalSwitch(..) ) +import Errors ( unifyErr, UnifyErrInfo(..), UnifyErrContext ) +import Id ( Id, DataCon(..), Inst ) +import Maybes ( Maybe(..) ) +import Subst ( extendSubst, SubstResult(..), Subst ) +#if USE_ATTACK_PRAGMAS +import Class ( Class(..), cmpClass ) -- .. for pragmas only +import TyCon ( TyCon(..), isBoxedTyCon, isVisibleSynTyCon, cmpTyCon ) + -- .. on TyCon is for pragmas only +import TyVar -- make all visible for pragmas +import UniTyFuns ( pprUniType, pprTyCon ) +#else +import Class ( Class ) +import TyVar ( TyVar(..), TyVarTemplate ) +import TyCon ( TyCon, isBoxedTyCon, isVisibleSynTyCon ) +#endif +import UniType ( UniType(..), TauType(..) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Unify-spec]{Specification} +%* * +%************************************************************************ + +CLAIM: the unifier works correctly even if the types to be unified are not +fixed points of the substitution. + +%************************************************************************ +%* * +\subsection[Unify-exported]{Exported unification functions} +%* * +%************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. + +Unify two @TauType@s. Dead straightforward. + +\begin{code} +unifyTauTy :: TauType -> TauType -> UnifyErrContext -> TcM () + +unifyTauTy ty1 ty2 err_ctxt = uTys ty1 ty1 ty2 ty2 err_ctxt +\end{code} + +@unifyTauTyLists@ unifies corresponding elements of its two list +arguments. The lists should be of equal length. + +\begin{code} +unifyTauTyLists :: [TauType] -> [TauType] -> UnifyErrContext -> TcM () + +unifyTauTyLists tys1 tys2 err_ctxt = uList tys1 tys2 err_ctxt +\end{code} + +@unifyTauTyList@ takes a single list of @TauType@s and unifies them +all together. It is used, for example, when typechecking explicit +lists, when all the elts should be of the same type. + +\begin{code} +unifyTauTyList :: [TauType] -> UnifyErrContext -> TcM () + +unifyTauTyList [] _ = returnTc () +unifyTauTyList [ty] _ = returnTc () + +unifyTauTyList (ty1:tys@(ty2:_)) err_ctxt + = unifyTauTy ty1 ty2 err_ctxt `thenTc_` + unifyTauTyList tys err_ctxt +\end{code} + +%************************************************************************ +%* * +\subsection[Unify-lists-of-types]{@uList@} +%* * +%************************************************************************ + +@uList@ unifies corresponding elements of two lists of @TauType@s. It +uses @uTys@ to do the real work. We charge down the list explicitly +so that we can complain if their lengths differ. + +\begin{code} +uList :: [TauType] -> [TauType] + -> UnifyErrContext + -> TcM () + +uList [] [] _ = returnTc () + +uList (ty1:tys1) (ty2:tys2) err_ctxt + = uTys ty1 ty1 ty2 ty2 err_ctxt `thenTc_` + uList tys1 tys2 err_ctxt + +uList ty1s ty2s _ = panic "Unify.uList: mismatched type lists!" +\end{code} + +%************************************************************************ +%* * +\subsection[Unify-uTys]{@uTys@: getting down to business} +%* * +%************************************************************************ + +@uTys@ is the heart of the unifier. Each arg happens twice, because +we want to report errors in terms of synomyms if poss. The first of +the pair is used in error messages only; it is always the same as the +second, except that if the first is a synonym then the second may be a +de-synonym'd version. This way we get better error messages. + +We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''. + +\begin{code} +uTys :: TauType -> TauType -- Error reporting ty1 and real ty1 + -> TauType -> TauType -- Error reporting ty2 and real ty2 + -> UnifyErrContext + -> TcM () +\end{code} + +%******************************************************** +%* * +Sanity check: should never find a UniTyVarTemplate +%* * +%******************************************************** + +\begin{code} +#ifdef DEBUG + +uTys ps_ty1 ty1@(UniTyVarTemplate tv1) ps_ty2 ty2 err_ctxt + = pprPanic "Unify:uTys:unifying w/ UniTyVarTemplate(1):" (ppCat [ppr PprDebug tv1, ppr PprDebug ty2]) + +uTys ps_ty1 ty1 ps_ty2 ty2@(UniTyVarTemplate tv2) err_ctxt + = pprPanic "Unify:uTys:unifying w/ UniTyVarTemplate(2):" (ppCat [ppr PprDebug ty1, ppr PprDebug tv2]) + +#endif {-DEBUG-} +\end{code} + +%******************************************************** +%* * +Both variables: +%* * +%******************************************************** + +\begin{code} +uTys ps_ty1 (UniTyVar tyvar1) ps_ty2 ty2 err_ctxt = uVar tyvar1 ps_ty2 ty2 err_ctxt +uTys ps_ty1 ty1 ps_ty2 (UniTyVar tyvar2) err_ctxt = uVar tyvar2 ps_ty1 ty1 err_ctxt +\end{code} + +%******************************************************** +%* * +Both function constructors: +%* * +%******************************************************** + +\begin{code} +uTys _ (UniFun fun1 arg1) _ (UniFun fun2 arg2) err_ctxt + = uList [fun1, arg1] [fun2, arg2] err_ctxt +\end{code} + +%******************************************************** +%* * +Both datatype constructors: +%* * +%******************************************************** + +\begin{code} +uTys ps_ty1 ty1@(UniData con1 args1) ps_ty2 ty2@(UniData con2 args2) err_ctxt + = if (con1 == con2) then + -- Same constructors, just unify the arguments + uList args1 args2 err_ctxt + else + -- Different constructors: disaster + getSrcLocTc `thenNF_Tc` \ src_loc -> + failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc) +\end{code} + +%******************************************************** +%* * +Type synonyms: +%* * +%******************************************************** + +If just one or the other is a synonym, just expand it. + +\begin{code} +uTys ps_ty1 (UniSyn con1 args1 ty1) ps_ty2 ty2 err_ctxt + | isVisibleSynTyCon con1 + = uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt + +uTys ps_ty1 ty1 ps_ty2 (UniSyn con2 args2 ty2) err_ctxt + | isVisibleSynTyCon con2 + = uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt +\end{code} + +If you are tempted to make a short cut on synonyms, as in this +pseudocode... + +\begin{verbatim} +uTys (UniSyn con1 args1 ty1) (UniSyn con2 args2 ty2) + = if (con1 == con2) then + -- Good news! Same synonym constructors, so we can shortcut + -- by unifying their arguments and ignoring their expansions. + uList 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} + +Still, if the synonym is abstract, we can only just go ahead and try! + +\begin{code} +uTys ps_ty1 (UniSyn con1 args1 ty1) ps_ty2 (UniSyn con2 args2 ty2) err_ctxt + -- Both must be abstract (i.e., non "visible" -- not done yet) + = if (con1 == con2) then + -- Good news! Same synonym constructors, so we can shortcut + -- by unifying their arguments and ignoring their expansions. + uList args1 args2 err_ctxt + else + -- Bad news; mis-matched type constructors + getSrcLocTc `thenNF_Tc` \ src_loc -> + failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc) +\end{code} + +%******************************************************** +%* * +Catch-all case---just fails: +%* * +%******************************************************** + +Anything else fails. For example, matching a @UniFun@ against +a @UniData@. +\begin{code} +uTys ps_ty1 ty1 ps_ty2 ty2 err_ctxt + = getSrcLocTc `thenNF_Tc` \ src_loc -> + failTc (unifyErr (UnifyMisMatch ps_ty1 ps_ty2) err_ctxt src_loc) +\end{code} + +%************************************************************************ +%* * +\subsection[Unify-uVar]{@uVar@: unifying with a type variable} +%* * +%************************************************************************ + +@uVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @bindTo@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. + +There is a slight worry that one might try to @bindTo@ a (say) Poly +tyvar (as tv1) with an Open tyvar (as ty2) which is already unified to +an unboxed type. In fact this can't happen, because the Open ones are +always the ones which are unified away. + +\begin{code} +uVar :: TyVar + -> UniType -> UniType -- printing and real versions + -> UnifyErrContext + -> TcM () + +uVar tv1 ps_ty2 ty2 err_ctxt + = do tv1 ty2 + where + -- Expand synonyms + do _ (UniSyn _ _ ty2) = do tv1 ty2 + + -- Commit any open type variable + do (OpenSysTyVar _) ty2 = tv1 `bindTo` ps_ty2 + do _ ty2@(UniTyVar tv2@(OpenSysTyVar _)) = tv2 `bindTo` ty1 + + -- Eliminate Poly in favour of User + do (PolySysTyVar _) ty2@(UniTyVar (UserTyVar _ _)) = tv1 `bindTo` ps_ty2 + do (PolySysTyVar _) ty2@(UniTyVar (PolySysTyVar _)) = tv1 `bindTo` ps_ty2 + do (UserTyVar _ _) ty2@(UniTyVar tv2@(PolySysTyVar _)) = tv2 `bindTo` ty1 + do (UserTyVar _ _) ty2@(UniTyVar (UserTyVar _ _)) = tv1 `bindTo` ps_ty2 + + -- Matching for boxed data types + do (PolySysTyVar _) ty2@(UniData con _) | isBoxedTyCon con = tv1 `bindTo` ps_ty2 + do (UserTyVar _ _) ty2@(UniData con _) | isBoxedTyCon con = tv1 `bindTo` ps_ty2 + + -- Matching for unboxed data types: + -- requires specialisation w.r.t. the unboxed type + do (PolySysTyVar _) ty2@(UniData con _) = tv1 `bindToUnboxed` ps_ty2 + do (UserTyVar _ _) ty2@(UniData con _) = tv1 `bindToUnboxed` ps_ty2 + + -- Matching for function types + do (PolySysTyVar _) ty2@(UniFun _ _) = tv1 `bindTo` ps_ty2 + do (UserTyVar _ _) ty2@(UniFun _ _) = tv1 `bindTo` ps_ty2 + + -- Default + do _ _ = getSrcLocTc `thenNF_Tc` \ src_loc -> + failTc (unifyErr (UnifyMisMatch ty1 ps_ty2) err_ctxt src_loc) + + ----------- END OF CASES --------------- + + ty1 = UniTyVar tv1 + + tyvar1 `bindTo` ty2 + = extendSubstTc tyvar1 ty2 err_ctxt + + tyvar1 `bindToUnboxed` ty2 + = getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> + if sw_chkr SpecialiseUnboxed then + extendSubstTc tyvar1 ty2 err_ctxt + else + getSrcLocTc `thenNF_Tc` \ src_loc -> + failTc (unifyErr (UnifyMisMatch ty1 ps_ty2) err_ctxt src_loc) +\end{code} diff --git a/ghc/compiler/typecheck/root.lit b/ghc/compiler/typecheck/root.lit new file mode 100644 index 0000000..401055f --- /dev/null +++ b/ghc/compiler/typecheck/root.lit @@ -0,0 +1,71 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate,a4wide]{article} +\begin{document} +\title{The Glasgow \Haskell{} typechecker} +\author{The AQUA team} +\date{February 1994} +\maketitle +\tableofcontents +\end{onlystandalone} + +\begin{onlypartofdoc} +\section[Typechecker]{The typechecker} +\downsection +\end{onlypartofdoc} + +\input{Typecheck.lhs} + +\section[Typechecker-monadery]{Typechecker: monad stuff (Saps)} +\downsection +\input{TcMonad.lhs} +\input{TcMonadFns.lhs} +\upsection + +\section{Typechecker: misc} +\downsection +\input{BackSubst.lhs} +\input{Disambig.lhs} +\input{Spec.lhs} +\input{Subst.lhs} +\input{Unify.lhs} +\upsection + +\section[Typechecker-toplevel]{Typechecker: top-level modules} +\downsection +\input{TcModule.lhs} +\upsection + +\section[Typechecker-core]{Typechecking the abstract syntax} +\downsection +\input{TcBinds.lhs} +\input{TcClassDcl.lhs} +\input{TcClassSig.lhs} +\input{TcConDecls.lhs} +\input{TcContext.lhs} +\input{TcExpr.lhs} +\input{TcGRHSs.lhs} +\input{TcIfaceSig.lhs} +\input{TcInstDcls.lhs} +\input{TcMatches.lhs} +\input{TcMonoBnds.lhs} +\input{TcMonoType.lhs} +\input{TcPat.lhs} +\input{TcPolyType.lhs} +\input{TcPragmas.lhs} +\input{TcQuals.lhs} +\input{TcTyDecls.lhs} +\upsection + +\section[Typechecker-support]{Typechecker: supporting modules} +\downsection +\input{GenSpecEtc.lhs} +\input{TcSimplify.lhs} +\upsection + +\begin{onlypartofdoc} +\upsection +\end{onlypartofdoc} +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/compiler/uniType/AbsUniType.hi b/ghc/compiler/uniType/AbsUniType.hi new file mode 100644 index 0000000..02c4bcd --- /dev/null +++ b/ghc/compiler/uniType/AbsUniType.hi @@ -0,0 +1,568 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface AbsUniType where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo) +import CharSeq(CSeq) +import Class(Class, ClassOp, cmpClass, derivableClassKeys, getClassBigSig, getClassInstEnv, getClassKey, getClassOpId, getClassOpLocalType, getClassOpString, getClassOpTag, getClassOps, getClassSig, getConstMethodId, getDefaultMethodId, getSuperDictSelId, isNumericClass, isStandardClass, isSuperClassOf, mkClass, mkClassOp) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreAtom, CoreExpr) +import Id(DataCon(..), Id, IdDetails) +import IdEnv(IdEnv(..)) +import IdInfo(IdInfo) +import InstEnv(ClassInstEnv(..), InstTemplate, InstTy, MatchEnv(..)) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda, assocMaybe) +import Name(Name) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep) +import PrimKind(PrimKind) +import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance) +import SrcLoc(SrcLoc) +import TyCon(Arity(..), TyCon, cmpTyCon, derivedFor, eqTyCon, getTyConArity, getTyConDataCons, getTyConDerivings, getTyConFamilySize, getTyConKind, getTyConTyVarTemplates, isBigTupleTyCon, isBoxedTyCon, isDataTyCon, isEnumerationTyCon, isLocalGenTyCon, isLocalSpecTyCon, isPrimTyCon, isSynTyCon, isTupleTyCon, isVisibleSynTyCon, maybeCharLikeTyCon, maybeDoubleLikeTyCon, maybeFloatLikeTyCon, maybeIntLikeTyCon, maybeSingleConstructorTyCon, mkDataTyCon, mkPrimTyCon, mkSpecTyCon, mkSynonymTyCon, mkTupleTyCon) +import TyVar(TyVar, TyVarTemplate, alphaTyVars, alpha_tv, alpha_tyvar, beta_tv, beta_tyvar, cloneTyVar, cloneTyVarFromTemplate, cmpTyVar, delta_tv, delta_tyvar, epsilon_tv, epsilon_tyvar, eqTyVar, gamma_tv, gamma_tyvar, instantiateTyVarTemplates, ltTyVar, mkOpenSysTyVar, mkPolySysTyVar, mkSysTyVarTemplate, mkTemplateTyVars, mkUserTyVar, mkUserTyVarTemplate) +import TyVarEnv(TyVarEnv(..), TypeEnv(..)) +import UniTyFuns(applyNonSynTyCon, applySynTyCon, applyTy, applyTyCon, applyTypeEnvToThetaTy, applyTypeEnvToTy, cmpUniTypeMaybeList, expandVisibleTySyn, extractTyVarTemplatesFromTy, extractTyVarsFromTy, extractTyVarsFromTys, funResultTy, getMentionedTyCons, getMentionedTyConsAndClassesFromClass, getMentionedTyConsAndClassesFromTyCon, getMentionedTyConsAndClassesFromUniType, getTauType, getTyVar, getTyVarMaybe, getTyVarTemplateMaybe, getTypeString, getUniDataSpecTyCon, getUniDataSpecTyCon_maybe, getUniDataTyCon, getUniDataTyCon_maybe, getUniTyDescription, glueTyArgs, instanceIsExported, isDictTy, isForAllTy, isFunType, isGroundOrTyVarTy, isGroundTy, isLeakFreeType, isPrimType, isTauTy, isTyVarTemplateTy, isTyVarTy, isUnboxedDataType, kindFromType, mapOverTyVars, matchTy, maybeBoxedPrimType, maybePurelyLocalClass, maybePurelyLocalTyCon, maybePurelyLocalType, maybeUnpackFunTy, mkSuperDictSelType, pprClassOp, pprIfaceClass, pprMaybeTy, pprParendUniType, pprTyCon, pprUniType, returnsRealWorld, showTyCon, showTypeCategory, specMaybeTysSuffix, specialiseTy, splitDictType, splitForalls, splitTyArgs, splitType, splitTypeWithDictsAsArgs, typeMaybeString, unDictifyTy) +import UniType(InstTyEnv(..), RhoType(..), SigmaType(..), TauType(..), ThetaType(..), UniType, alpha, alpha_ty, beta, beta_ty, cmpUniType, delta, delta_ty, epsilon, epsilon_ty, gamma, gamma_ty, instantiateTauTy, instantiateThetaTy, instantiateTy, mkDictTy, mkForallTy, mkRhoTy, mkSigmaTy, mkTyVarTemplateTy, mkTyVarTy, quantifyTy) +import UniqFM(UniqFM) +import Unique(Unique) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +type DataCon = Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdEnv a = UniqFM a +type ClassInstEnv = [(UniType, InstTemplate)] +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +type MatchEnv a b = [(a, b)] +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +type Arity = Int +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +type TypeEnv = UniqFM UniType +type InstTyEnv = [(TyVarTemplate, UniType)] +type RhoType = UniType +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +cmpClass :: Class -> Class -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +derivableClassKeys :: [Unique] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +getClassBigSig :: Class -> (TyVarTemplate, [Class], [Id], [ClassOp], [Id], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLLLLLAA)" _N_ _N_ #-} +getClassInstEnv :: Class -> [(UniType, InstTemplate)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [(UniType, InstTemplate)]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u9; _NO_DEFLT_ } _N_ #-} +getClassKey :: Class -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u1; _NO_DEFLT_ } _N_ #-} +getClassOpId :: Class -> ClassOp -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAASAAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u8, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getClassOpLocalType :: ClassOp -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-} +getClassOpString :: ClassOp -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u1; _NO_DEFLT_ } _N_ #-} +getClassOpTag :: ClassOp -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u2; _NO_DEFLT_ } _N_ #-} +getClassOps :: Class -> [ClassOp] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [ClassOp]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u6; _NO_DEFLT_ } _N_ #-} +getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLALAAAA)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: TyVarTemplate) (u1 :: [Class]) (u2 :: [ClassOp]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u3, u4, u6]; _NO_DEFLT_ } _N_ #-} +getConstMethodId :: Class -> ClassOp -> UniType -> Id + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(AAAAALSAAA)U(LU(P)L)L" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getDefaultMethodId :: Class -> ClassOp -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAAASAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u9, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getSuperDictSelId :: Class -> Class -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASLAAAAA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isNumericClass :: Class -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isStandardClass :: Class -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isSuperClassOf :: Class -> Class -> Labda [Class] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(AAAAAAAAAS)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ u1, u0 ] _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: Class) (u1 :: Class) -> case u1 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ ub, u0 ]; _NO_DEFLT_ } _N_ #-} +mkClass :: Name -> TyVarTemplate -> [Class] -> [Id] -> [ClassOp] -> [Id] -> [Id] -> [(UniType, InstTemplate)] -> Class + {-# GHC_PRAGMA _A_ 8 _U_ 12222222 _N_ _N_ _N_ _N_ #-} +mkClassOp :: _PackedString -> Int -> UniType -> ClassOp + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: _PackedString) (u1 :: Int) (u2 :: UniType) -> _!_ _ORIG_ Class MkClassOp [] [u0, u1, u2] _N_ #-} +assocMaybe :: Eq a => [(a, b)] -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ [Char], _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +derivedFor :: Class -> TyCon -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 9 \ (u0 :: Class) (u1 :: TyCon) -> case u1 of { _ALG_ _ORIG_ TyCon DataTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [TyVarTemplate]) (u6 :: [Id]) (u7 :: [Class]) (u8 :: Bool) -> _APP_ _WRKR_ _SPEC_ _ORIG_ Util isIn [ (Class) ] [ u0, u7 ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-} +eqTyCon :: TyCon -> TyCon -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +getTyConArity :: TyCon -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyConDataCons :: TyCon -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyConDerivings :: TyCon -> [Class] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon DataTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: [Id]) (u6 :: [Class]) (u7 :: Bool) -> u6; _ORIG_ TyCon SpecTyCon (u8 :: TyCon) (u9 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { [Class] } [ _NOREP_S_ "getTyConDerivings:SpecTyCon" ]; (ua :: TyCon) -> _!_ _NIL_ [Class] [] } _N_ #-} +getTyConFamilySize :: TyCon -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyConKind :: TyCon -> [PrimKind] -> PrimKind + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 8 \ (u0 :: TyCon) (u1 :: [PrimKind]) -> case u0 of { _ALG_ _ORIG_ TyCon PrimTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [PrimKind] -> PrimKind) -> _APP_ u5 [ u1 ]; (u6 :: TyCon) -> _!_ _ORIG_ PrimKind PtrKind [] [] } _N_ #-} +getTyConTyVarTemplates :: TyCon -> [TyVarTemplate] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isBigTupleTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isBoxedTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isDataTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isEnumerationTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isLocalGenTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isLocalSpecTyCon :: Bool -> TyCon -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-} +isPrimTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isSynTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> _!_ True [] []; _ORIG_ TyCon SpecTyCon (u7 :: TyCon) (u8 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isSynTyCon: SpecTyCon" ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-} +isTupleTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isVisibleSynTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> u6; (u7 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isVisibleSynTyCon" ] } _N_ #-} +maybeCharLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeDoubleLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeFloatLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeIntLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeSingleConstructorTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkDataTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> [Id] -> [Class] -> Bool -> TyCon + {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: [Id]) (u5 :: [Class]) (u6 :: Bool) -> _!_ _ORIG_ TyCon DataTyCon [] [u0, u1, u2, u3, u4, u5, u6] _N_ #-} +mkPrimTyCon :: Unique -> FullName -> Int -> ([PrimKind] -> PrimKind) -> TyCon + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [PrimKind] -> PrimKind) -> _!_ _ORIG_ TyCon PrimTyCon [] [u0, u1, u2, u3] _N_ #-} +mkSpecTyCon :: TyCon -> [Labda UniType] -> TyCon + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [Labda UniType]) -> _!_ _ORIG_ TyCon SpecTyCon [] [u0, u1] _N_ #-} +mkSynonymTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> UniType -> Bool -> TyCon + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _F_ _IF_ARGS_ 0 6 XXXXXX 7 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: UniType) (u5 :: Bool) -> _!_ _ORIG_ TyCon SynonymTyCon [] [u0, u1, u2, u3, u4, u5] _N_ #-} +mkTupleTyCon :: Int -> TyCon + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ TyCon TupleTyCon [] [u0] _N_ #-} +alphaTyVars :: [TyVarTemplate] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +alpha_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +alpha_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +beta_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +beta_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cloneTyVar :: TyVar -> Unique -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +cloneTyVarFromTemplate :: TyVarTemplate -> Unique -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: TyVarTemplate) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u2 :: Unique) (u3 :: _PackedString) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u1]; _ORIG_ TyVar UserTyVarTemplate (u4 :: Unique) (u5 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u1, u5]; _NO_DEFLT_ } _N_ #-} +cmpTyVar :: TyVar -> TyVar -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +delta_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +delta_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +epsilon_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +epsilon_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqTyVar :: TyVar -> TyVar -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +gamma_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gamma_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instantiateTyVarTemplates :: [TyVarTemplate] -> [Unique] -> ([(TyVarTemplate, UniType)], [TyVar], [UniType]) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _N_ #-} +ltTyVar :: TyVar -> TyVar -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +mkOpenSysTyVar :: Unique -> TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar OpenSysTyVar [] [u0] _N_ #-} +mkPolySysTyVar :: Unique -> TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u0] _N_ #-} +mkSysTyVarTemplate :: Unique -> _PackedString -> TyVarTemplate + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: _PackedString) -> _!_ _ORIG_ TyVar SysTyVarTemplate [] [u0, u1] _N_ #-} +mkTemplateTyVars :: [TyVar] -> [TyVarTemplate] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkUserTyVar :: Unique -> ShortName -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u0, u1] _N_ #-} +mkUserTyVarTemplate :: Unique -> ShortName -> TyVarTemplate + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVarTemplate [] [u0, u1] _N_ #-} +applyNonSynTyCon :: TyCon -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [UniType]) -> _!_ _ORIG_ UniType UniData [] [u0, u1] _N_ #-} +applySynTyCon :: TyCon -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +applyTy :: UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +applyTyCon :: TyCon -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +applyTypeEnvToThetaTy :: UniqFM UniType -> [(a, UniType)] -> [(a, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +applyTypeEnvToTy :: UniqFM UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +cmpUniTypeMaybeList :: [Labda UniType] -> [Labda UniType] -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +expandVisibleTySyn :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarsFromTy :: UniType -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarsFromTys :: [UniType] -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +funResultTy :: UniType -> Int -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getMentionedTyCons :: TyCon -> [TyCon] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-} +getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTauType :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: UniType) -> case _APP_ _ORIG_ UniTyFuns splitType [ u0 ] of { _ALG_ _TUP_3 (u1 :: [TyVarTemplate]) (u2 :: [(Class, UniType)]) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-} +getTyVar :: [Char] -> UniType -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +getTyVarMaybe :: UniType -> Labda TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyVarTemplateMaybe :: UniType -> Labda TyVarTemplate + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTypeString :: UniType -> [_PackedString] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataSpecTyCon :: UniType -> (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataSpecTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataTyCon :: UniType -> (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniTyDescription :: UniType -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +glueTyArgs :: [UniType] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instanceIsExported :: Class -> UniType -> Bool -> Bool + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AU(AASLAA)AAAAAAAA)SL" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isDictTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isForAllTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isFunType :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isGroundOrTyVarTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isGroundTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isLeakFreeType :: [TyCon] -> UniType -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +isPrimType :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTauTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTyVarTemplateTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTyVarTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isUnboxedDataType :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +kindFromType :: UniType -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mapOverTyVars :: (TyVar -> UniType) -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +matchTy :: UniType -> UniType -> Labda [(TyVarTemplate, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +maybeBoxedPrimType :: UniType -> Labda (Id, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +maybePurelyLocalClass :: Class -> Labda [Int -> Bool -> PrettyRep] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-} +maybePurelyLocalTyCon :: TyCon -> Labda [Int -> Bool -> PrettyRep] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +maybePurelyLocalType :: UniType -> Labda [Int -> Bool -> PrettyRep] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeUnpackFunTy :: UniType -> Labda (UniType, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkSuperDictSelType :: Class -> Class -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "U(LLLLLLLLLL)L" _N_ _N_ #-} +pprClassOp :: PprStyle -> ClassOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> UniqFM UnfoldingDetails -> Class -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222122 _N_ _S_ "LLLU(ALLLLLLLAA)" _N_ _N_ #-} +pprMaybeTy :: PprStyle -> Labda UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SS" _N_ _N_ #-} +pprParendUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-} +pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +returnsRealWorld :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +showTyCon :: PprStyle -> TyCon -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +showTypeCategory :: UniType -> Char + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +specMaybeTysSuffix :: [Labda UniType] -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +specialiseTy :: UniType -> [Labda UniType] -> Int -> UniType + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLL" _N_ _N_ #-} +splitDictType :: UniType -> (Class, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +splitForalls :: UniType -> ([TyVarTemplate], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +splitTyArgs :: UniType -> ([UniType], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +splitType :: UniType -> ([TyVarTemplate], [(Class, UniType)], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +splitTypeWithDictsAsArgs :: UniType -> ([TyVarTemplate], [UniType], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +typeMaybeString :: Labda UniType -> [_PackedString] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unDictifyTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +alpha :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar alpha_tv] _N_ #-} +alpha_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar alpha_tyvar] _N_ #-} +beta :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar beta_tv] _N_ #-} +beta_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar beta_tyvar] _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +delta :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar delta_tv] _N_ #-} +delta_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar delta_tyvar] _N_ #-} +epsilon :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar epsilon_tv] _N_ #-} +epsilon_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar epsilon_tyvar] _N_ #-} +gamma :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar gamma_tv] _N_ #-} +gamma_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar gamma_tyvar] _N_ #-} +instantiateTauTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniType instantiateTy _N_ #-} +instantiateThetaTy :: [(TyVarTemplate, UniType)] -> [(Class, UniType)] -> [(Class, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +instantiateTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-} +mkDictTy :: Class -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: UniType) -> _!_ _ORIG_ UniType UniDict [] [u0, u1] _N_ #-} +mkForallTy :: [TyVarTemplate] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mkRhoTy :: [(Class, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mkSigmaTy :: [TyVarTemplate] -> [(Class, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ #-} +mkTyVarTemplateTy :: TyVarTemplate -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ UniType UniTyVarTemplate [] [u0] _N_ #-} +mkTyVarTy :: TyVar -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _!_ _ORIG_ UniType UniTyVar [] [u0] _N_ #-} +quantifyTy :: [TyVar] -> UniType -> ([TyVarTemplate], UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +instance Eq Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Eq Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance NamedThing FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-} +instance NamedThing ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance NamedThing TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-} +instance NamedThing TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-} +instance Outputable Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable FullName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ShortName + {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_ + ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-} +instance Text Unique + {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_ + readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_, + showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_, + readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_, + showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/uniType/AbsUniType.lhs b/ghc/compiler/uniType/AbsUniType.lhs new file mode 100644 index 0000000..2bfdb2f --- /dev/null +++ b/ghc/compiler/uniType/AbsUniType.lhs @@ -0,0 +1,223 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[AbsUniType]{@AbsUniType@: the abstract interface to @UniType@} + +The module @AbsUniType@ is the ``outside world's'' interface to the +@UniType@ datatype. It imports and re-exports the appropriate +@UniType@ stuff. + +The prototype compiler's lack of original namery means it is good to +include @Class@, @TyVar@ and @TyCon@ stuff here, too, and to let this +module also present the ``outside-world'' interface for them. + +\begin{code} +#include "HsVersions.h" + +module AbsUniType ( + -- Class and ClassOp stuff ------------------------------------- + Class, + mkClass, + getClassKey, getClassOps, + getSuperDictSelId, getClassOpId, getDefaultMethodId, + getConstMethodId, + getClassSig, getClassBigSig, getClassInstEnv, +--UNUSED: getClassDefaultMethodsInfo, + isSuperClassOf, + cmpClass, + derivableClassKeys, + isNumericClass, isStandardClass, -- UNUSED: isDerivableClass, + + ClassOp, + mkClassOp, + getClassOpTag, getClassOpString, +--UNUSED: getClassOpSig, + getClassOpLocalType, + + -- TyVar stuff ------------------------------------------------- + TyVar, + TyVarTemplate, + + mkUserTyVar, mkPolySysTyVar, mkOpenSysTyVar, +--UNUSED: mkPrimSysTyVar, isPrimTyVar, + +-- getTyVarUnique, + + cmpTyVar, eqTyVar, ltTyVar, -- used a lot! + + mkUserTyVarTemplate, mkSysTyVarTemplate, mkTemplateTyVars, + + cloneTyVarFromTemplate, + cloneTyVar, + instantiateTyVarTemplates, + + -- a supply of template tyvars + alphaTyVars, + alpha_tv, beta_tv, gamma_tv, delta_tv, epsilon_tv, -- templates + alpha_tyvar, beta_tyvar, gamma_tyvar, delta_tyvar, epsilon_tyvar,-- real tyvars + + -- TyCon stuff ------------------------------------------------- + TyCon, + Arity(..), -- synonym for Int + mkSynonymTyCon, mkDataTyCon, mkTupleTyCon, + mkPrimTyCon, mkSpecTyCon, +#ifdef DPH + mkProcessorTyCon, mkPodizedPodTyCon, +#endif {- Data Parallel Haskell -} + + isSynTyCon, isVisibleSynTyCon, isDataTyCon, + isPrimTyCon, isBoxedTyCon, + maybeCharLikeTyCon, maybeIntLikeTyCon, + maybeFloatLikeTyCon, maybeDoubleLikeTyCon, + isEnumerationTyCon, --UNUSED: isEnumerationTyConMostly, + isTupleTyCon, + isLocalSpecTyCon, isLocalGenTyCon, isBigTupleTyCon, + maybeSingleConstructorTyCon, + derivedFor, --UNUSED: preludeClassDerivedFor, + cmpTyCon, eqTyCon, + + getTyConArity, getTyConDataCons, + getTyConTyVarTemplates, + getTyConKind, + getTyConDerivings, + getTyConFamilySize, + + -- UniType stuff ----------------------------------------------- + UniType, + + -- USEFUL SYNONYMS + SigmaType(..), RhoType(..), TauType(..), + ThetaType(..), -- synonym for [(Class,UniType)] + + -- CONSTRUCTION + mkTyVarTy, mkTyVarTemplateTy, mkDictTy, + -- use applyTyCon to make UniDatas, UniSyns + mkRhoTy, mkForallTy, mkSigmaTy, -- ToDo: perhaps nuke one? + + -- QUANTIFICATION & INSTANTIATION + quantifyTy, + instantiateTy, instantiateTauTy, instantiateThetaTy, + + -- COMPARISON (use sparingly!) + cmpUniType, + cmpUniTypeMaybeList, + + -- PRE-BUILT TYPES (for Prelude) + alpha, beta, gamma, delta, epsilon, -- these have templates in them + alpha_ty, beta_ty, gamma_ty, delta_ty, epsilon_ty, -- these have tyvars in them + + -- UniTyFuns stuff --------------------------------------------- + -- CONSTRUCTION + applyTy, applyTyCon, applySynTyCon, applyNonSynTyCon, + glueTyArgs, mkSuperDictSelType, --UNUSED: mkDictFunType, + specialiseTy, + + -- DESTRUCTION +--not exported: expandTySyns, + expandVisibleTySyn, + getTyVar, getTyVarMaybe, getTyVarTemplateMaybe, + splitType, splitForalls, getTauType, splitTyArgs, + splitTypeWithDictsAsArgs, +--not exported/unused: sourceTypes, targetType, + funResultTy, + splitDictType, + kindFromType, + getUniDataTyCon, getUniDataTyCon_maybe, + getUniDataSpecTyCon, getUniDataSpecTyCon_maybe, + unDictifyTy, + getMentionedTyCons, +#ifdef USE_SEMANTIQUE_STRANAL + getReferredToTyCons, +#endif {- Semantique strictness analyser -} + getMentionedTyConsAndClassesFromUniType, + getMentionedTyConsAndClassesFromTyCon, + getMentionedTyConsAndClassesFromClass, + getUniTyDescription, + + -- FREE-VARIABLE EXTRACTION + extractTyVarsFromTy, extractTyVarsFromTys, + extractTyVarTemplatesFromTy, + + -- PREDICATES + isTyVarTy, isTyVarTemplateTy, + maybeUnpackFunTy, isFunType, + isPrimType, isUnboxedDataType, --UNUSED: isDataConType, + isLeakFreeType, + maybeBoxedPrimType, +--UNUSED: hasHigherOrderArg, + isDictTy, isGroundTy, isGroundOrTyVarTy, + instanceIsExported, +--UNUSED: isSynTarget, + isTauTy, isForAllTy, + maybePurelyLocalTyCon, maybePurelyLocalClass, + maybePurelyLocalType, + returnsRealWorld, -- HACK courtesy of SLPJ +#ifdef DPH + isProcessorTy, + isProcessorTyCon, + isPodizedPodTyCon, + getPodizedPodDimension, + runtimeUnpodizableType, +#endif {- Data Parallel Haskell -} + + -- SUBSTITUTION + applyTypeEnvToTy, applyTypeEnvToThetaTy, +--not exported: applyTypeEnvToTauTy, + mapOverTyVars, +-- genInstantiateTyUS, -- ToDo: ??? + + -- PRETTY PRINTING AND FORCING + pprUniType, pprParendUniType, pprMaybeTy, + pprTyCon, pprIfaceClass, pprClassOp, + getTypeString, + typeMaybeString, + specMaybeTysSuffix, + showTyCon, + showTypeCategory, + + -- MATCHING + matchTy, -- UNUSED: matchTys, + + -- and, finally, stuff to make the interface self-contained... +-- Outputable(..), NamedThing(..), + ExportFlag, Pretty(..), PprStyle, PrettyRep, + + GlobalSwitch, UnfoldingDetails, Id, DataCon(..), IdEnv(..), + InstTemplate, Maybe, Name, FullName, ShortName, + PrimKind, TyVarEnv(..), TypeEnv(..), Unique, ClassInstEnv(..), + MatchEnv(..), InstTyEnv(..), UniqFM, Bag + + IF_ATTACK_PRAGMAS(COMMA assocMaybe) + +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +import Class +import TyVar +import TyCon +import UniType +import UniTyFuns + +import AbsSyn ( RenamedBinds(..), RenamedExpr(..), RenamedGRHS(..), + RenamedGRHSsAndBinds(..), RenamedPat(..), Binds, + Expr, GRHS, GRHSsAndBinds, InPat + ) +import InstEnv ( ClassInstEnv(..), MatchEnv(..) ) +import Maybes ( assocMaybe, Maybe(..) ) -- (..) for pragmas only +import NameTypes ( ShortName, FullName ) -- pragmas only +import Outputable +import Pretty ( Pretty(..) + IF_ATTACK_PRAGMAS(COMMA ppStr COMMA ppDouble COMMA ppInteger) + ) +import TyVarEnv -- ( TyVarEnv ) +import Unique ( Unique, UniqueSupply ) +#if USE_ATTACK_PRAGMAS +import Util +#else +#ifndef __GLASGOW_HASKELL__ +import Util ( TAG_ ) +#endif +#endif +\end{code} diff --git a/ghc/compiler/uniType/Class.hi b/ghc/compiler/uniType/Class.hi new file mode 100644 index 0000000..925e012 --- /dev/null +++ b/ghc/compiler/uniType/Class.hi @@ -0,0 +1,108 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Class where +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import InstEnv(InstTemplate, InstTy) +import Maybes(Labda) +import Name(Name) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludePS(_PackedString) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +data Class = MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] +data ClassOp = MkClassOp _PackedString Int UniType +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +cmpClass :: Class -> Class -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +derivableClassKeys :: [Unique] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +getClassBigSig :: Class -> (TyVarTemplate, [Class], [Id], [ClassOp], [Id], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLLLLLAA)" _N_ _N_ #-} +getClassInstEnv :: Class -> [(UniType, InstTemplate)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [(UniType, InstTemplate)]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u9; _NO_DEFLT_ } _N_ #-} +getClassKey :: Class -> Unique + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u1; _NO_DEFLT_ } _N_ #-} +getClassOpId :: Class -> ClassOp -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAASAAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u8, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getClassOpLocalType :: ClassOp -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-} +getClassOpString :: ClassOp -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u1; _NO_DEFLT_ } _N_ #-} +getClassOpTag :: ClassOp -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u2; _NO_DEFLT_ } _N_ #-} +getClassOps :: Class -> [ClassOp] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [ClassOp]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u6; _NO_DEFLT_ } _N_ #-} +getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp]) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLALAAAA)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: TyVarTemplate) (u1 :: [Class]) (u2 :: [ClassOp]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u3, u4, u6]; _NO_DEFLT_ } _N_ #-} +getConstMethodId :: Class -> ClassOp -> UniType -> Id + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(AAAAALSAAA)U(LU(P)L)L" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getDefaultMethodId :: Class -> ClassOp -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAAASAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u9, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +getSuperDictSelId :: Class -> Class -> Id + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASLAAAAA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isNumericClass :: Class -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isStandardClass :: Class -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isSuperClassOf :: Class -> Class -> Labda [Class] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(AAAAAAAAAS)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ u1, u0 ] _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: Class) (u1 :: Class) -> case u1 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ ub, u0 ]; _NO_DEFLT_ } _N_ #-} +mkClass :: Name -> TyVarTemplate -> [Class] -> [Id] -> [ClassOp] -> [Id] -> [Id] -> [(UniType, InstTemplate)] -> Class + {-# GHC_PRAGMA _A_ 8 _U_ 12222222 _N_ _N_ _N_ _N_ #-} +mkClassOp :: _PackedString -> Int -> UniType -> ClassOp + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: _PackedString) (u1 :: Int) (u2 :: UniType) -> _!_ _ORIG_ Class MkClassOp [] [u0, u1, u2] _N_ #-} +instance Eq Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Eq ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +instance Ord Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Ord ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +instance NamedThing Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_ + getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_, + getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable Class + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable ClassOp + {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ + ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/uniType/Class.lhs b/ghc/compiler/uniType/Class.lhs new file mode 100644 index 0000000..ca6c2ce --- /dev/null +++ b/ghc/compiler/uniType/Class.lhs @@ -0,0 +1,386 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Class]{The @Class@ datatype} + +\begin{code} +#include "HsVersions.h" + +module Class ( + Class(..), -- must be *NON*-abstract so UniTyFuns can see it + + mkClass, + getClassKey, getClassOps, + getSuperDictSelId, getClassOpId, getDefaultMethodId, + getConstMethodId, + getClassSig, getClassBigSig, getClassInstEnv, +--UNUSED: getClassDefaultMethodsInfo, + isSuperClassOf, + cmpClass, + + derivableClassKeys, + isNumericClass, isStandardClass, --UNUSED: isDerivableClass, + + ClassOp(..), -- must be non-abstract so UniTyFuns can see them + mkClassOp, + getClassOpTag, getClassOpString, +--UNUSED: getClassOpSig, + getClassOpLocalType, + + -- and to make the interface self-sufficient... + Id, InstTemplate, Maybe, Name, FullName, TyVarTemplate, + UniType, Unique + ) where + +import Id ( getIdSpecialisation, Id ) +import IdInfo +import InstEnv ( ClassInstEnv(..), MatchEnv(..) ) +import Maybes ( assocMaybe, Maybe(..) ) +import Name ( Name(..), ShortName ) +import NameTypes ( FullName, SrcLoc ) +import Pretty +import Outputable -- class for printing, forcing +import TyCon ( TyCon, Arity(..) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import TyVar ( TyVarTemplate ) +import Unique -- class key stuff +import UniType ( UniType, ThetaType(..), TauType(..) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import UniTyFuns ( splitType, pprClassOp + IF_ATTACK_PRAGMAS(COMMA pprUniType COMMA pprTyCon) + ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Class-basic]{@Class@: basic definition} +%* * +%************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: + +\begin{code} +data Class + = MkClass + Unique{-ClassKey-}-- Key for fast comparison + FullName + + TyVarTemplate -- The class type variable + + [Class] [Id] -- Immediate superclasses, and the + -- corresponding selector functions to + -- extract them from a dictionary of this + -- class + + [ClassOp] -- The * class operations + [Id] -- * selector functions + [Id] -- * default methods + -- They are all ordered by tag. The + -- selector ids are less innocent than they + -- look, because their IdInfos contains + -- suitable specialisation information. In + -- particular, constant methods are + -- instances of selectors at suitably simple + -- types. + + ClassInstEnv -- Gives details of all the instances of this class + + [(Class,[Class])] -- Indirect superclasses; + -- (k,[k1,...,kn]) means that + -- k is an immediate superclass of k1 + -- k1 is an immediate superclass of k2 + -- ... and kn is an immediate superclass + -- of this class. (This is all redundant + -- information, since it can be derived from + -- the superclass information above.) +\end{code} + +The @mkClass@ function fills in the indirect superclasses. + +\begin{code} +mkClass :: Name -> TyVarTemplate + -> [Class] -> [Id] + -> [ClassOp] -> [Id] -> [Id] + -> ClassInstEnv + -> Class + +mkClass name tyvar super_classes superdict_sels + class_ops dict_sels defms class_insts + = MkClass key full_name tyvar + super_classes superdict_sels + class_ops dict_sels defms + class_insts + trans_clos + where + (key,full_name) = case name of + OtherClass uniq full_name _ -> (uniq, full_name) + PreludeClass key full_name -> (key, full_name) + + trans_clos :: [(Class,[Class])] + trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ] + + succ (clas@(MkClass _ _ _ super_classes _ _ _ _ _ _), links) + = [(super, (clas:links)) | super <- super_classes] +\end{code} + +%************************************************************************ +%* * +\subsection[Class-selectors]{@Class@: simple selectors} +%* * +%************************************************************************ + +The rest of these functions are just simple selectors. + +\begin{code} +getClassKey (MkClass key _ _ _ _ _ _ _ _ _) = key + +getClassOps (MkClass _ _ _ _ _ ops _ _ _ _) = ops + +getSuperDictSelId (MkClass _ _ _ scs scsel_ids _ _ _ _ _) super_clas + = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas + +getClassOpId (MkClass _ _ _ _ _ ops op_ids _ _ _) op + = op_ids !! (getClassOpTag op - 1) + +getDefaultMethodId (MkClass _ _ _ _ _ ops _ defm_ids _ _) op + = defm_ids !! (getClassOpTag op - 1) + +getConstMethodId (MkClass _ _ _ _ _ ops op_ids _ _ _) op ty + = -- constant-method info is hidden in the IdInfo of + -- the class-op id (as mentioned up above). + let + sel_id = op_ids !! (getClassOpTag op - 1) + in + case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of + Just xx -> xx + Nothing -> error (ppShow 80 (ppAboves [ + ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op, ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, ppr PprDebug sel_id], + ppStr "(This can arise if an interface pragma refers to an instance", + ppStr "but there is no imported interface which *defines* that instance.", + ppStr "The info above, however ugly, should indicate what else you need to import." + ])) + +getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp]) + +getClassSig (MkClass _ _ tyvar super_classes _ ops _ _ _ _) + = (tyvar, super_classes, ops) + +getClassBigSig (MkClass _ _ tyvar super_classes sdsels ops sels defms _ _) + = (tyvar, super_classes, sdsels, ops, sels, defms) + +getClassInstEnv (MkClass _ _ _ _ _ _ _ _ inst_env _) = inst_env + +--UNUSED: getClassDefaultMethodsInfo (MkClass _ _ _ _ _ _ _ defms _ _) = defms +\end{code} + +@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of +@b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the +$k_1,\ldots,k_n$ are exactly as described in the definition of the +@MkClass@ constructor above. + +\begin{code} +isSuperClassOf :: Class -> Class -> Maybe [Class] + +clas `isSuperClassOf` (MkClass _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas +\end{code} + +%************************************************************************ +%* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +%* * +%************************************************************************ + +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@TcDeriv@). + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. + +\begin{code} +isNumericClass, isStandardClass {-UNUSED:, isDerivableClass-} :: Class -> Bool + +isNumericClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys +isStandardClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys +--isDerivableClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` derivableClassKeys + +is_elem = isIn "is_X_Class" + +numericClassKeys + = [ numClassKey, + realClassKey, + integralClassKey, + fractionalClassKey, + floatingClassKey, + realFracClassKey, + realFloatClassKey ] + +derivableClassKeys + = [ eqClassKey, + textClassKey, + ordClassKey, + enumClassKey, + ixClassKey ] + -- ToDo: add binaryClass + +standardClassKeys + = derivableClassKeys ++ numericClassKeys + ++ [ cCallableClassKey, cReturnableClassKey ] + -- + -- We have to have "_CCallable" and "_CReturnable" in the standard + -- classes, so that if you go... + -- + -- _ccall_ foo ... 93{-numeric literal-} ... + -- + -- ... it can do The Right Thing on the 93. +\end{code} + +%************************************************************************ +%* * +\subsection[Class-instances]{Instance declarations for @Class@} +%* * +%************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). + +\begin{code} +cmpClass (MkClass k1 _ _ _ _ _ _ _ _ _) (MkClass k2 _ _ _ _ _ _ _ _ _) + = cmpUnique k1 k2 + +instance Eq Class where + (MkClass k1 _ _ _ _ _ _ _ _ _) == (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 == k2 + (MkClass k1 _ _ _ _ _ _ _ _ _) /= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 /= k2 + +instance Ord Class where + (MkClass k1 _ _ _ _ _ _ _ _ _) <= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 <= k2 + (MkClass k1 _ _ _ _ _ _ _ _ _) < (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 < k2 + (MkClass k1 _ _ _ _ _ _ _ _ _) >= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 >= k2 + (MkClass k1 _ _ _ _ _ _ _ _ _) > (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 > k2 +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpClass a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +\begin{code} +instance NamedThing Class where + getExportFlag (MkClass _ n _ _ _ _ _ _ _ _) = getExportFlag n + isLocallyDefined (MkClass _ n _ _ _ _ _ _ _ _) = isLocallyDefined n + getOrigName (MkClass _ n _ _ _ _ _ _ _ _) = getOrigName n + getOccurrenceName (MkClass _ n _ _ _ _ _ _ _ _) = getOccurrenceName n + getInformingModules (MkClass _ n _ _ _ _ _ _ _ _) = getInformingModules n + getSrcLoc (MkClass _ n _ _ _ _ _ _ _ _) = getSrcLoc n + fromPreludeCore (MkClass _ n _ _ _ _ _ _ _ _) = fromPreludeCore n + + getTheUnique = panic "NamedThing.Class.getTheUnique" + hasType = panic "NamedThing.Class.hasType" + getType = panic "NamedThing.Class.getType" +\end{code} + +And the usual output stuff: +\begin{code} +instance Outputable Class where + -- we use pprIfaceClass for printing in interfaces + +{- ppr sty@PprShowAll (MkClass u n _ _ _ ops _ _ _ _) + = ppCat [ppr sty n, pprUnique u, ppr sty ops] +-} + ppr sty (MkClass u n _ _ _ _ _ _ _ _) = ppr sty n +\end{code} + +%************************************************************************ +%* * +\subsection[ClassOp-basic]{@ClassOp@: type and basic functions} +%* * +%************************************************************************ + +\begin{code} +data ClassOp + = MkClassOp FAST_STRING -- The operation name + + Int -- Unique within a class; starts at 1 + + UniType -- Type; the class tyvar is free (you can find + -- it from the class). This means that a + -- ClassOp doesn't make much sense outside the + -- context of its parent class. +\end{code} + +A @ClassOp@ represents a a class operation. From it and its parent +class we can construct the dictionary-selector @Id@ for the +operation/superclass dictionary, and the @Id@ for its default method. +It appears in a list inside the @Class@ object. + +The type of a method in a @ClassOp@ object is its local type; that is, +without the overloading of the class itself. For example, in the +declaration +\begin{pseudocode} + class Foo a where + op :: Ord b => a -> b -> a +\end{pseudocode} +the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is +just + $\forall \beta.~ + @Ord@~\beta \Rightarrow + \alpha \rightarrow \beta \rightarrow alpha$ + +(where $\alpha$ is the class type variable recorded in the @Class@ +object). Of course, the type of @op@ recorded in the GVE will be its +``full'' type + + $\forall \alpha \forall \beta.~ + @Foo@~\alpha \Rightarrow + ~@Ord@~\beta \Rightarrow \alpha + \rightarrow \beta \rightarrow alpha$ + +****************************************************************** +**** That is, the type variables of a class op selector +*** are all at the outer level. +****************************************************************** + +\begin{code} +mkClassOp = MkClassOp + +getClassOpTag :: ClassOp -> Int +getClassOpTag (MkClassOp _ tag _) = tag + +getClassOpString :: ClassOp -> FAST_STRING +getClassOpString (MkClassOp str _ _) = str + +{- UNUSED: +getClassOpSig :: ClassOp -> ([TyVarTemplate], ThetaType, TauType) +getClassOpSig (MkClassOp _ _ ty) = splitType ty +-} + +getClassOpLocalType :: ClassOp -> UniType {-SigmaType-} +getClassOpLocalType (MkClassOp _ _ ty) = ty +\end{code} + +%************************************************************************ +%* * +\subsection[ClassOp-instances]{Instance declarations for @ClassOp@} +%* * +%************************************************************************ + +@ClassOps@ are compared by their tags. + +\begin{code} +instance Eq ClassOp where + (MkClassOp _ i1 _) == (MkClassOp _ i2 _) = i1 == i2 + (MkClassOp _ i1 _) /= (MkClassOp _ i2 _) = i1 == i2 + +instance Ord ClassOp where + (MkClassOp _ i1 _) <= (MkClassOp _ i2 _) = i1 <= i2 + (MkClassOp _ i1 _) < (MkClassOp _ i2 _) = i1 < i2 + (MkClassOp _ i1 _) >= (MkClassOp _ i2 _) = i1 >= i2 + (MkClassOp _ i1 _) > (MkClassOp _ i2 _) = i1 > i2 + -- ToDo: something for _tagCmp? (WDP 94/10) +\end{code} + +And the usual output stuff: +\begin{code} +instance Outputable ClassOp where + ppr = pprClassOp +\end{code} diff --git a/ghc/compiler/uniType/TyCon.hi b/ghc/compiler/uniType/TyCon.hi new file mode 100644 index 0000000..d75b2bc --- /dev/null +++ b/ghc/compiler/uniType/TyCon.hi @@ -0,0 +1,113 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TyCon where +import Class(Class, ClassOp) +import Id(DataCon(..), Id, IdDetails) +import IdInfo(IdInfo) +import InstEnv(InstTemplate) +import Maybes(Labda) +import NameTypes(FullName, Provenance, ShortName) +import Outputable(ExportFlag, NamedThing, Outputable) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import SrcLoc(SrcLoc) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +type Arity = Int +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +type DataCon = Id +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data TyCon = SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +cmpTyCon :: TyCon -> TyCon -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +derivedFor :: Class -> TyCon -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 9 \ (u0 :: Class) (u1 :: TyCon) -> case u1 of { _ALG_ _ORIG_ TyCon DataTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [TyVarTemplate]) (u6 :: [Id]) (u7 :: [Class]) (u8 :: Bool) -> _APP_ _WRKR_ _SPEC_ _ORIG_ Util isIn [ (Class) ] [ u0, u7 ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-} +eqTyCon :: TyCon -> TyCon -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +getTyConArity :: TyCon -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyConDataCons :: TyCon -> [Id] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyConDerivings :: TyCon -> [Class] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon DataTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: [Id]) (u6 :: [Class]) (u7 :: Bool) -> u6; _ORIG_ TyCon SpecTyCon (u8 :: TyCon) (u9 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { [Class] } [ _NOREP_S_ "getTyConDerivings:SpecTyCon" ]; (ua :: TyCon) -> _!_ _NIL_ [Class] [] } _N_ #-} +getTyConFamilySize :: TyCon -> Labda Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyConKind :: TyCon -> [PrimKind] -> PrimKind + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 8 \ (u0 :: TyCon) (u1 :: [PrimKind]) -> case u0 of { _ALG_ _ORIG_ TyCon PrimTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [PrimKind] -> PrimKind) -> _APP_ u5 [ u1 ]; (u6 :: TyCon) -> _!_ _ORIG_ PrimKind PtrKind [] [] } _N_ #-} +getTyConTyVarTemplates :: TyCon -> [TyVarTemplate] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isBigTupleTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isBoxedTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isDataTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isEnumerationTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isLocalGenTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isLocalSpecTyCon :: Bool -> TyCon -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-} +isPrimTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isSynTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> _!_ True [] []; _ORIG_ TyCon SpecTyCon (u7 :: TyCon) (u8 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isSynTyCon: SpecTyCon" ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-} +isTupleTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isVisibleSynTyCon :: TyCon -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> u6; (u7 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isVisibleSynTyCon" ] } _N_ #-} +maybeCharLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeDoubleLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeFloatLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeIntLikeTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeSingleConstructorTyCon :: TyCon -> Labda Id + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkDataTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> [Id] -> [Class] -> Bool -> TyCon + {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: [Id]) (u5 :: [Class]) (u6 :: Bool) -> _!_ _ORIG_ TyCon DataTyCon [] [u0, u1, u2, u3, u4, u5, u6] _N_ #-} +mkPrimTyCon :: Unique -> FullName -> Int -> ([PrimKind] -> PrimKind) -> TyCon + {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [PrimKind] -> PrimKind) -> _!_ _ORIG_ TyCon PrimTyCon [] [u0, u1, u2, u3] _N_ #-} +mkSpecTyCon :: TyCon -> [Labda UniType] -> TyCon + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [Labda UniType]) -> _!_ _ORIG_ TyCon SpecTyCon [] [u0, u1] _N_ #-} +mkSynonymTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> UniType -> Bool -> TyCon + {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _F_ _IF_ARGS_ 0 6 XXXXXX 7 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: UniType) (u5 :: Bool) -> _!_ _ORIG_ TyCon SynonymTyCon [] [u0, u1, u2, u3, u4, u5] _N_ #-} +mkTupleTyCon :: Int -> TyCon + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ TyCon TupleTyCon [] [u0] _N_ #-} +instance Eq TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Ord TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance NamedThing TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_ + getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +instance Outputable TyCon + {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_ + ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-} + diff --git a/ghc/compiler/uniType/TyCon.lhs b/ghc/compiler/uniType/TyCon.lhs new file mode 100644 index 0000000..ddf1716 --- /dev/null +++ b/ghc/compiler/uniType/TyCon.lhs @@ -0,0 +1,585 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TyCon]{Type constructors} + +\begin{code} +#include "HsVersions.h" + +module TyCon ( + TyCon(..), -- not abstract; usually grabbed via AbsUniType + Arity(..), -- synonym for Int + mkSynonymTyCon, mkDataTyCon, mkTupleTyCon, + mkPrimTyCon, mkSpecTyCon, +#ifdef DPH + mkProcessorTyCon, + mkPodizedPodTyCon, + isProcessorTyCon, + isPodizedPodTyCon, + getPodizedPodDimension, +#endif {- Data Parallel Haskell -} + + isSynTyCon, isVisibleSynTyCon, isDataTyCon, + isPrimTyCon, isBoxedTyCon, + maybeCharLikeTyCon, maybeIntLikeTyCon, + maybeFloatLikeTyCon, maybeDoubleLikeTyCon, + isEnumerationTyCon, --UNUSED: isEnumerationTyConMostly, + isTupleTyCon, + isLocalSpecTyCon, isLocalGenTyCon, isBigTupleTyCon, + maybeSingleConstructorTyCon, + derivedFor, --UNUSED: preludeClassDerivedFor, + cmpTyCon, eqTyCon, + + getTyConArity, getTyConDataCons, + getTyConTyVarTemplates, + getTyConKind, + getTyConDerivings, + getTyConFamilySize, + + -- to make the interface self-sufficient... + Class, Id, FullName, PrimKind, TyVarTemplate, UniType, + Unique, Maybe, DataCon(..) + ) where + +IMPORT_Trace -- ToDo: rm (debugging) + +import AbsPrel ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, pRELUDE_BUILTIN + ) + +import Class ( getClassKey, Class + IF_ATTACK_PRAGMAS(COMMA cmpClass) + ) +import Id -- DPH wants to export various things as well +import IdInfo +import Maybes ( Maybe(..) ) +import NameTypes -- various types to do with names +import Outputable -- class for printing, forcing +import Pretty -- pretty-printing utilities +import PrimKind ( PrimKind(..) ) +import SrcLoc +import TyVar ( TyVarTemplate, alphaTyVars ) +import Unique ( cmpUnique, Unique ) +import UniTyFuns ( getTauType, getUniDataTyCon, pprTyCon, + cmpUniTypeMaybeList, specMaybeTysSuffix + IF_ATTACK_PRAGMAS(COMMA pprUniType COMMA splitType) + ) +import UniType ( UniType + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[TyCon-basics]{@TyCon@ type and basic operations} +%* * +%************************************************************************ + +\begin{code} +data TyCon + = SynonymTyCon Unique{-TyConKey-} -- for fast comparison + FullName + Arity + [TyVarTemplate]-- Argument type variables + UniType -- Right-hand side, mentioning these type vars + -- Acts as a template for the expansion when + -- the tycon is applied to some types. + Bool -- True <=> expansion is visible to user; + -- i.e., *not* abstract + + | DataTyCon Unique{-TyConKey-} + FullName + Arity + [TyVarTemplate] -- see note below + [Id] -- its data constructors + [Class] -- classes which have derived instances + Bool -- True <=> data constructors are visible + -- to user; i.e., *not* abstract + + | TupleTyCon Arity -- just a special case of DataTyCon + + | PrimTyCon -- Primitive types; cannot be defined in Haskell + -- Always unboxed; hence never represented by a closure + -- Often represented by a bit-pattern for the thing + -- itself (eg Int#), but sometimes by a pointer to + -- a heap-allocated object (eg ArrInt#). + -- The primitive types Arr# and StablePtr# have + -- parameters (hence arity /= 0); but the rest don't. + Unique{-TyConKey-} + FullName + Arity -- Arity is *usually* 0. + ([PrimKind] -> PrimKind) + -- Only arrays use the list in a non-trivial way. + -- Length of that list must == arity. + + -- Used only for naming purposes in CLabels + | SpecTyCon TyCon -- original data (or tuple) tycon + [Maybe UniType] -- specialising types + +#ifdef DPH + | ProcessorTyCon Arity -- special cased in same way as tuples + + | PodizedPodTyCon Int -- podized dimension + TyCon -- Thing the pod contains +#endif + +type Arity = Int +\end{code} + +{\em Note about the the @[TyVarTemplates]@ in @DataTyCon@ (and +@SynonymTyCon@, too? ToDo):} they should be the type variables which +appeared in the original @data@ declaration. They are there {\em for +documentation purposes only}. In particular, when printing out +interface files, we want to use the same type-variable names as +appeared in the @data@ declaration for that type constructor. +However, they have no semantic significance. + +We could also ensure that the data constructors in the @[Id]@ had the +{\em same} type vars in their @[TyVarTemplate]@ lists, so that we +don't have to do a translation on printout. +{\em End of note.} + +Constructor functions, and simple access functions: +\begin{code} +mkSynonymTyCon = SynonymTyCon +mkDataTyCon = DataTyCon +mkTupleTyCon = TupleTyCon +mkPrimTyCon = PrimTyCon +mkSpecTyCon = SpecTyCon + +#ifdef DPH +mkProcessorTyCon= ProcessorTyCon +mkPodizedPodTyCon = PodizedPodTyCon +#endif {- Data Parallell Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[TyCon-extractors]{Extractors for @TyCon@} +%* * +%************************************************************************ + +\begin{code} +getTyConArity (PrimTyCon _ _ a _) = a +getTyConArity (SynonymTyCon _ _ a _ _ _) = a +getTyConArity (DataTyCon _ _ a _ _ _ _) = a +getTyConArity (SpecTyCon tc tys) = getTyConArity tc - length tys +getTyConArity (TupleTyCon a) = a +#ifdef DPH +getTyConArity (ProcessorTyCon a) = a +getTyConArity (PodizedPodTyCon _ _) = panic "getTyConArity: pod" +#endif {- Data Parallel Haskell -} + +getTyConKind (PrimTyCon _ _ _ kind_fn) kinds = kind_fn kinds +#ifdef DPH +getTyConKind (PodizedPodTyCon _ tc) kinds = getTyConKind tc kinds +#endif {- Data Parallel Haskell -} +getTyConKind other kinds = PtrKind -- the "default" + +getTyConDerivings (DataTyCon _ _ _ _ _ derivings _) = derivings +getTyConDerivings (SpecTyCon tc tys) = panic "getTyConDerivings:SpecTyCon" +#ifdef DPH +getTyConDerivings (PodizedPodTyCon _ _) = panic "getTyConDerivings:pod" +#endif {- Data Parallel Haskell -} +getTyConDerivings other = [] + -- NB: we do *not* report the PreludeCore types "derivings"... + +getTyConDataCons (DataTyCon _ _ _ _ data_cons _ _) = data_cons +getTyConDataCons (SpecTyCon tc tys) = panic "getTyConDataCons:SpecTyCon" +getTyConDataCons (TupleTyCon a) = [mkTupleCon a] +#ifdef DPH +getTyConDataCons (ProcessorTyCon a) = [mkProcessorCon a] +getTyConDataCons (PodizedPodTyCon _ _) = panic "getTyConDataCons: pod" +#endif {- Data Parallel Haskell -} +getTyConDataCons other_tycon = [] +\end{code} +For the use of @getTyConDataCons@ in @MkUnfoldings@, the behaviour +above is right: return @[]@ if not an algebraic data type. I am not +certain if that's right for all uses (perhaps should @panic@?) [WDP] + +The following function returns (free) type-variables associated with a +given @TyCon@. As the information about these variables is distributed +over the @TyCon@'s constructors we take them from the type of any +of the constructors assuming that the variables in the remaining +type constructors are the same (responsible for keeping this assumption +valid is the typechecker). ToDo: rm this old comment? +\begin{code} +getTyConTyVarTemplates (SynonymTyCon _ _ _ tvs _ _) = tvs +getTyConTyVarTemplates (DataTyCon _ _ _ tvs _ _ _) = tvs +getTyConTyVarTemplates (SpecTyCon tc tys) = panic "getTyConTyVarTemplates:SpecTyCon" +getTyConTyVarTemplates (TupleTyCon a) = take a alphaTyVars +getTyConTyVarTemplates (PrimTyCon _ _ _ _) = [] -- ToDo: ??? +#ifdef DPH +getTyConTyVarTemplates (ProcessorTyCon a) = take a alphaTyVars +getTyConTyVarTemplates (PodizedPodTyCon _ _) = panic "getTyConTyVarTem" +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +getTyConFamilySize :: TyCon -> Maybe Int -- return Nothing if we don't know + +getTyConFamilySize (TupleTyCon _) = Just 1 +getTyConFamilySize (SpecTyCon tc tys) = getTyConFamilySize tc +getTyConFamilySize (DataTyCon _ _ _ _ dcs _ _) + = let + no_data_cons = length dcs + in + if no_data_cons == 0 then Nothing else Just no_data_cons + +#ifdef DEBUG + -- ToDo: if 0 then the answer is really "I don't know"; what then? +getTyConFamilySize tc@(PrimTyCon _ _ _ _) + = pprPanic "getTyConFamilySize:prim:" (ppr PprDebug tc) +getTyConFamilySize (SynonymTyCon _ _ _ _ expand _) + = pprTrace "getTyConFamilySize:Syn:" (ppr PprDebug expand) ( + let + (tycon,_,data_cons) = getUniDataTyCon (getTauType expand) + no_data_cons = length data_cons + in + if no_data_cons == 0 then Nothing else Just no_data_cons + ) +#endif +#ifdef DPH +getTyConFamilySize (ProcessorTyCon _) = Just 1 +getTyConFamilySize (PodizedPodTyCon _ _) = panic "getTyConFamilySize: Pod" +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[TyCon-predicates]{Predicates on @TyCon@s} +%* * +%************************************************************************ + +\begin{code} +-- True <=> Algebraic data type +isDataTyCon (DataTyCon _ _ _ _ _ _ _) = True +isDataTyCon (SpecTyCon tc tys) = isDataTyCon tc +isDataTyCon (TupleTyCon _) = True +#ifdef DPH +isDataTyCon (ProcessorTyCon _) = True +isDataTyCon (PodizedPodTyCon _ tc) = isDataTyCon tc +#endif {- Data Parallel Haskell -} +isDataTyCon other = False + +-- True <=> Synonym +isSynTyCon (SynonymTyCon _ _ _ _ _ _) = True +isSynTyCon (SpecTyCon tc tys) = panic "isSynTyCon: SpecTyCon" +#ifdef DPH +isSynTyCon (PodizedPodTyCon _ _) = panic "isSynTyCon: Pod" +#endif {- Data Parallel Haskell -} +isSynTyCon other = False + +isVisibleSynTyCon (SynonymTyCon _ _ _ _ _ visible) = visible +isVisibleSynTyCon other_tycon = panic "isVisibleSynTyCon" + +isPrimTyCon (PrimTyCon _ _ _ _) = True +isPrimTyCon (SpecTyCon tc tys) = isPrimTyCon tc +#ifdef DPH +isPrimTyCon (PodizedPodTyCon _ tc) = isPrimTyCon tc +#endif {- Data Parallel Haskell -} +isPrimTyCon other = False + +-- At present there are no unboxed non-primitive types, so isBoxedTyCon is +-- just the negation of isPrimTyCon. +isBoxedTyCon (PrimTyCon _ _ _ _) = False +isBoxedTyCon (SpecTyCon tc tys) = isBoxedTyCon tc +#ifdef DPH +isBoxedTyCon (PodizedPodTyCon _ tc) = isBoxedTyCon tc +#endif {- Data Parallel Haskell -} +isBoxedTyCon other = True + +\end{code} + +The @maybeCharLikeTyCon@ predicate tests for a tycon with no type +variables, and one constructor which has one argument of type +@CharPrim@. Similarly @maybeIntLikeTyCon@, etc. + +ToDo:SpecTyCon Do we want to CharLike etc for SpecTyCons ??? + +\begin{code} +maybeCharLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con charPrimTy +#ifdef DPH +maybeCharLikeTyCon (PodizedPodTyCon _ _) = panic "maybeCharLikeTyCon: Pod" +#endif {- Data Parallel Haskell -} +maybeCharLikeTyCon other = Nothing + +maybeIntLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con intPrimTy +#ifdef DPH +maybeIntLikeTyCon (PodizedPodTyCon _ _) = panic "maybeIntLikeTyCon: Pod" +#endif {- Data Parallel Haskell -} +maybeIntLikeTyCon other = Nothing + +maybeFloatLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con floatPrimTy +#ifdef DPH +maybeFloatLikeTyCon (PodizedPodTyCon _ _) = panic "maybeFloatLikeTyCon: Pod" +#endif {- Data Parallel Haskell -} +maybeFloatLikeTyCon other = Nothing + +maybeDoubleLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con doublePrimTy +#ifdef DPH +maybeDoubleLikeTyCon (PodizedPodTyCon _ _) = panic "maybeDoubleLikeTyCon: Pod" +#endif {- Data Parallel Haskell -} +maybeDoubleLikeTyCon other = Nothing + +maybe_foo_like con prim_type_to_match + = case (getDataConSig con) of + ([], [], [should_be_prim], _) + | should_be_prim == prim_type_to_match -> Just con + other -> Nothing + +#ifdef DPH +isProcessorTyCon :: TyCon -> Bool +isProcessorTyCon (ProcessorTyCon _) = True +isProcessorTyCon other = False + +isPodizedPodTyCon :: TyCon -> Bool +isPodizedPodTyCon (PodizedPodTyCon _ _) = True +isPodizedPodTyCon other = False + +getPodizedPodDimension::TyCon -> Int +getPodizedPodDimension (PodizedPodTyCon d _) = d +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +isEnumerationTyCon :: TyCon -> Bool + +isEnumerationTyCon (TupleTyCon arity) + = arity == 0 +isEnumerationTyCon (DataTyCon _ _ _ _ data_cons _ _) + = not (null data_cons) && all is_nullary data_cons + where + is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) -> + null arg_tys } +#ifdef DEBUG +-- isEnumerationTyCon (SpecTyCon tc tys) -- ToDo:SpecTyCon +isEnumerationTyCon other = pprPanic "isEnumerationTyCon: " (ppr PprShowAll other) +#endif + +-- this one is more of a *heuristic* +{- UNUSED: +isEnumerationTyConMostly :: TyCon -> Bool + +isEnumerationTyConMostly (TupleTyCon arity) = arity == 0 + +isEnumerationTyConMostly tycon@(DataTyCon _ _ _ _ data_cons _ _) + = isEnumerationTyCon tycon + || four_or_more data_cons 0 + where + four_or_more :: [Id] -> Int -> Bool + + four_or_more [] acc = if acc >= 4 then True else False + four_or_more (c:cs) acc + = case (getDataConSig c) of { (_,_, arg_tys, _) -> + four_or_more cs (if (null arg_tys) then acc+1 else acc) + } +-- isEnumerationTyConMostly (SpecTyCon tc tys) -- ToDo:SpecTyCon +-} + + +maybeSingleConstructorTyCon :: TyCon -> Maybe Id +maybeSingleConstructorTyCon (TupleTyCon arity) = Just (mkTupleCon arity) +maybeSingleConstructorTyCon (DataTyCon _ _ _ _ [c] _ _) = Just c +maybeSingleConstructorTyCon (DataTyCon _ _ _ _ _ _ _) = Nothing +maybeSingleConstructorTyCon (PrimTyCon _ _ _ _) = Nothing +maybeSingleConstructorTyCon (SpecTyCon tc tys) = panic "maybeSingleConstructorTyCon:SpecTyCon" + -- requires DataCons of TyCon +\end{code} + +@derivedFor@ reports if we have an {\em obviously}-derived instance +for the given class/tycon. Of course, you might be deriving something +because it a superclass of some other obviously-derived class---this +function doesn't deal with that. + +ToDo:SpecTyCon Do we want derivedFor etc for SpecTyCons ??? + +\begin{code} +derivedFor :: Class -> TyCon -> Bool + +clas `derivedFor` (DataTyCon _ _ _ _ _ derivs _) = clas `is_elem` derivs +clas `derivedFor` something_weird = False + +x `is_elem` y = isIn "X_derivedFor" x y + +{- UNUSED: +preludeClassDerivedFor :: Unique{-ClassKey-} -> TyCon -> Bool + +preludeClassDerivedFor key (DataTyCon _ _ _ _ _ derivs _) + = key `is_elem` (map getClassKey derivs) +preludeClassDerivedFor key something_weird = False +-} +\end{code} + +\begin{code} +isTupleTyCon (TupleTyCon arity) = arity >= 2 -- treat "0-tuple" specially +isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc +isTupleTyCon other = False +\end{code} + +@isLocalSpecTyCon@ determines if a tycon has specialisations created +locally: locally defined tycons and any tycons from the prelude. +But *not* if we're compiling the prelude itself... + +@isLocalGenTyCon@ determines if constructor code for a tycon is +generated locally: locally defined tycons and big tuple tycons. + +\begin{code} +isLocalSpecTyCon :: Bool -> TyCon -> Bool + +isLocalSpecTyCon compiling_prelude tc + = isLocallyDefined tc || (fromPreludeCore tc && not compiling_prelude) + +isLocalGenTyCon (SpecTyCon tc tys) = isLocalGenTyCon tc +isLocalGenTyCon tc = isBigTupleTyCon tc || isLocallyDefined tc + +isBigTupleTyCon (TupleTyCon arity) = arity > 32 + -- Tuple0 to Tuple32 declared in prelude + -- HEY! Nice magic constant! WDP 95/06 +isBigTupleTyCon (SpecTyCon tc _) = isBigTupleTyCon tc +isBigTupleTyCon _ = False +\end{code} + +%************************************************************************ +%* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +%* * +%************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. + +The strictness analyser needs @Ord@. It is a lexicographic order with +the property @(a<=b) || (b<=a)@. + +\begin{code} +cmpTyCon (SynonymTyCon k1 _ _ _ _ _) (SynonymTyCon k2 _ _ _ _ _)= cmpUnique k1 k2 +cmpTyCon (DataTyCon k1 _ _ _ _ _ _) (DataTyCon k2 _ _ _ _ _ _) = cmpUnique k1 k2 +cmpTyCon (TupleTyCon a1) (TupleTyCon a2) = cmp_i a1 a2 +cmpTyCon (PrimTyCon k1 _ _ _) (PrimTyCon k2 _ _ _) = cmpUnique k1 k2 +cmpTyCon (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2) + = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList mtys1 mtys2; other -> other } +#ifdef DPH +cmpTyCon (ProcessorTyCon a1) (ProcessorTyCon a2) = cmp_i a1 a2 +cmpTyCon (PodizedPodTyCon d1 tc1) (PodizedPodTyCon d2 tc2) + = case cmp_i d1 d2 of { EQ_ -> cmpTyCon tc1 tc2; other -> other } +#endif {- Data Parallel Haskell -} + + -- now we *know* the tags are different, so... +cmpTyCon other_1 other_2 + = let + tag1 = tag_TyCon other_1 + tag2 = tag_TyCon other_2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag_TyCon (SynonymTyCon _ _ _ _ _ _) = (ILIT(1) :: FAST_INT) + tag_TyCon (DataTyCon _ _ _ _ _ _ _)= ILIT(2) + tag_TyCon (TupleTyCon _) = ILIT(3) + tag_TyCon (PrimTyCon _ _ _ _) = ILIT(4) + tag_TyCon (SpecTyCon _ _) = ILIT(5) +#ifdef DPH + tag_TyCon (ProcessorTyCon _) = ILIT(6) + tag_TyCon (PodizedPodTyCon _ _) = ILIT(7) +#endif {- Data Parallel Haskell -} + +cmp_i :: Int -> Int -> TAG_ +cmp_i a1 a2 + = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_ +\end{code} + +\begin{code} +eqTyCon :: TyCon -> TyCon -> Bool + +eqTyCon a b = case cmpTyCon a b of { EQ_ -> True; _ -> False } + +instance Eq TyCon where + a == b = case cmpTyCon a b of { EQ_ -> True; _ -> False } + a /= b = case cmpTyCon a b of { EQ_ -> False; _ -> True } + +instance Ord TyCon where + a <= b = case cmpTyCon a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmpTyCon a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmpTyCon a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmpTyCon a b of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpTyCon a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +\begin{code} +instance NamedThing TyCon where + getExportFlag (TupleTyCon _) = NotExported +#ifdef DPH + getExportFlag (ProcessorTyCon _) = NotExported + getExportFlag (PodizedPodTyCon _ tc) = getExportFlag tc +#endif {- Data Parallel Haskell -} + getExportFlag other = getExportFlag (get_name other) + + isLocallyDefined (TupleTyCon _) = False +#ifdef DPH + isLocallyDefined (ProcessorTyCon _) = False + isLocallyDefined (PodizedPodTyCon _ tc) = isLocallyDefined tc +#endif {- Data Parallel Haskell -} + isLocallyDefined other = isLocallyDefined (get_name other) + + getOrigName (TupleTyCon a) = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ (show a))) + getOrigName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in + (m, n _APPEND_ specMaybeTysSuffix tys) +#ifdef DPH + getOrigName (ProcessorTyCon a) = ("PreludeBuiltin", "Processor" ++ (show a)) + getOrigName (PodizedPodTyCon d tc) = let (m,n) = getOrigName tc in + (m,n++"Pod"++show d) +#endif {- Data Parallel Haskell -} + getOrigName other = getOrigName (get_name other) + + getOccurrenceName (TupleTyCon a) = _PK_ ("Tuple" ++ (show a)) + getOccurrenceName (SpecTyCon tc tys) = getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys +#ifdef DPH + getOccurrenceName (ProcessorTyCon a) = "Processor" ++ (show a) + getOccurrenceName (PodizedPodTyCon d tc) = getOccurrenceName tc ++ + "Pod" ++ show d +#endif {- Data Parallel Haskell -} + getOccurrenceName other = getOccurrenceName (get_name other) + + getInformingModules (TupleTyCon a) = panic "getInformingModule:TupleTyCon" +#ifdef DPH + getInformingModules (ProcessorTyCon a) = "Processor" ++ (show a) + getInformingModules (PodizedPodTyCon d tc) = getInformingModule tc ++ + "Pod" ++ show d +#endif {- Data Parallel Haskell -} + getInformingModules other = getInformingModules (get_name other) + + getSrcLoc (TupleTyCon _) = mkBuiltinSrcLoc +#ifdef DPH + getSrcLoc (ProcessorTyCon _) = mkBuiltinSrcLoc + getSrcLoc (PodizedPodTyCon _ tc) = getSrcLoc tc +#endif {- Data Parallel Haskell -} + getSrcLoc other = getSrcLoc (get_name other) + + getTheUnique other = panic "NamedThing.TyCon.getTheUnique" + + fromPreludeCore (TupleTyCon a) = True +#ifdef DPH + fromPreludeCore (ProcessorTyCon a) = True + fromPreludeCore (PodizedPodTyCon _ tc) = fromPreludeCore tc +#endif {- Data Parallel Haskell -} + fromPreludeCore other = fromPreludeCore (get_name other) + + hasType = panic "NamedThing.TyCon.hasType" + getType = panic "NamedThing.TyCon.getType" +\end{code} + +Emphatically un-exported: +\begin{code} +get_name (SynonymTyCon _ n _ _ _ _) = n +get_name (DataTyCon _ n _ _ _ _ _) = n +get_name (PrimTyCon _ n _ _) = n +get_name (SpecTyCon tc _) = get_name tc +\end{code} + +And the usual output stuff: +\begin{code} +instance Outputable TyCon where + ppr sty tycon = pprTyCon sty tycon [{-No Specialisations-}] +\end{code} diff --git a/ghc/compiler/uniType/TyVar.hi b/ghc/compiler/uniType/TyVar.hi new file mode 100644 index 0000000..c6bcfd2 --- /dev/null +++ b/ghc/compiler/uniType/TyVar.hi @@ -0,0 +1,114 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface TyVar where +import NameTypes(ShortName) +import Outputable(NamedThing, Outputable) +import PreludePS(_PackedString) +import SrcLoc(SrcLoc) +import UniType(UniType) +import Unique(Unique) +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data TyVar = PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +alphaTyVars :: [TyVarTemplate] + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +alpha_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +alpha_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +beta_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +beta_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +cloneTyVar :: TyVar -> Unique -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +cloneTyVarFromTemplate :: TyVarTemplate -> Unique -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: TyVarTemplate) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u2 :: Unique) (u3 :: _PackedString) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u1]; _ORIG_ TyVar UserTyVarTemplate (u4 :: Unique) (u5 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u1, u5]; _NO_DEFLT_ } _N_ #-} +cmpTyVar :: TyVar -> TyVar -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +delta_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +delta_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +epsilon_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +epsilon_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +eqTyVar :: TyVar -> TyVar -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +gamma_tv :: TyVarTemplate + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +gamma_tyvar :: TyVar + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +instantiateTyVarTemplates :: [TyVarTemplate] -> [Unique] -> ([(TyVarTemplate, UniType)], [TyVar], [UniType]) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _N_ #-} +ltTyVar :: TyVar -> TyVar -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +mkOpenSysTyVar :: Unique -> TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar OpenSysTyVar [] [u0] _N_ #-} +mkPolySysTyVar :: Unique -> TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u0] _N_ #-} +mkSysTyVarTemplate :: Unique -> _PackedString -> TyVarTemplate + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: _PackedString) -> _!_ _ORIG_ TyVar SysTyVarTemplate [] [u0, u1] _N_ #-} +mkTemplateTyVars :: [TyVar] -> [TyVarTemplate] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mkUserTyVar :: Unique -> ShortName -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u0, u1] _N_ #-} +mkUserTyVarTemplate :: Unique -> ShortName -> TyVarTemplate + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVarTemplate [] [u0, u1] _N_ #-} +instance Eq TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-} +instance Eq TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_ + (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_ + (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Ord TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_ + (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_, + max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_, + _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +instance NamedThing TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-} +instance NamedThing TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_ + getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_, + isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_, + getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_, + getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_, + getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_, + getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_, + hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_, + getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_, + fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-} +instance Outputable TyVar + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_ + ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable TyVarTemplate + {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_ + ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/uniType/TyVar.lhs b/ghc/compiler/uniType/TyVar.lhs new file mode 100644 index 0000000..4723b8c --- /dev/null +++ b/ghc/compiler/uniType/TyVar.lhs @@ -0,0 +1,344 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[TyVar]{Type variables} + +\begin{code} +#include "HsVersions.h" + +module TyVar ( + TyVar(..), -- non-abstract for unifier's benefit + TyVarTemplate, + + mkUserTyVar, mkPolySysTyVar, mkOpenSysTyVar, +--UNUSED: mkPrimSysTyVar, isPrimTyVar, + +-- getTyVarUnique, + + cmpTyVar, eqTyVar, ltTyVar, -- used a lot! + + mkUserTyVarTemplate, mkSysTyVarTemplate, mkTemplateTyVars, + + cloneTyVarFromTemplate, + cloneTyVar, + instantiateTyVarTemplates, + + -- a supply of template tyvars + alphaTyVars, + alpha_tv, beta_tv, gamma_tv, delta_tv, epsilon_tv, -- templates + alpha_tyvar, beta_tyvar, gamma_tyvar, delta_tyvar, epsilon_tyvar,-- real tyvars + + -- so the module is self-contained... + ShortName + ) where + +import NameTypes ( ShortName ) +import Outputable -- class for printing, forcing +import Pretty -- pretty-printing utilities +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import Unique +import UniType ( mkTyVarTy, TauType(..), InstTyEnv(..), UniType + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Util + +#ifndef __GLASGOW_HASKELL__ +{-hide import from mkdependHS-} +import + Word +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[TyVar-basics]{@TyVar@ type and basic operations} +%* * +%************************************************************************ + +We distinguish system from user type variables so that the unifier can +bias in terms of replacing system with user ones rather than vice +versa. + +\begin{code} +data TyVar + = PrimSysTyVar -- Can only be unified with a primitive type + Unique -- Cannot be generalised + -- Introduced by ccalls + + | PolySysTyVar -- Can only be unified with a boxed type + Unique -- Can be generalised + -- Introduced when a polymorphic type is instantiated + + | OpenSysTyVar -- Can unify with any type at all + Unique -- Can be generalised, but remember that the resulting + -- polymorphic type will be instantiated with PolySysTyVars + -- Introduced by lambda bindings + + | UserTyVar -- This is exactly like PolySysTyVar except that it + Unique -- has a name attached, derived from something the user typed + ShortName + +-- **** NB: Unboxed but non-primitive things (which don't exist at all at present) +-- are not catered for by the above scheme. + +mkPolySysTyVar = PolySysTyVar +mkUserTyVar = UserTyVar +mkOpenSysTyVar = OpenSysTyVar +--UNUSED:mkPrimSysTyVar = PrimSysTyVar + +{-UNUSED +isPrimTyVar (PrimSysTyVar _) = True +isPrimTyVar other = False +-} + +-- Make a tyvar from a template, given also a unique +cloneTyVarFromTemplate :: TyVarTemplate -> Unique -> TyVar +cloneTyVarFromTemplate (SysTyVarTemplate _ _) uniq = PolySysTyVar uniq +cloneTyVarFromTemplate (UserTyVarTemplate _ n) uniq = UserTyVar uniq n + +instantiateTyVarTemplates + :: [TyVarTemplate] + -> [Unique] + -> (InstTyEnv, -- Old-to-new assoc list + [TyVar], -- New type vars + [TauType]) -- New type vars wrapped in a UniTyVar +instantiateTyVarTemplates tv_tmpls uniqs + = --pprTrace "instTyVarTemplates:" (ppr PprDebug new_tys) + (tv_tmpls `zipEqual` new_tys, new_tyvars, new_tys) + where + new_tyvars = zipWith cloneTyVarFromTemplate tv_tmpls uniqs + new_tys = map mkTyVarTy new_tyvars + +getTyVarUnique :: TyVar -> Unique +getTyVarUnique (PolySysTyVar u) = u +getTyVarUnique (PrimSysTyVar u) = u +getTyVarUnique (OpenSysTyVar u) = u +getTyVarUnique (UserTyVar u _) = u +\end{code} + +Make a new TyVar ``just like'' another one, but w/ a new @Unique@. +Used when cloning big lambdas. his is only required after +typechecking so the @TyVarUnique@ is just a normal @Unique@. + +\begin{code} +cloneTyVar :: TyVar -> Unique -> TyVar + +cloneTyVar (PolySysTyVar _) uniq = PolySysTyVar uniq +cloneTyVar (PrimSysTyVar _) uniq = PrimSysTyVar uniq +cloneTyVar (OpenSysTyVar _) uniq = OpenSysTyVar uniq +cloneTyVar (UserTyVar _ n) uniq = UserTyVar uniq n +\end{code} + +%************************************************************************ +%* * +\subsection[TyVar-template]{The @TyVarTemplate@ type} +%* * +%************************************************************************ + +A @TyVarTemplate@ is a type variable which is used by @UniForall@ to +universally quantify a type. It only occurs in a {\em binding} +position in a @UniForall@, not (for example) in a @TyLam@ or +@AbsBinds@. Every occurrence of a @TyVarTemplate@ in a @UniType@ is +bound by an enclosing @UniForall@, with the sole exception that the +type in a @ClassOp@ has a free @TyVarTemplate@ which is the class type +variable; it is found in the corresponding @Class@ object. + +\begin{code} +data TyVarTemplate + = SysTyVarTemplate Unique FAST_STRING + | UserTyVarTemplate Unique ShortName + +mkSysTyVarTemplate = SysTyVarTemplate +mkUserTyVarTemplate = UserTyVarTemplate + +getTyVarTemplateUnique (SysTyVarTemplate u _) = u +getTyVarTemplateUnique (UserTyVarTemplate u _) = u +\end{code} + +\begin{code} +alpha_tv, beta_tv, gamma_tv, delta_tv, epsilon_tv :: TyVarTemplate +alpha_tv = SysTyVarTemplate (mkBuiltinUnique 1) SLIT("a") +beta_tv = SysTyVarTemplate (mkBuiltinUnique 2) SLIT("b") +gamma_tv = SysTyVarTemplate (mkBuiltinUnique 3) SLIT("c") +delta_tv = SysTyVarTemplate (mkBuiltinUnique 4) SLIT("d") +epsilon_tv = SysTyVarTemplate (mkBuiltinUnique 5) SLIT("e") + +alpha_tyvar, beta_tyvar, gamma_tyvar, delta_tyvar, epsilon_tyvar :: TyVar +alpha_tyvar = PolySysTyVar (mkBuiltinUnique 1) +beta_tyvar = PolySysTyVar (mkBuiltinUnique 2) +gamma_tyvar = PolySysTyVar (mkBuiltinUnique 3) +delta_tyvar = PolySysTyVar (mkBuiltinUnique 4) +epsilon_tyvar = PolySysTyVar (mkBuiltinUnique 5) + +-- these are used in tuple magic (see TyCon.lhs and Id.lhs) +alphaTyVars :: [TyVarTemplate] +alphaTyVars = alphas_from (10::Int) tyVarStrings + where + alphas_from :: Int -> [FAST_STRING] -> [TyVarTemplate] + alphas_from n (s:ss) + = SysTyVarTemplate (mkBuiltinUnique n) s : (alphas_from (n+1) ss) + +tyVarStrings :: [FAST_STRING] +tyVarStrings + = letter_strs {- a..y -} ++ number_strs {- z0 ... zN -} + where + letter_strs = [ _PK_ [c] | c <- ['d' .. 'y'] ] + number_strs = [ _PK_ ('z': show n) | n <- ([0 .. ] :: [Int]) ] +\end{code} + +@mkTemplateTyVars@ creates new template type variables, giving them +the same name and unique as the type variable given to it. (The name +is for documentation purposes; the unique could just as well be +fresh.) + +\begin{code} +mkTemplateTyVars :: [TyVar] -> [TyVarTemplate] + +mkTemplateTyVars tyvars + = zipWith mk_tmpl tyvars tyVarStrings + where + mk_tmpl (UserTyVar u name) str = UserTyVarTemplate u name + mk_tmpl (PolySysTyVar u) str = SysTyVarTemplate u str + mk_tmpl (OpenSysTyVar u) str = SysTyVarTemplate u str +\end{code} + +%************************************************************************ +%* * +\subsection[TyVar-instances]{Instance declarations for @TyVar@} +%* * +%************************************************************************ + +@TyVars@s are compared by comparing their @Unique@s. (Often!) +\begin{code} +cmpTyVar (PolySysTyVar u1) (PolySysTyVar u2) = u1 `cmpUnique` u2 +cmpTyVar (PrimSysTyVar u1) (PrimSysTyVar u2) = u1 `cmpUnique` u2 +cmpTyVar (OpenSysTyVar u1) (OpenSysTyVar u2) = u1 `cmpUnique` u2 +cmpTyVar (UserTyVar u1 _) (UserTyVar u2 _) = u1 `cmpUnique` u2 +cmpTyVar other_1 other_2 + = let tag1 = tag other_1 + tag2 = tag other_2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag (PolySysTyVar _) = (ILIT(1) :: FAST_INT) + tag (PrimSysTyVar _) = ILIT(2) + tag (OpenSysTyVar _) = ILIT(3) + tag (UserTyVar _ _) = ILIT(4) +\end{code} + +\begin{code} +eqTyVar a b = case cmpTyVar a b of { EQ_ -> True; _ -> False } +ltTyVar a b = case cmpTyVar a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + +instance Eq TyVar where + a == b = case cmpTyVar a b of { EQ_ -> True; _ -> False } + a /= b = case cmpTyVar a b of { EQ_ -> False; _ -> True } + +instance Ord TyVar where + a <= b = case cmpTyVar a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmpTyVar a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmpTyVar a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmpTyVar a b of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpTyVar a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} +(@Ord@ for @TyVars@ is needed for the @sortLt@ in @TcSimplify@.) + +\begin{code} +instance NamedThing TyVar where + getExportFlag tyvar = NotExported + isLocallyDefined tyvar = True + + getOrigName (UserTyVar _ n) = (panic "NamedThing.TyVar.getOrigName(UserTyVar)", + getLocalName n) + getOrigName tyvar = (panic "NamedThing.TyVar.getOrigName(SysTyVar)", + _PK_ ('t' : (_UNPK_ (showUnique (getTyVarUnique tyvar))))) + + getOccurrenceName (UserTyVar _ n) = getOccurrenceName n + getOccurrenceName tyvar = _PK_ ('t' : (_UNPK_ (showUnique (getTyVarUnique tyvar)))) + + getInformingModules tyvar = panic "getInformingModule:TyVar" + + getSrcLoc (UserTyVar _ n) = getSrcLoc n + getSrcLoc _ = mkUnknownSrcLoc + + getTheUnique tyvar = getTyVarUnique tyvar + + fromPreludeCore _ = False +\end{code} + +\begin{code} +instance Outputable TyVar where + ppr sty (PolySysTyVar u) = ppr_tyvar sty (ppChar 't') u + ppr sty (PrimSysTyVar u) = ppr_tyvar sty (ppChar 'p') u + ppr sty (OpenSysTyVar u) = ppr_tyvar sty (ppChar 'o') u + ppr sty (UserTyVar u name) = ppr_tyvar sty (ppr sty name) u + +ppr_tyvar sty name u + = case sty of + --OLD: PprForUser -> name + PprDebug -> pprUnique10 u + PprUnfolding _ -> pprUnique10 u + _ -> ppBesides [name, ppChar '.', pprUnique10 u] +\end{code} + +%************************************************************************ +%* * +\subsection[TyVarTemplate-instances]{Instance declarations for @TyVarTemplates@} +%* * +%************************************************************************ + +\begin{code} +instance Eq TyVarTemplate where + a == b = getTyVarTemplateUnique a == getTyVarTemplateUnique b + a /= b = getTyVarTemplateUnique a /= getTyVarTemplateUnique b +\end{code} + +\begin{code} +instance Ord TyVarTemplate where + a <= b = getTyVarTemplateUnique a <= getTyVarTemplateUnique b + a < b = getTyVarTemplateUnique a < getTyVarTemplateUnique b + a >= b = getTyVarTemplateUnique a >= getTyVarTemplateUnique b + a > b = getTyVarTemplateUnique a > getTyVarTemplateUnique b +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpUnique (getTyVarTemplateUnique a) (getTyVarTemplateUnique b) + of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +\begin{code} +instance NamedThing TyVarTemplate where + getExportFlag tyvar = NotExported + isLocallyDefined tyvar = True + + getOrigName (UserTyVarTemplate _ n) = (panic "NamedThing.TyVar.getOrigName(UserTyVarTemplate)", + getLocalName n) + getOrigName tyvar = (panic "NamedThing.TyVar.getOrigName(SysTyVarTemplate)", + _PK_ ('t' : (_UNPK_ (showUnique (getTyVarTemplateUnique tyvar))))) + + getOccurrenceName (UserTyVarTemplate _ n) = getOccurrenceName n + getOccurrenceName tyvar = _PK_ ('t' : (_UNPK_ (showUnique (getTyVarTemplateUnique tyvar)))) + + getInformingModules tyvar = panic "getInformingModule:TyVarTemplate" + + getSrcLoc (UserTyVarTemplate _ n) = getSrcLoc n + getSrcLoc _ = mkUnknownSrcLoc + + getTheUnique tyvar = getTyVarTemplateUnique tyvar + + fromPreludeCore _ = False +\end{code} + +\begin{code} +instance Outputable TyVarTemplate where + ppr sty (SysTyVarTemplate u name) + = case sty of +--OLD: PprForUser -> ppPStr name + _ -> ppBesides [ppPStr name, ppChar '$', pprUnique10 u] + + ppr sty (UserTyVarTemplate u name) + = case sty of +--OLD: PprForUser -> ppr sty name + _ -> ppBesides [ppr sty name, ppChar '$', pprUnique10 u] +\end{code} diff --git a/ghc/compiler/uniType/UniTyFuns.hi b/ghc/compiler/uniType/UniTyFuns.hi new file mode 100644 index 0000000..acba0fe --- /dev/null +++ b/ghc/compiler/uniType/UniTyFuns.hi @@ -0,0 +1,175 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UniTyFuns where +import Bag(Bag) +import BasicLit(BasicLit) +import BinderInfo(BinderInfo) +import CharSeq(CSeq) +import Class(Class, ClassOp) +import CmdLineOpts(GlobalSwitch) +import CoreSyn(CoreAtom, CoreExpr) +import Id(Id) +import IdEnv(IdEnv(..)) +import InstEnv(InstTemplate) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda) +import NameTypes(FullName, ShortName) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle, PrettyRep) +import PrimKind(PrimKind) +import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance) +import SplitUniq(SplitUniqSupply) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TyVarEnv(..), TypeEnv(..)) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique, UniqueSupply) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +type IdEnv a = UniqFM a +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +type TypeEnv = UniqFM UniType +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +applyNonSynTyCon :: TyCon -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [UniType]) -> _!_ _ORIG_ UniType UniData [] [u0, u1] _N_ #-} +applySynTyCon :: TyCon -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +applyTy :: UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +applyTyCon :: TyCon -> [UniType] -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +applyTypeEnvToThetaTy :: UniqFM UniType -> [(a, UniType)] -> [(a, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +applyTypeEnvToTy :: UniqFM UniType -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +cmpUniTypeMaybeList :: [Labda UniType] -> [Labda UniType] -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-} +expandVisibleTySyn :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarsFromTy :: UniType -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +extractTyVarsFromTys :: [UniType] -> [TyVar] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +funResultTy :: UniType -> Int -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getMentionedTyCons :: TyCon -> [TyCon] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-} +getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTauType :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: UniType) -> case _APP_ _ORIG_ UniTyFuns splitType [ u0 ] of { _ALG_ _TUP_3 (u1 :: [TyVarTemplate]) (u2 :: [(Class, UniType)]) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-} +getTyVar :: [Char] -> UniType -> TyVar + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +getTyVarMaybe :: UniType -> Labda TyVar + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTyVarTemplateMaybe :: UniType -> Labda TyVarTemplate + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +getTypeString :: UniType -> [_PackedString] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataSpecTyCon :: UniType -> (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataSpecTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataTyCon :: UniType -> (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniDataTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id]) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +getUniTyDescription :: UniType -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +glueTyArgs :: [UniType] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +instanceIsExported :: Class -> UniType -> Bool -> Bool + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AU(AASLAA)AAAAAAAA)SL" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-} +isDictTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isForAllTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isFunType :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isGroundOrTyVarTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isGroundTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isLeakFreeType :: [TyCon] -> UniType -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +isPrimType :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTauTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTyVarTemplateTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isTyVarTy :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isUnboxedDataType :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +kindFromType :: UniType -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mapOverTyVars :: (TyVar -> UniType) -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +matchTy :: UniType -> UniType -> Labda [(TyVarTemplate, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +maybeBoxedPrimType :: UniType -> Labda (Id, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +maybePurelyLocalClass :: Class -> Labda [Int -> Bool -> PrettyRep] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-} +maybePurelyLocalTyCon :: TyCon -> Labda [Int -> Bool -> PrettyRep] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +maybePurelyLocalType :: UniType -> Labda [Int -> Bool -> PrettyRep] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +maybeUnpackFunTy :: UniType -> Labda (UniType, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +mkSuperDictSelType :: Class -> Class -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "U(LLLLLLLLLL)L" _N_ _N_ #-} +pprClassOp :: PprStyle -> ClassOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> UniqFM UnfoldingDetails -> Class -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 222122 _N_ _S_ "LLLU(ALLLLLLLAA)" _N_ _N_ #-} +pprMaybeTy :: PprStyle -> Labda UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SS" _N_ _N_ #-} +pprParendUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-} +pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +returnsRealWorld :: UniType -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +showTyCon :: PprStyle -> TyCon -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +showTypeCategory :: UniType -> Char + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +specMaybeTysSuffix :: [Labda UniType] -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +specialiseTy :: UniType -> [Labda UniType] -> Int -> UniType + {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLL" _N_ _N_ #-} +splitDictType :: UniType -> (Class, UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +splitForalls :: UniType -> ([TyVarTemplate], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +splitTyArgs :: UniType -> ([UniType], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +splitType :: UniType -> ([TyVarTemplate], [(Class, UniType)], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +splitTypeWithDictsAsArgs :: UniType -> ([TyVarTemplate], [UniType], UniType) + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +typeMaybeString :: Labda UniType -> [_PackedString] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unDictifyTy :: UniType -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/uniType/UniTyFuns.lhs b/ghc/compiler/uniType/UniTyFuns.lhs new file mode 100644 index 0000000..0fdb64e --- /dev/null +++ b/ghc/compiler/uniType/UniTyFuns.lhs @@ -0,0 +1,1940 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[UniTyFuns]{Utility functions for @UniTypes@} + +This is one of the modules whose functions know about the internal +representation of @UniTypes@ (and @TyCons@ and ... ?). + +\begin{code} +#include "HsVersions.h" + +module UniTyFuns ( + + -- CONSTRUCTION + applyTy, applyTyCon, applySynTyCon, applyNonSynTyCon, + {-mkSigmaTy,-} glueTyArgs, mkSuperDictSelType, --UNUSED: mkDictFunType, + specialiseTy, + + -- DESTRUCTION +--not exported: expandTySyns, + expandVisibleTySyn, + getTyVar, getTyVarMaybe, getTyVarTemplateMaybe, + splitType, splitForalls, getTauType, splitTyArgs, + splitTypeWithDictsAsArgs, +--not exported/unused: sourceTypes, targetType, + funResultTy, + splitDictType, + kindFromType, + getUniDataTyCon, getUniDataTyCon_maybe, + getUniDataSpecTyCon, getUniDataSpecTyCon_maybe, + unDictifyTy, + getMentionedTyCons, +#ifdef USE_SEMANTIQUE_STRANAL + getReferredToTyCons, +#endif {- Semantique strictness analyser -} + getMentionedTyConsAndClassesFromUniType, + getMentionedTyConsAndClassesFromTyCon, + getMentionedTyConsAndClassesFromClass, + getUniTyDescription, + + -- FREE-VARIABLE EXTRACTION + extractTyVarsFromTy, extractTyVarsFromTys, + extractTyVarTemplatesFromTy, + + -- PREDICATES + isTyVarTy, isTyVarTemplateTy, + maybeUnpackFunTy, isFunType, + isPrimType, isUnboxedDataType, -- UNUSED: isDataConType, + isLeakFreeType, + maybeBoxedPrimType, +--UNUSED: hasHigherOrderArg, + isDictTy, isGroundTy, isGroundOrTyVarTy, + instanceIsExported, +-- UNUSED: isSynTarget, + isTauTy, isForAllTy, + maybePurelyLocalTyCon, maybePurelyLocalClass, maybePurelyLocalType, + returnsRealWorld, -- HACK courtesy of SLPJ +#ifdef DPH + isProcessorTy, + runtimeUnpodizableType, +#endif {- Data Parallel Haskell -} + + -- SUBSTITUTION + applyTypeEnvToTy, applyTypeEnvToThetaTy, +--not exported : applyTypeEnvToTauTy, + mapOverTyVars, + -- moved to Subst: applySubstToTauTy, applySubstToTy, applySubstToThetaTy, + -- genInstantiateTyUS, -- ToDo: ??? + + -- PRETTY PRINTING AND FORCING + pprUniType, pprParendUniType, pprMaybeTy, + pprTyCon, pprIfaceClass, pprClassOp, + getTypeString, + typeMaybeString, + specMaybeTysSuffix, + showTyCon, + showTypeCategory, + + -- MATCHING and COMPARISON + matchTy, -- UNUSED: matchTys, + cmpUniTypeMaybeList, + + -- to make this interface self-sufficient.... + TyVar, TyVarTemplate, TyCon, Class, UniType, UniqueSupply, + IdEnv(..), UniqFM, UnfoldingDetails, PrimKind, TyVarEnv(..), + TypeEnv(..), Maybe, PprStyle, PrettyRep, Bag + ) where + +IMPORT_Trace -- ToDo:rm (debugging) + +-- internal modules; allowed to see constructors for type things +import Class +import TyVar +import TyCon +import UniType + +import AbsPrel ( listTyCon, integerTyCon, charPrimTyCon, + intPrimTyCon, wordPrimTyCon, addrPrimTyCon, + floatPrimTyCon, doublePrimTyCon, + realWorldTyCon +#ifdef DPH + , podTyCon +#endif {- Data Parallel Haskell -} + ) +import Bag +import CLabelInfo ( identToC ) +import CmdLineOpts ( GlobalSwitch(..) ) +import Id ( Id, getIdInfo, + getMentionedTyConsAndClassesFromId, + getInstantiatedDataConSig, + getDataConSig, mkSameSpecCon, + DataCon(..) + ) +import IdEnv -- ( lookupIdEnv, IdEnv ) +import IdInfo ( ppIdInfo, boringIdInfo, IdInfo, UnfoldingDetails ) +import InstEnv ( ClassInstEnv(..), MatchEnv(..) ) +import ListSetOps ( unionLists ) +import NameTypes ( FullName ) +import Maybes +import Outputable +import Pretty +import PrimKind ( PrimKind(..) ) +import SpecTyFuns ( specialiseConstrTys ) +import TyVarEnv +import Unique -- used UniqueSupply monadery +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-construction]{Putting types together} +%* * +%************************************************************************ + +\begin{code} +applyTy :: SigmaType -> SigmaType -> SigmaType + +applyTy (UniSyn _ _ fun_ty) arg_ty = applyTy fun_ty arg_ty +applyTy fun_ty@(UniForall tyvar ty) arg_ty + = instantiateTy [(tyvar,arg_ty)] ty +#ifdef DEBUG +applyTy bad_fun_ty arg_ty + = pprPanic "applyTy: not a forall type:" (ppAbove (ppr PprDebug bad_fun_ty) (ppr PprDebug arg_ty)) +#endif +\end{code} + +@applyTyCon@ applies a type constructor to a list of tau-types to give +a type. @applySynTyCon@ and @applyNonSynTyCon@ are similar, but they +``know'' what sort the type constructor is, so they are a bit lazier. +This is important in @TcMonoType.lhs@. + +\begin{code} +applyTyCon, applySynTyCon, applyNonSynTyCon :: TyCon -> [TauType] -> TauType + +applyTyCon tc tys + = ASSERT (if (getTyConArity tc == length tys) then True else pprTrace "applyTyCon" (ppCat [ppr PprDebug tc, ppr PprDebug tys]) False) + --false:ASSERT (all isTauTy tys) TauType?? 94/06 + let + result = apply_tycon tc tys + in + --false:ASSERT (isTauTy result) TauType?? 94/06 + result + where + apply_tycon tc@(SynonymTyCon _ _ _ _ _ _) tys = applySynTyCon tc tys + apply_tycon tc@(DataTyCon _ _ _ _ _ _ _) tys = applyNonSynTyCon tc tys + + apply_tycon tc@(PrimTyCon _ _ _ _) tys = UniData tc tys + + apply_tycon tc@(TupleTyCon _) tys = UniData tc tys + -- The arg types here aren't necessarily tau-types, because we + -- may have polymorphic methods in a dictionary. + + -- Original tycon used in type of SpecTyCon + apply_tycon tc_spec@(SpecTyCon tc spec_tys) tys + = apply_tycon tc (fill_nothings spec_tys tys) + where + fill_nothings (Just ty:maybes) fills = ty : fill_nothings maybes fills + fill_nothings (Nothing:maybes) (ty:fills) = ty : fill_nothings maybes fills + fill_nothings [] [] = [] + +#ifdef DPH + apply_tycon tc@(ProcessorTyCon _) tys = UniData tc tys +#endif {- Data Parallel Haskell -} + + +----------------- + +applySynTyCon tycon tys + = UniSyn tycon ok_tys (instantiateTauTy (tyvars `zip` ok_tys) template) + -- Memo the result of substituting for the tyvars in the template + where + SynonymTyCon _ _ _ tyvars template _ = tycon + -- NB: Matched lazily + +#ifdef DEBUG + ok_tys = map (verifyTauTy "applyTyConLazily[syn]") tys +#else + ok_tys = tys +#endif + +----------------- + +applyNonSynTyCon tycon tys -- We don't expect function tycons; + -- but it must be lazy, so we can't check that here! +#ifdef DEBUG + = UniData tycon (map (verifyTauTy "applyTyConLazily[data]") tys) +#else + = UniData tycon tys +#endif +\end{code} + +@glueTyArgs [ty1,...,tyn] ty@ returns the type +@ty1 -> ... -> tyn -> ty@. This is the exact reverse of @splitTyArgs@. + +\begin{code} +-- ToDo: DEBUG: say what's true about these types +glueTyArgs :: [UniType] -> UniType -> UniType + +glueTyArgs tys ty = foldr UniFun ty tys +\end{code} + +\begin{code} +mkSuperDictSelType :: Class -- The input class + -> Class -- The superclass + -> UniType -- The type of the selector function + +mkSuperDictSelType clas@(MkClass _ _ tyvar _ _ _ _ _ _ _) super + = UniForall tyvar (UniFun (UniDict clas (UniTyVarTemplate tyvar)) + (UniDict super (UniTyVarTemplate tyvar))) +\end{code} + +UNUSED: @mkDictFunType@ creates the type of a dictionary function, given: +the polymorphic type variables, the types of the dict args, the class and +tautype of the result. + +\begin{code} +{- UNUSED: +mkDictFunType :: [TyVarTemplate] -> ThetaType -> Class -> TauType -> UniType + +mkDictFunType tyvars theta clas tau_ty +#ifndef DEBUG + = mkForallTy tyvars (foldr f (UniDict clas tau_ty) theta) +#else + = mkForallTy tyvars (foldr f (UniDict clas (verifyTauTy "mkDictFunType" tau_ty)) theta) +#endif + where + f (clas,tau_ty) sofar = UniFun (UniDict clas tau_ty) sofar +-} +\end{code} + +\begin{code} +specialiseTy :: UniType -- The type of the Id of which the SpecId + -- is a specialised version + -> [Maybe UniType] -- The types at which it is specialised + -> Int -- Number of leading dictionary args to ignore + -> UniType + +specialiseTy main_ty maybe_tys dicts_to_ignore + = --false:ASSERT(isTauTy tau) TauType?? + mkSigmaTy remaining_tyvars + (instantiateThetaTy inst_env remaining_theta) + (instantiateTauTy inst_env tau) + where + (tyvars, theta, tau) = splitType main_ty -- A prefix of, but usually all, + -- the theta is discarded! + remaining_theta = drop dicts_to_ignore theta + tyvars_and_maybe_tys = tyvars `zip` maybe_tys + remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys] + inst_env = [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys] +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-destruction]{Taking types apart} +%* * +%************************************************************************ + +@expandVisibleTySyn@ removes any visible type-synonym from the top level of a +@TauType@. Note that the expansion is recursive. + +@expandTySyns@ removes all type-synonyms from a @TauType@. + +\begin{code} +expandVisibleTySyn, expandTySyns :: TauType -> TauType + +expandVisibleTySyn (UniSyn con _ tau) + | isVisibleSynTyCon con + = ASSERT(isTauTy tau) + expandVisibleTySyn tau +expandVisibleTySyn tau + = ASSERT(isTauTy tau) + tau + +expandTySyns (UniSyn _ _ tau) = expandTySyns tau +expandTySyns (UniFun a b) = UniFun (expandTySyns a) (expandTySyns b) +expandTySyns (UniData c tys) = UniData c (map expandTySyns tys) +expandTySyns tau = -- FALSE:WDP 95/03: ASSERT(isTauTy tau) + tau +\end{code} + +@getTyVar@ extracts a type variable from a @UniType@ if the latter is +just a type variable, failing otherwise. @getTyVarMaybe@ is similar, +except that it returns a @Maybe@ type. + +\begin{code} +getTyVar :: String -> UniType -> TyVar +getTyVar panic_msg (UniTyVar tyvar) = tyvar +getTyVar panic_msg other = panic ("getTyVar: " ++ panic_msg) + +getTyVarMaybe :: UniType -> Maybe TyVar +getTyVarMaybe (UniTyVar tyvar) = Just tyvar +getTyVarMaybe (UniSyn _ _ exp) = getTyVarMaybe exp +getTyVarMaybe other = Nothing + +getTyVarTemplateMaybe :: UniType -> Maybe TyVarTemplate +getTyVarTemplateMaybe (UniTyVarTemplate tyvar) = Just tyvar +getTyVarTemplateMaybe (UniSyn _ _ exp) = getTyVarTemplateMaybe exp +getTyVarTemplateMaybe other = Nothing +\end{code} + +@splitType@ splits a type into three components. The first is the +bound type variables, the second is the context and the third is the +tau type. I'll produce specific functions which access particular pieces +of the type when we see where they are needed. + +\begin{code} +splitType :: UniType -> ([TyVarTemplate], ThetaType, TauType) +splitType uni_ty + = case (split_foralls uni_ty) of { (tyvars, rho_ty) -> + case (split_rho_ty rho_ty) of { (theta_ty, tau_ty) -> + --false:ASSERT(isTauTy tau_ty) TauType + (tyvars, theta_ty, tau_ty) + }} + where + split_foralls (UniForall tyvar uni_ty) + = case (split_foralls uni_ty) of { (tyvars,new_ty) -> + (tyvar:tyvars, new_ty) } + + split_foralls other_ty = ([], other_ty) + + split_rho_ty (UniFun (UniDict clas ty) ty_body) + = case (split_rho_ty ty_body) of { (context,ty_body') -> + ((clas, ty) :context, ty_body') } + + split_rho_ty other_ty = ([], other_ty) +\end{code} + +Sometimes we want the dictionaries counted as arguments. We guarantee +to return {\em some} arguments if there are any, but not necessarily +{\em all}. In particular, the ``result type'' might be a @UniDict@, +which might (in the case of a single-classop class) be a function. In +that case, we strongly avoid returning a @UniDict@ ``in the corner'' +(by @unDictify@ing that type, too). + +This seems like a bit of a fudge, frankly, but it does the job. + +\begin{code} +splitTypeWithDictsAsArgs + :: UniType -- input + -> ([TyVarTemplate], + [UniType], -- arg types + TauType) -- result type + +splitTypeWithDictsAsArgs ty + = case (splitType ty) of { (tvs, theta, tau_ty) -> + case (splitTyArgs tau_ty) of { (tau_arg_tys, res_ty) -> + let + result extra_arg_tys res_ty + = --false: ASSERT(isTauTy res_ty) TauType + (tvs, + [ mkDictTy c t | (c,t) <- theta ] ++ tau_arg_tys ++ extra_arg_tys, + res_ty) + in + if not (isDictTy res_ty) then + result [] res_ty + else + let + undicted_res_ty = unDictifyTy res_ty + (tau_arg_tys', res_ty') = splitTyArgs undicted_res_ty + in + if (null theta && null tau_arg_tys) + || isFunType undicted_res_ty then + + -- (a) The input ty was just a "dictionary" for a + -- single-method class with no super-dicts; the + -- "dictionary" is just the one method itself; we'd really + -- rather give info about that method... + + -- (b) The input ty gave back a "dictionary" for a + -- single-method class; if the method itself is a + -- function, then we'd jolly well better add its arguments + -- onto the whole "arg_tys" list. + + -- There may be excessive paranoia going on here (WDP). + + result tau_arg_tys' res_ty' + + else -- do nothing special... + result [] res_ty + }} +\end{code} + +@splitForalls@ is similar, but only splits off the forall'd type +variables. + +\begin{code} +splitForalls :: UniType -> ([TyVarTemplate], RhoType) + +splitForalls (UniForall tyvar ty) + = case (splitForalls ty) of + (tyvars, new_ty) -> (tyvar:tyvars, new_ty) +splitForalls (UniSyn _ _ ty) = splitForalls ty +splitForalls other_ty = ([], other_ty) +\end{code} + +And a terribly convenient way to access @splitType@: + +\begin{code} +getTauType :: UniType -> TauType +getTauType uni_ty + = case (splitType uni_ty) of { (_,_,tau_ty) -> + --false:ASSERT(isTauTy tau_ty) TauType??? (triggered in ProfMassage) + tau_ty } +\end{code} + +@splitTyArgs@ does the same for the arguments of a function type. + +\begin{code} +splitTyArgs :: TauType -> ([TauType], TauType) + +splitTyArgs ty + = --false: ASSERT(isTauTy ty) TauType??? + split ty + where + split (UniSyn _ _ expand) = split expand + + split (UniFun arg result) + = case (split result) of { (args, result') -> + (arg:args, result') } + + split ty = ([], ty) + +funResultTy :: RhoType -- Function type + -> Int -- Number of args to which applied + -> RhoType -- Result type + +funResultTy ty 0 = ty +funResultTy (UniSyn _ _ expand) n_args = funResultTy expand n_args +funResultTy ty@(UniDict _ _) n_args = funResultTy (unDictifyTy ty) n_args +funResultTy (UniFun _ result_ty) n_args = funResultTy result_ty (n_args - 1) +#ifdef DEBUG +funResultTy other_ty n_args = panic ("funResultTy:not a fun:"++(ppShow 80 (ppr PprDebug other_ty))) +#endif +\end{code} + +The type-destructor functions above return dictionary information in +terms of @UniDict@, a relatively abstract construct. What really +happens ``under the hood'' is that {\em tuples} (usually) are passed +around as ordinary arguments. Sometimes we want this ``what's really +happening'' information. + +The interesting case for @getUniDataTyCon_maybe@ is if the argument is +a dictionary type. Dictionaries are represented by tuples (except for +size-one dictionaries which are represented by the method itself), so +@getUniDataTyCon_maybe@ has to figure out which tuple. This is a bit +unsatisfactory; the information about how dictionaries are represented +is rather thinly distributed. + +@unDictify@ only removes a {\em top-level} @UniDict@. There may be +buried @UniDicts@ in what is returned. + +\begin{code} +unDictifyTy :: UniType -- Might be a UniDict + -> UniType -- Can't be a UniDict + +unDictifyTy (UniSyn _ _ expansion) = unDictifyTy expansion + +unDictifyTy (UniDict clas ty) + = ASSERT(dict_size >= 0) + if dict_size == 1 then + unDictifyTy (head all_arg_tys) -- just the itself + -- The extra unDictify is to make sure that + -- the result isn't still a dict, which it might be + -- if the original guy was a dict with one superdict and + -- no methods! + else + UniData (mkTupleTyCon dict_size) all_arg_tys -- a tuple of 'em + -- NB: dict_size can be 0 if the class is + -- _CCallable, _CReturnable (and anything else + -- *really weird* that the user writes). + where + (tyvar, super_classes, ops) = getClassSig clas + dict_size = length super_classes + length ops + + super_dict_tys = map mk_super_ty super_classes + class_op_tys = map mk_op_ty ops + + all_arg_tys = super_dict_tys ++ class_op_tys + + mk_super_ty sc = mkDictTy sc ty + mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op) + +unDictifyTy other_ty = other_ty +\end{code} + +\begin{code} +{- UNUSED: +sourceTypes :: TauType -> [TauType] +sourceTypes ty + = --false:ASSERT(isTauTy ty) + (fst . splitTyArgs) ty + +targetType :: TauType -> TauType +targetType ty + = --false: ASSERT(isTauTy ty) TauType?? + (snd . splitTyArgs) ty +-} +\end{code} + +Here is a function that tell you if a type has as its target a Synonym. +If so it returns the relevant constructor and its argument type. + +\begin{code} +{- UNUSED: +isSynTarget :: UniType -> Maybe (TyCon,Int) + +isSynTarget (UniFun _ arg) = case isSynTarget arg of + Just (tycon,x) -> Just (tycon,x + 1) + Nothing -> Nothing +isSynTarget (UniSyn tycon _ _) = Just (tycon,0) +isSynTarget (UniForall _ e) = isSynTarget e +isSynTarget _ = Nothing +--isSynTarget (UniTyVarTemplate e) = panic "isSynTarget: got a UniTyVarTemplate!" +-} +\end{code} + +\begin{code} +splitDictType :: UniType -> (Class, UniType) +splitDictType (UniDict clas ty) = (clas, ty) +splitDictType (UniSyn _ _ ty) = splitDictType ty +splitDictType other = panic "splitDictTy" +\end{code} + +In @kindFromType@ it can happen that we come across a @TyVarTemplate@, +for example when figuring out the kinds of the argument of a data +constructor; inside the @DataCon@ the argument types are in template form. + +\begin{code} +kindFromType :: UniType -> PrimKind +kindFromType (UniSyn tycon tys expand) = kindFromType expand +kindFromType (UniData tycon tys) = getTyConKind tycon (map kindFromType tys) +kindFromType other = PtrKind -- the "default" + +isPrimType :: UniType -> Bool + +isPrimType (UniSyn tycon tys expand) = isPrimType expand +#ifdef DPH +isPrimType (UniData tycon tys) | isPodizedPodTyCon tycon + = all isPrimType tys +#endif {- Data Parallel Haskell} +isPrimType (UniData tycon tys) = isPrimTyCon tycon +isPrimType other = False -- the "default" + +maybeBoxedPrimType :: UniType -> Maybe (Id{-DataCon-}, UniType) + +maybeBoxedPrimType ty + = case (getUniDataTyCon_maybe ty) of -- Data type, + Just (tycon, tys_applied, [data_con]) -- with exactly one constructor + -> case (getInstantiatedDataConSig data_con tys_applied) of + (_, [data_con_arg_ty], _) -- Applied to exactly one type, + | isPrimType data_con_arg_ty -- which is primitive + -> Just (data_con, data_con_arg_ty) + other_cases -> Nothing + other_cases -> Nothing +\end{code} + +At present there are no unboxed non-primitive types, so +isUnboxedDataType is the same as isPrimType. + +\begin{code} +isUnboxedDataType :: UniType -> Bool + +isUnboxedDataType (UniSyn _ _ expand) = isUnboxedDataType expand +isUnboxedDataType (UniData tycon _) = not (isBoxedTyCon tycon) +isUnboxedDataType other = False +\end{code} + +If you want to run @getUniDataTyCon...@ or @UniDataArgTys@ over a +dictionary-full type, then put the type through @unDictifyTy@ first. + +\begin{code} +getUniDataTyCon_maybe + :: TauType + -> Maybe (TyCon, -- the type constructor + [TauType], -- types to which it is applied + [Id]) -- its family of data-constructors + +getUniDataTyCon_maybe ty + = --false:ASSERT(isTauTy ty) TauType? + get ty + where + get (UniSyn _ _ expand) = get expand + get ty@(UniDict _ _) = get (unDictifyTy ty) + + get (UniData tycon arg_tys) + = Just (tycon, arg_tys, getTyConDataCons tycon) + -- does not returned specialised data constructors + + get other_ty = Nothing +\end{code} + +@getUniDataTyCon@ is just a version which fails noisily. +\begin{code} +getUniDataTyCon ty + = case getUniDataTyCon_maybe ty of + Just stuff -> stuff +#ifdef DEBUG + Nothing -> pprPanic "getUniDataTyCon:" (ppr PprShowAll ty) +#endif +\end{code} + +@getUniDataSpecTyCon_maybe@ returns an appropriate specialised tycon, +any remaining (boxed) type arguments, and specialsied constructors. +\begin{code} +getUniDataSpecTyCon_maybe + :: TauType + -> Maybe (TyCon, -- the type constructor + [TauType], -- types to which it is applied + [Id]) -- its family of data-constructors + +getUniDataSpecTyCon_maybe ty + = case getUniDataTyCon_maybe ty of + Nothing -> Nothing + Just unspec@(tycon, tycon_arg_tys, datacons) -> + let spec_tys = specialiseConstrTys tycon_arg_tys + spec_reqd = maybeToBool (firstJust spec_tys) + + data_cons = getTyConDataCons tycon + spec_datacons = map (mkSameSpecCon spec_tys) data_cons + spec_tycon = mkSpecTyCon tycon spec_tys + + tys_left = [ty | (spec, ty) <- spec_tys `zip` tycon_arg_tys, + not (maybeToBool spec) ] + in + if spec_reqd + then Just (spec_tycon, tys_left, spec_datacons) + else Just unspec +\end{code} + +@getUniDataSpecTyCon@ is just a version which fails noisily. +\begin{code} +getUniDataSpecTyCon ty + = case getUniDataSpecTyCon_maybe ty of + Just stuff -> stuff + Nothing -> panic ("getUniDataSpecTyCon:"++ (ppShow 80 (ppr PprShowAll ty))) +\end{code} + +@getMentionedTyCons@ maps a type constructor to a list of type +constructors. If the type constructor is built-in or a @data@ type +constructor, the list is empty. In the case of synonyms, list +contains all the type {\em synonym} constructors {\em directly} +mentioned in the definition of the synonym. +\begin{code} +getMentionedTyCons :: TyCon -> [TyCon] + +getMentionedTyCons (SynonymTyCon _ _ _ _ expansion _) = get_ty_cons expansion + where + get_ty_cons (UniTyVar _) = [] + get_ty_cons (UniTyVarTemplate _)= [] + get_ty_cons (UniData _ tys) = concat (map get_ty_cons tys) + get_ty_cons (UniFun ty1 ty2) = get_ty_cons ty1 ++ get_ty_cons ty2 + get_ty_cons (UniSyn tycon _ _) = [tycon] + get_ty_cons _ = panic "get_ty_cons: unexpected UniType" + +getMentionedTyCons other_tycon = [] +\end{code} + +Here's a similar thing used in the Semantique strictness analyser: +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +getReferredToTyCons :: TauType -> [TyCon] +getReferredToTyCons (UniTyVar v) = [] +getReferredToTyCons (UniTyVarTemplate v) = [] +getReferredToTyCons (UniData t ts) = t : concat (map getReferredToTyCons ts) +getReferredToTyCons (UniFun s t) = getReferredToTyCons s ++ getReferredToTyCons t +getReferredToTyCons (UniSyn _ _ t) = getReferredToTyCons (getTauType t) +getReferredToTyCons other = panic "getReferredToTyCons: not TauType" +#endif {- Semantique strictness analyser -} +\end{code} + +This @getMentioned*@ code is for doing interfaces. Tricky point: we +{\em always} expand synonyms in interfaces, so note the handling of +@UniSyns@. +\begin{code} +getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class) + +getMentionedTyConsAndClassesFromUniType (UniTyVar _) = (emptyBag, emptyBag) +getMentionedTyConsAndClassesFromUniType (UniTyVarTemplate _) = (emptyBag, emptyBag) + +getMentionedTyConsAndClassesFromUniType (UniData tycon arg_tys) + = foldr do_arg_ty (unitBag tycon, emptyBag) arg_tys + where + do_arg_ty ty (ts_sofar, cs_sofar) + = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) -> + (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) } + +getMentionedTyConsAndClassesFromUniType (UniFun ty1 ty2) + = case (getMentionedTyConsAndClassesFromUniType ty1) of { (ts1, cs1) -> + case (getMentionedTyConsAndClassesFromUniType ty2) of { (ts2, cs2) -> + (ts1 `unionBags` ts2, cs1 `unionBags` cs2) }} + +getMentionedTyConsAndClassesFromUniType (UniSyn tycon _ expansion) + = getMentionedTyConsAndClassesFromUniType expansion + -- if synonyms were not expanded: (unitBag tycon, emptyBag) + +getMentionedTyConsAndClassesFromUniType (UniDict clas ty) + = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) -> + (ts, cs `snocBag` clas) } + +getMentionedTyConsAndClassesFromUniType (UniForall _ ty) + = getMentionedTyConsAndClassesFromUniType ty +\end{code} + +This code could go in @TyCon@, but it's better to keep all the +``getMentioning'' together. +\begin{code} +getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class) + +getMentionedTyConsAndClassesFromTyCon tycon@(SynonymTyCon _ _ _ _ ty _) + = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) -> + (ts `snocBag` tycon, cs) } + +getMentionedTyConsAndClassesFromTyCon tycon@(DataTyCon _ _ _ _ constructors _ _) + = foldr do_con (unitBag tycon, emptyBag) constructors + -- We don't worry whether this TyCon is exported abstractly + -- or not, because even if so, the pragmas probably need + -- to know this info. + where + do_con con (ts_sofar, cs_sofar) + = case (getMentionedTyConsAndClassesFromId con) of { (ts, cs) -> + (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) } + +getMentionedTyConsAndClassesFromTyCon other + = panic "tried to get mentioned tycons and classes from funny tycon" +\end{code} + +\begin{code} +getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class) + +getMentionedTyConsAndClassesFromClass clas@(MkClass _ _ _ super_classes _ ops _ _ _ _) + = foldr do_op + (emptyBag, unitBag clas `unionBags` listToBag super_classes) + ops + where + do_op (MkClassOp _ _ ty) (ts_sofar, cs_sofar) + = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) -> + (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) } +\end{code} + +Grab a name for the type. This is used to determine the type +description for profiling. +\begin{code} +getUniTyDescription :: UniType -> String +getUniTyDescription ty + = case (getTauType ty) of + UniFun arg res -> '-' : '>' : fun_result res + UniData tycon _ -> _UNPK_ (getOccurrenceName tycon) + UniSyn tycon _ _ -> _UNPK_ (getOccurrenceName tycon) + UniDict cls uni -> "dict" -- Or from unitype ? + UniTyVar _ -> "*" -- Distinguish ? + UniTyVarTemplate _-> "*" + _ -> panic "getUniTyName: other" + + where + fun_result (UniFun _ res) = '>' : fun_result res + fun_result other = getUniTyDescription other + +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-fvs]{Extracting free type variables} +%* * +%************************************************************************ + +@extractTyVarsFromTy@ gets the free type variables from a @UniType@. +The list returned has no duplicates. + +\begin{code} +extractTyVarsFromTys :: [UniType] -> [TyVar] +extractTyVarsFromTys = foldr (unionLists . extractTyVarsFromTy) [] + +extractTyVarsFromTy :: UniType -> [TyVar] +extractTyVarsFromTy ty + = get ty [] + where + -- weird arg order so we can foldr easily + get (UniTyVar tyvar) free + | tyvar `is_elem` free = free + | otherwise = tyvar:free + get (UniTyVarTemplate _) free = free + get (UniFun ty1 ty2) free = get ty1 (get ty2 free) + get (UniData tycon tys) free = foldr get free tys + get (UniSyn tycon tys ty) free = foldr get free tys + get (UniDict clas ty) free = get ty free + get (UniForall tyvar ty) free = get ty free + + is_elem = isIn "extractTyVarsFromTy" +\end{code} + +\begin{code} +extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate] +extractTyVarTemplatesFromTy ty + = get ty [] + where + get (UniTyVarTemplate tyvar) free + | tyvar `is_elem` free = free + | otherwise = tyvar:free + get (UniTyVar tyvar) free = free + get (UniFun ty1 ty2) free = get ty1 (get ty2 free) + get (UniData tycon tys) free = foldr get free tys + get (UniSyn tycon tys ty) free = foldr get free tys + get (UniDict clas ty) free = get ty free + get (UniForall tyvar ty) free = get ty free + + is_elem = isIn "extractTyVarTemplatesFromTy" +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-predicates]{Predicates (and such) on @UniTypes@} +%* * +%************************************************************************ + +We include functions that return @Maybe@ thingies as ``predicates.'' + +\begin{code} +isTyVarTy :: UniType -> Bool +isTyVarTy (UniTyVar _) = True +isTyVarTy (UniSyn _ _ expand) = isTyVarTy expand +isTyVarTy other = False + +-- isTyVarTemplateTy only used in Renamer for error checking +isTyVarTemplateTy :: UniType -> Bool +isTyVarTemplateTy (UniTyVarTemplate tv) = True +isTyVarTemplateTy (UniSyn _ _ expand) = isTyVarTemplateTy expand +isTyVarTemplateTy other = False + +maybeUnpackFunTy :: TauType -> Maybe (TauType, TauType) + +maybeUnpackFunTy ty + = --false: ASSERT(isTauTy ty) TauType?? + maybe ty + where + maybe (UniSyn _ _ expand) = maybe expand + maybe (UniFun arg result) = Just (arg, result) + maybe ty@(UniDict _ _) = maybe (unDictifyTy ty) + maybe other = Nothing + +isFunType :: TauType -> Bool +isFunType ty + = --false: ASSERT(isTauTy ty) TauType??? + maybeToBool (maybeUnpackFunTy ty) +\end{code} + +\begin{code} +{- UNUSED: +isDataConType :: TauType -> Bool + +isDataConType ty + = ASSERT(isTauTy ty) + is_con_ty ty + where + is_con_ty (UniData _ _) = True + is_con_ty (UniSyn _ _ expand) = is_con_ty expand + is_con_ty _ = False +-} +\end{code} + +SIMON'S NOTES: + +leakFree (UniData (DataTyCon ...) tys) + = nonrecursive type && + all leakFree (apply constructors to tys) + +leakFree (PrimTyCon...) = True + +leakFree (TyVar _) = False +leakFree (UniFun _ _) = False + +non-recursive: enumeration types, tuples, primitive types... + +END NOTES + +The list of @TyCons@ is ones we have already seen (and mustn't see +again). + +\begin{code} +isLeakFreeType :: [TyCon] -> UniType -> Bool + +isLeakFreeType seen (UniSyn _ _ expand) = isLeakFreeType seen expand + +isLeakFreeType _ (UniTyVar _) = False -- Utterly unknown +isLeakFreeType _ (UniTyVarTemplate _) = False + +isLeakFreeType _ (UniFun _ _) = False -- Could have leaky free variables + +isLeakFreeType _ ty@(UniDict _ _) = True -- I'm prepared to bet that + -- we'll never get a space leak + -- from a dictionary. But I could + -- be wrong... SLPJ + +isLeakFreeType seen (UniForall _ ty) = isLeakFreeType seen ty + +-- For a data type we must look at all the argument types of all +-- the constructors. It isn't enough to look merely at the +-- types to which the type constructor is applied. For example +-- +-- data Foo a = MkFoo [a] +-- +-- Is (Foo Int) leak free? No! + +isLeakFreeType seen (UniData tycon tycon_arg_tys) + | tycon `is_elem` seen = False -- Recursive type! Bale out! + + | isDataTyCon tycon = all data_con_args_leak_free (getTyConDataCons tycon) + + | otherwise = isPrimTyCon tycon && -- was an assert; now just paranoia + -- We should have a leak-free-ness predicate on PrimTyCons, + -- but that's too big a change for today, so we hack it. + -- Return true iff it's one of the tycons we know are leak-free + -- 94/10: I hope I don't live to regret taking out + -- the first check... + {-(tycon `elem` [ + charPrimTyCon, intPrimTyCon, wordPrimTyCon, + addrPrimTyCon, floatPrimTyCon, doublePrimTyCon, + byteArrayPrimTyCon, arrayPrimTyCon, + mallocPtrPrimTyCon, stablePtrPrimTyCon + -- List almost surely incomplete! + ]) + &&-} (all (isLeakFreeType (tycon:seen)) tycon_arg_tys) + where + data_con_args_leak_free data_con + = case (getInstantiatedDataConSig data_con tycon_arg_tys) of { (_,arg_tys,_) -> + all (isLeakFreeType (tycon:seen)) arg_tys } + + is_elem = isIn "isLeakFreeType" +\end{code} + +\begin{code} +{- UNUSED: +hasHigherOrderArg :: UniType -> Bool +hasHigherOrderArg ty + = case (splitType ty) of { (_, _, tau_ty) -> + case (splitTyArgs tau_ty) of { (arg_tys, _) -> + + foldr ((||) . isFunType . expandTySyns) False arg_tys + }} +-} +\end{code} + +\begin{code} +isDictTy :: UniType -> Bool + +isDictTy (UniDict _ _) = True +isDictTy (UniSyn _ _ expand) = isDictTy expand +isDictTy _ = False + +isTauTy :: UniType -> Bool + +isTauTy (UniTyVar v) = True +isTauTy (UniFun a b) = isTauTy a && isTauTy b +isTauTy (UniData _ tys) = all isTauTy tys +isTauTy (UniSyn _ _ ty) = isTauTy ty +isTauTy (UniDict _ ty) = False +isTauTy (UniTyVarTemplate _) = False +isTauTy (UniForall _ _) = False + +isForAllTy :: UniType -> Bool +isForAllTy (UniForall _ _) = True +isForAllTy (UniSyn _ _ ty) = isForAllTy ty +isForAllTy _ = False +\end{code} + +NOTE: I haven't thought about this much (ToDo: check). +\begin{code} +isGroundOrTyVarTy, isGroundTy :: UniType -> Bool + +isGroundOrTyVarTy ty = isGroundTy ty || isTyVarTy ty + +isGroundTy (UniTyVar tyvar) = False +isGroundTy (UniTyVarTemplate _) = False +isGroundTy (UniFun ty1 ty2) = isGroundTy ty1 && isGroundTy ty2 +isGroundTy (UniData tycon tys) = all isGroundTy tys +isGroundTy (UniSyn _ _ exp) = isGroundTy exp +isGroundTy (UniDict clas ty) = isGroundTy ty +isGroundTy (UniForall tyvar ty) = False -- Safe for the moment +\end{code} + +Broadly speaking, instances are exported (a)~if {\em either} the class +or {\em OUTERMOST} tycon [arbitrary...] is exported; or (b)~{\em both} +class and tycon are from PreludeCore [non-std, but convenient] {\em +and} the instance was defined in this module. BUT: if either the +class or tycon was defined in this module, but not exported, then +there is no point exporting the instance. + +\begin{code} +instanceIsExported + :: Class -> TauType -- class/"tycon" defining instance + -> Bool -- True <=> instance decl in this module + -> Bool + +instanceIsExported clas ty from_here + = --false:ASSERT(isTauTy ty) TauType?? failed compiling IArray + if is_core_class then + if is_fun_tycon || is_core_tycon then + {-if-} from_here + else + is_exported_tycon + || (is_imported_tycon && from_here) -- V NAUGHTY BY HASKELL RULES + + else if is_fun_tycon || is_core_tycon then + -- non-Core class; depends on its export flag + is_exported_class + || (is_imported_class && from_here) -- V NAUGHTY BY HASKELL RULES + + else -- non-Core class & non-Core tycon: + -- exported if one of them is, but not if either of them + -- is locally-defined *and* not exported + if (isLocallyDefined clas && not is_exported_class) + || (isLocallyDefined tycon && not is_exported_tycon) then + False + else + is_exported_class || is_exported_tycon + where + tycon = case getUniDataTyCon_maybe ty of + Just (xx,_,_) -> xx + Nothing -> panic "instanceIsExported:no tycon" + + is_core_class = fromPreludeCore clas + is_core_tycon = fromPreludeCore tycon + + is_fun_tycon = isFunType ty + + is_exported_class = case (getExportFlag clas) of + NotExported -> False + _ -> True + + is_exported_tycon = case (getExportFlag tycon) of + NotExported -> False + _ -> True + + is_imported_class = not (isLocallyDefined clas) + is_imported_tycon = not (isLocallyDefined tycon) +\end{code} + +\begin{code} +maybePurelyLocalTyCon :: TyCon -> Maybe [Pretty] +maybePurelyLocalClass :: Class -> Maybe [Pretty] +maybePurelyLocalType :: UniType -> Maybe [Pretty] + +purely_local tc -- overloaded + = if (isLocallyDefined tc && not (isExported tc)) + then Just (ppr PprForUser tc) + else Nothing + +--overloaded: merge_maybes :: (a -> Maybe b) -> [a] -> Maybe [b] + +merge_maybes f xs + = case (catMaybes (map f xs)) of + [] -> Nothing -- no hit anywhere along the list + xs -> Just xs + +maybePurelyLocalTyCon tycon + = let + mentioned_tycons = fst (getMentionedTyConsAndClassesFromTyCon tycon) + -- will include tycon itself + in + merge_maybes purely_local (bagToList mentioned_tycons) + +maybePurelyLocalClass clas + = let + (mentioned_classes, mentioned_tycons) + = getMentionedTyConsAndClassesFromClass clas + -- will include clas itself + + tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons) + cl_stuff = merge_maybes purely_local (bagToList mentioned_classes) + in + case (tc_stuff, cl_stuff) of + (Nothing, Nothing) -> Nothing + (Nothing, Just xs) -> Just xs + (Just xs, Nothing) -> Just xs + (Just xs, Just ys) -> Just (xs ++ ys) + +maybePurelyLocalType ty + = let + (mentioned_classes, mentioned_tycons) + = getMentionedTyConsAndClassesFromUniType ty + -- will include ty itself + + tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons) + cl_stuff = merge_maybes purely_local (bagToList mentioned_classes) + in + case (tc_stuff, cl_stuff) of + (Nothing, Nothing) -> Nothing + (Nothing, Just xs) -> Just xs + (Just xs, Nothing) -> Just xs + (Just xs, Just ys) -> Just (xs ++ ys) +\end{code} + +A gigantic HACK due to Simon (95/05) +\begin{code} +returnsRealWorld :: UniType -> Bool + +returnsRealWorld (UniTyVar _) = False +returnsRealWorld (UniTyVarTemplate _) = False +returnsRealWorld (UniSyn _ _ exp) = returnsRealWorld exp +returnsRealWorld (UniDict _ ty) = returnsRealWorld ty +returnsRealWorld (UniForall _ ty) = returnsRealWorld ty +returnsRealWorld (UniFun ty1 ty2) = returnsRealWorld ty2 + +returnsRealWorld (UniData tycon []) = tycon == realWorldTyCon +returnsRealWorld (UniData tycon tys) = any returnsRealWorld tys +\end{code} + +\begin{code} +#ifdef DPH +isProcessorTy :: UniType -> Bool +isProcessorTy (UniData tycon _) = isProcessorTyCon tycon +isProcessorTy _ = False +#endif {- Data Parallel Haskell -} +\end{code} + +Podization of a function @f@ is the compile time specialisation of @f@ +to a form that is equivalent to (map.f) . We can podize {\em some} +functions at runtime because of the laws concerning map and functional +composition: +\begin{verbatim} + map (f . g) == (map f) . (map g) etc... +\end{verbatim} +i.e If we compose two functions, to create a {\em new} function, then +we can compose the podized versions in just the same way. There is a +problem however (as always :-(; We cannot convert between an vanilla +function, and the podized form (and visa versa) at run-time. The +predicate below describes the set of all objects that cannot be +podized at runtime (i.e anything that has a function in it). +\begin{code} +#ifdef DPH +runtimeUnpodizableType:: UniType -> Bool +runtimeUnpodizableType (UniDict _ _) = True +runtimeUnpodizableType (UniFun _ _) = True +runtimeUnpodizableType (UniData _ tys) = any runtimeUnpodizableType tys +runtimeUnpodizableType (UniSyn _ _ ty) = runtimeUnpodizableType ty +runtimeUnpodizableType other = False +#endif {- Data Parallel Haskell -} +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-subst]{Substitute in a type} +%* * +%************************************************************************ + +The idea here is to substitute for the TyVars in a type. Note, not +the TyVarTemplates---that's the job of instantiateTy. + +There is a single general function, and two interfaces. + +\subsubsection{Interface 1: substitutions} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +NOTE: This has been moved to @Subst@ (mostly for speed reasons). + +\subsubsection{Interface 2: Envs} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +\begin{code} +applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType +applyTypeEnvToTy tenv ty + = mapOverTyVars v_fn ty + where + v_fn v = case (lookupTyVarEnv tenv v) of + Just ty -> ty + Nothing -> UniTyVar v + +applyTypeEnvToTauTy :: TypeEnv -> TauType -> TauType +applyTypeEnvToTauTy e ty + = ASSERT(isTauTy ty) + applyTypeEnvToTy e ty + +applyTypeEnvToThetaTy tenv theta + = [(clas, + ASSERT(isTauTy ty) + applyTypeEnvToTauTy tenv ty) | (clas, ty) <- theta] +\end{code} + +\subsubsection{@mapOverTyVars@: does the real work} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +@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 -> UniType) -> UniType -> UniType +mapOverTyVars v_fn (UniTyVar v) = v_fn v +mapOverTyVars v_fn (UniFun t1 t2) = UniFun (mapOverTyVars v_fn t1) (mapOverTyVars v_fn t2) +mapOverTyVars v_fn (UniData con args) = UniData con (map (mapOverTyVars v_fn) args) +mapOverTyVars v_fn (UniSyn con args ty) = UniSyn con (map (mapOverTyVars v_fn) args) (mapOverTyVars v_fn ty) +mapOverTyVars v_fn (UniDict clas ty) = UniDict clas (mapOverTyVars v_fn ty) +mapOverTyVars v_fn (UniForall v ty) = UniForall v (mapOverTyVars v_fn ty) +mapOverTyVars v_fn (UniTyVarTemplate v) = UniTyVarTemplate v +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-ppr]{Pretty-printing @UniTypes@} +%* * +%************************************************************************ + +@pprUniType@ is the std @UniType@ printer; the overloaded @ppr@ +function is defined to use this. @pprParendUniType@ is the same, +except it puts parens around the type, except for the atomic cases. +@pprParendUniType@ works just by setting the initial context +precedence very high. ToDo: what if not a @TauType@? +\begin{code} +pprUniType, pprParendUniType :: PprStyle -> UniType -> Pretty + +pprUniType sty ty = ppr_ty_init sty tOP_PREC ty +pprParendUniType sty ty = ppr_ty_init sty tYCON_PREC ty + +pprMaybeTy :: PprStyle -> Maybe UniType -> Pretty +pprMaybeTy PprDebug Nothing = ppStr "*" +pprMaybeTy PprDebug (Just ty) = pprParendUniType PprDebug ty + +getTypeString :: UniType -> [FAST_STRING] + -- shallowly magical; converts a type into something + -- vaguely close to what can be used in C identifier. + -- Don't forget to include the module name!!! + +getTypeString ty + = let + ppr_t = ppr_ty PprForUser (\t -> ppStr "*") tOP_PREC (expandTySyns ty) + + string = _PK_ (tidy (ppShow 1000 ppr_t)) + in + if is_prelude_ty + then [string] + else [mod, string] + where + (is_prelude_ty, mod) + = case getUniDataTyCon_maybe ty of + Nothing -> true_bottom + Just (tycon,_,_) -> + if fromPreludeCore tycon + then true_bottom + else (False, fst (getOrigName tycon)) + + true_bottom = (True, panic "getTypeString") + + -------------------------------------------------- + -- tidy: very ad-hoc + tidy [] = [] -- done + + tidy (' ' : more) + = case more of + ' ' : _ -> tidy more + '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs) + other -> ' ' : tidy more + + tidy (',' : more) = ',' : tidy (no_leading_sps more) + + tidy (x : xs) = x : tidy xs -- catch all + + no_leading_sps [] = [] + no_leading_sps (' ':xs) = no_leading_sps xs + no_leading_sps other = other + +typeMaybeString :: Maybe UniType -> [FAST_STRING] +typeMaybeString Nothing = [SLIT("!")] +typeMaybeString (Just t) = getTypeString t + +specMaybeTysSuffix :: [Maybe UniType] -> FAST_STRING +specMaybeTysSuffix ty_maybes + = let + ty_strs = concat (map typeMaybeString ty_maybes) + dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] + in + _CONCAT_ dotted_tys +\end{code} + +Nota Bene: we must assign print-names to the forall'd type variables +alphabetically, with the first forall'd variable having the alphabetically +first name. Reason: so anyone reading the type signature printed without +explicit forall's will be able to reconstruct them in the right order. + +\begin{code} +ppr_ty_init :: PprStyle -> Int -> UniType -> Pretty + +ppr_ty_init sty init_prec ty + = let (tyvars, _, _) = splitType ty + lookup_fn = mk_lookup_tyvar_fn sty tyvars + in + ppr_ty sty lookup_fn init_prec ty + +mk_lookup_tyvar_fn :: PprStyle -> [TyVarTemplate] -> (TyVarTemplate -> Pretty) + +mk_lookup_tyvar_fn sty tyvars + = tv_lookup_fn + where + tv_lookup_fn :: TyVarTemplate -> Pretty + tv_lookup_fn tyvar + = let + pp_tyvar_styish = ppr sty tyvar + + assocs = [ pp | (tv, pp) <- tvs_n_pprs, tv == tyvar ] + + pp_tyvar_canonical + = case assocs of + [] -> pprPanic "pprUniType: bad tyvar lookup:" (ppr sty tyvar) + -- sometimes, in printing monomorphic types, + -- (usually in debugging), we won't have the tyvar + -- in our list; so we just ppr it anyway... + x:_ -> x + in + case sty of + PprInterface _ -> pp_tyvar_canonical + PprForC _ -> ppChar '*' + PprUnfolding _ -> case assocs of + x:_ -> ppBeside x (ppPStr SLIT("$z1")) + _ -> ppPStr SLIT("z$z1") + PprForUser -> case assocs of + x:_ -> x + _ -> pp_tyvar_styish + debuggish -> pp_tyvar_styish + + tvs_n_pprs = tyvars `zip` tyvar_pretties + + tyvar_pretties = letter_pprs {- a..y -} ++ number_pprs {- z0 ... zN -} + + letter_pprs = map (\ c -> ppChar c ) ['a' .. 'y'] + number_pprs = map (\ n -> ppBeside (ppChar 'z') (ppInt n)) + ([0 .. ] :: [Int]) +\end{code} + +\begin{code} +ppr_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty + +ppr_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar + +ppr_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar + +ppr_ty sty lookup_fn ctxt_prec ty + = case sty of + PprForUser -> context_onward + PprInterface _ -> context_onward + _ -> + (if null tyvars then id else ppBeside (ppr_forall sty tyvars)) + context_onward + where + (tyvars, context, tau_ty) = splitType ty + + context_onward = + if (null pretty_context_pieces) then + ppr_tau_ty sty lookup_fn ctxt_prec tau_ty + else + ppCat (pretty_context_pieces + ++ [connector sty, ppr_tau_ty sty lookup_fn ctxt_prec tau_ty]) -- ToDo: dubious + + pretty_context_pieces = ppr_context sty context + + ppr_forall :: PprStyle -> [TyVarTemplate] -> Pretty + + ppr_forall _ [] = ppNil + ppr_forall sty tyvars + = ppBesides [ppPStr SLIT("_forall_ "), ppIntersperse pp'SP{-'-} pp_tyvars, + ppPStr SLIT(" =>")] + where + pp_tyvars = map lookup_fn tyvars + + ppr_context :: PprStyle -> [(Class, UniType)] -> [Pretty] + + ppr_context _ [] = [] + ppr_context sty context@(c:cs) + = case sty of + PprForUser -> userish + PprInterface _ -> userish + _ -> hackerish + where + userish + = [if (context `lengthExceeds` (1::Int)) then + ppBesides [ ppLparen, + ppIntersperse pp'SP{-'-} (map (ppr_kappa_tau PprForUser) context), + ppRparen] + else + ppr_kappa_tau PprForUser (head context) + ] + hackerish + = (ppr_kappa_tau sty c) : (map ( pin_on_arrow . (ppr_kappa_tau sty) ) cs) + + connector PprForUser = ppPStr SLIT("=>") + connector (PprInterface _) = ppPStr SLIT("=>") + connector other_sty = ppPStr SLIT("->") + + ppr_kappa_tau :: PprStyle -> (Class, UniType) -> Pretty + + ppr_kappa_tau sty (clas, ty) + = let + pp_ty = ppr_tau_ty sty lookup_fn ctxt_prec ty + user_ish = ppCat [ppr PprForUser clas, pp_ty] + hack_ish = ppBesides [ppStr "{{", ppr sty clas, ppSP, pp_ty, ppStr "}}"] + in + case sty of + PprForUser -> user_ish + PprInterface _ -> user_ish + _ -> hack_ish + + pin_on_arrow p = ppBeside (ppPStr SLIT("-> ")) p +\end{code} + +@ppr_tau_ty@ takes an @Int@ that is the precedence of the context. +The precedence levels are: +\begin{description} +\item[0:] What we start with. +\item[1:] Function application (@UniFuns@). +\item[2:] Type constructors. +\end{description} + +A non-exported help function that really does the printing: +\begin{code} +tOP_PREC = (0 :: Int) +fUN_PREC = (1 :: Int) +tYCON_PREC = (2 :: Int) + +ppr_tau_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty + +-- a quite special case, for printing instance decls in interfaces: +ppr_tau_ty sty@(PprInterface _) lookup_fn ctxt_prec (UniDict clas ty) + = ppCat [ppr PprForUser clas, ppr_ty sty lookup_fn tYCON_PREC ty] + +ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn _ _ expansion) + | case sty of { PprForUser -> False; _ -> True } + = ppr_tau_ty sty lookup_fn ctxt_prec expansion -- always expand types in an interface + +-- ..................... + +ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar + +ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar + +ppr_tau_ty sty lookup_fn ctxt_prec (UniFun ty1 ty2) + -- we fiddle the precedences passed to left/right branches, + -- so that right associativity comes out nicely... + + = let p1 = ppr_tau_ty sty lookup_fn fUN_PREC ty1 + p2 = ppr_tau_ty sty lookup_fn tOP_PREC ty2 + in + if ctxt_prec < fUN_PREC then -- no parens needed + ppCat [p1, ppBeside (ppPStr SLIT("-> ")) p2] + else + ppCat [ppBeside ppLparen p1, ppBesides [ppPStr SLIT("-> "), p2, ppRparen]] + +-- Special printing for list and tuple types. +-- we can re-set the precedence to tOP_PREC + +ppr_tau_ty sty lookup_fn ctxt_prec (UniData tycon tys) + = if tycon == listTyCon then + ppBesides [ppLbrack, ppr_tau_ty sty lookup_fn tOP_PREC (head tys), ppRbrack] + + else if (tycon == (TupleTyCon (length tys))) then + ppBesides [ppLparen, ppIntersperse pp'SP{-'-} (map (ppr_tau_ty sty lookup_fn tOP_PREC) tys), ppRparen] +#ifdef DPH + else if (tycon == podTyCon) then + pprPodshort sty lookup_fn tOP_PREC (head tys) + + else if (tycon == (ProcessorTyCon ((length tys)-1))) then + ppBesides [ppStr "(|", + ppIntersperse pp'SP{-'-} + (map (ppr_tau_ty sty lookup_fn tOP_PREC) (init tys)), + ppSemi , + ppr_tau_ty sty lookup_fn tOP_PREC (last tys), + ppStr "|)"] +#endif {- Data Parallel Haskell -} + else + ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys + +ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn tycon tys expansion) + = ppBeside + (ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys) + (ifPprShowAll sty (ppCat [ppStr " {- expansion:", ppr_ty sty lookup_fn ctxt_prec expansion, ppStr "-}"])) + +-- For SPECIALIZE instance error messages ... +ppr_tau_ty sty@PprForUser lookup_fn ctxt_prec (UniDict clas ty) + = if ctxt_prec < tYCON_PREC then + ppCat [ppr sty clas, ppr_ty sty lookup_fn tYCON_PREC ty] + else + ppBesides [ppStr "(", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr ")"] + +ppr_tau_ty sty lookup_fn ctxt_prec (UniDict clas ty) + = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr "}}"] + +ppr_tau_ty sty lookup_fn ctxt_prec other_ty -- must a be UniForall (ToDo: something?) + = ppBesides [ppLparen, ppr_ty sty lookup_fn ctxt_prec other_ty, ppRparen] + +-- code shared for UniDatas and UniSyns +ppr_tycon_and_tys :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> TyCon -> [UniType] -> Pretty + +ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys + = let pp_tycon = ppr (case sty of PprInterface _ -> PprForUser; _ -> sty) tycon + in + if null tys then + pp_tycon + else if ctxt_prec < tYCON_PREC then -- no parens needed + ppCat [pp_tycon, ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys) ] + else + ppBesides [ ppLparen, pp_tycon, ppSP, + ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys), ppRparen ] +\end{code} + +\begin{code} +#ifdef DPH +pprPodshort :: PprStyle -> (TyVarTemplate-> Pretty) -> Int -> UniType -> Pretty +pprPodshort sty lookup_fn ctxt_prec (UniData tycon tys) + | (tycon == (ProcessorTyCon ((length tys)-1))) + = ppBesides [ppStr "<<", + ppIntersperse pp'SP{-'-} + (map (ppr_tau_ty sty lookup_fn tOP_PREC) (init tys)), + ppSemi , + ppr_tau_ty sty lookup_fn tOP_PREC (last tys), + ppStr ">>"] +pprPodshort sty lookup_fn ctxt_prec ty + = ppBesides [ppStr "<<", + ppr_tau_ty sty lookup_fn tOP_PREC ty, + ppStr ">>"] +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +showTyCon :: PprStyle -> TyCon -> String +showTyCon sty tycon + = ppShow 80 (pprTyCon sty tycon []) + +pprTyCon :: PprStyle -> TyCon -> [[Maybe UniType]] -> Pretty +-- with "PprInterface", we print out for interfaces + +pprTyCon sty@(PprInterface sw_chkr) (SynonymTyCon k n a vs exp unabstract) specs + = ASSERT (null specs) + let + lookup_fn = mk_lookup_tyvar_fn sty vs + pp_tyvars = map lookup_fn vs + pp_abstract = if unabstract || (sw_chkr OmitInterfacePragmas) + then ppNil + else ppStr "{-# GHC_PRAGMA _ABSTRACT_ #-}" + in + ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars, + ppEquals, ppr_ty sty lookup_fn tOP_PREC exp, pp_abstract] + +pprTyCon sty@(PprInterface sw_chkr) this_tycon@(DataTyCon k n a vs cons derivings unabstract) specs + = ppHang (ppCat [ppPStr SLIT("data"), + -- pprContext sty context, + ppr sty n, + ppIntersperse ppSP (map lookup_fn vs)]) + 4 + (ppCat [pp_unabstract_condecls, + pp_pragma]) + -- NB: we do not print deriving info in interfaces + where + lookup_fn = mk_lookup_tyvar_fn sty vs + + yes_we_print_condecls + = unabstract + && not (null cons) -- we know what they are + && (case (getExportFlag n) of + ExportAbs -> False + other -> True) + + yes_we_print_pragma_condecls + = not yes_we_print_condecls + && not (sw_chkr OmitInterfacePragmas) + && not (null cons) + && not (maybeToBool (maybePurelyLocalTyCon this_tycon)) + {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -} + + yes_we_print_pragma_specs + = not (null specs) + + pp_unabstract_condecls + = if yes_we_print_condecls + then ppCat [ppSP, ppEquals, pp_condecls] + else ppNil + + pp_pragma_condecls + = if yes_we_print_pragma_condecls + then pp_condecls + else ppNil + + pp_pragma_specs + = if yes_we_print_pragma_specs + then pp_specs + else ppNil + + pp_pragma + = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs) + then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"] + else ppNil + + pp_condecls + = let + (c:cs) = cons + in + ppCat ((ppr_con c) : (map ppr_next_con cs)) + where + ppr_con con + = let + (_, _, con_arg_tys, _) = getDataConSig con + in + ppCat [pprNonOp PprForUser con, -- the data con's name... + ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)] + + ppr_next_con con = ppCat [ppChar '|', ppr_con con] + + pp_specs + = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [ + ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack] + | ty_maybes <- specs ]] + + pp_the_list [p] = p + pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps) + + pp_maybe Nothing = pp_NONE + pp_maybe (Just ty) = pprParendUniType sty ty + + pp_NONE = ppStr "_N_" + +pprTyCon (PprInterface _) (TupleTyCon a) specs + = ASSERT (null specs) + ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ] + +pprTyCon (PprInterface _) (PrimTyCon k n a kind_fn) specs + = ASSERT (null specs) + ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ] + +#ifdef DPH +pprTyCon (PprInterface _) (ProcessorTyCon a) specs + = ppCat [ ppStr "{- Processor", ppInt a, ppStr "-}" ] +#endif {- Data Parallel Haskell -} + +-- regular printing (ToDo: probably update) + +pprTyCon sty (SynonymTyCon k n a vs exp unabstract) [{-no specs-}] + = ppBeside (ppr sty n) + (ifPprShowAll sty + (ppCat [ ppStr " {-", ppInt a, interpp'SP sty vs, + pprParendUniType sty exp, + if unabstract then ppNil else ppStr "_ABSTRACT_", ppStr "-}"])) + +pprTyCon sty tycon@(DataTyCon k n a vs cons derivings unabstract) [{-no specs-}] + = case sty of + PprDebug -> pp_tycon_and_uniq + PprShowAll -> pp_tycon_and_uniq + _ -> pp_tycon + where + pp_tycon_and_uniq = ppBesides [pp_tycon, ppStr "{-", pprUnique k, ppStr "-}"] + pp_tycon + = let + pp_name = ppr sty n + in + if codeStyle sty || tycon /= listTyCon + then pp_name + else ppBesides [ppLbrack, interpp'SP sty vs, ppRbrack] + +{-ppBeside-} -- pp_tycon +{- SOMETIMES: + (ifPprShowAll sty + (ppCat [ ppStr " {-", ppInt a, interppSP sty vs, + interpp'SP PprForUser cons, + ppStr "deriving (", interpp'SP PprForUser derivings, + ppStr ")-}" ])) +-} + +pprTyCon sty (TupleTyCon a) [{-no specs-}] + = ppBeside (ppPStr SLIT("Tuple")) (ppInt a) + +pprTyCon sty (PrimTyCon k n a kind_fn) [{-no specs-}] + = ppr sty n + +pprTyCon sty (SpecTyCon tc ty_maybes) [] + = ppBeside (pprTyCon sty tc []) + (if (codeStyle sty) + then identToC tys_stuff + else ppPStr tys_stuff) + where + tys_stuff = specMaybeTysSuffix ty_maybes + +#ifdef DPH +pprTyCon sty (ProcessorTyCon a) [] = ppBeside (ppStr "Processor") (ppInt a) + +pprTyCon sty (PodizedPodTyCon dim tc) [] + = ppBesides [ ppr sty tc, ppStr "Podized", ppr sty dim] +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty + +pprIfaceClass sw_chker better_id_fn inline_env + (MkClass k n tyvar super_classes sdsels ops sels defms insts links) + = let + sdsel_infos = map (getIdInfo . better_id_fn) sdsels + in + ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes, + ppr sty n, lookup_fn tyvar, + if null sdsel_infos + || omit_iface_pragmas + || (any boringIdInfo sdsel_infos) + -- ToDo: really should be "all bor..." + -- but then parsing is more tedious, + -- and this is really as good in practice. + then ppNil + else pp_sdsel_pragmas (sdsels `zip` sdsel_infos), + if (null ops) + then ppNil + else ppPStr SLIT("where")], + ppNest 8 (ppAboves + [ ppr_op op (better_id_fn sel) (better_id_fn defm) + | (op,sel,defm) <- zip3 ops sels defms]) ] + where + sty = PprInterface sw_chker + omit_iface_pragmas = sw_chker OmitInterfacePragmas + + lookup_fn = mk_lookup_tyvar_fn sty [tyvar] + + ppr_theta :: TyVarTemplate -> [Class] -> Pretty + ppr_theta tv [] = ppNil + ppr_theta tv super_classes + = ppBesides [ppLparen, + ppIntersperse pp'SP{-'-} (map ppr_assert super_classes), + ppStr ") =>"] + where + ppr_assert (MkClass _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv] + + pp_sdsel_pragmas sdsels_and_infos + = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}", + ppIntersperse pp'SP{-'-} + [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info + | (sdsel, info) <- sdsels_and_infos ], + ppStr "#-}"] + + ppr_op op opsel_id defm_id + = let + stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op) + in + if omit_iface_pragmas + then stuff + else ppAbove stuff + (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"]) + where + pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)] + pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)] +\end{code} + +\begin{code} +pprClassOp :: PprStyle -> ClassOp -> Pretty + +pprClassOp sty op = ppr_class_op sty [] op + +ppr_class_op sty tyvars (MkClassOp op_name i ty) + = case sty of + PprForC _ -> pp_C + PprForAsm _ _ _ -> pp_C + PprInterface _ -> ppCat [pp_user, ppPStr SLIT("::"), ppr_ty sty lookup_fn tOP_PREC ty] + PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr_ty PprDebug lookup_fn tOP_PREC ty] + _ -> pp_user + where + (local_tyvars,_,_) = splitType ty + lookup_fn = mk_lookup_tyvar_fn sty (tyvars ++ local_tyvars) + + pp_C = ppPStr op_name + pp_user = if isAvarop op_name + then ppBesides [ppLparen, pp_C, ppRparen] + else pp_C +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-matching]{@matchTy@} +%* * +%************************************************************************ + +Matching is a {\em unidirectional} process, matching a type against a +template (which is just a type with type variables in it). The matcher +assumes that there are no repeated type variables in the template, so that +it simply returns a mapping of type variables to types. + +\begin{code} +matchTy :: UniType -- Template + -> UniType -- Proposed instance of template + -> Maybe [(TyVarTemplate,UniType)] -- Matching substitution + +matchTy (UniTyVarTemplate v) ty = Just [(v,ty)] +matchTy (UniTyVar _) ty = panic "matchTy: unexpected TyVar (need TyVarTemplates)" + +matchTy (UniFun fun1 arg1) (UniFun fun2 arg2) = matchTys [fun1, arg1] [fun2, arg2] + +matchTy ty1@(UniData con1 args1) ty2@(UniData con2 args2) | con1 == con2 + = matchTys args1 args2 -- Same constructors, just match the arguments + +-- with type synonyms, we have to be careful +-- for the exact same reasons as in the unifier. +-- Please see the considerable commentary there +-- before changing anything here! (WDP 95/05) + +-- If just one or the other is a "visible" synonym (they all are at +-- the moment...), just expand it. + +matchTy (UniSyn con1 args1 ty1) ty2 + | isVisibleSynTyCon con1 + = matchTy ty1 ty2 +matchTy ty1 (UniSyn con2 args2 ty2) + | isVisibleSynTyCon con2 + = matchTy ty1 ty2 + +matchTy (UniSyn con1 args1 ty1) (UniSyn con2 args2 ty2) + -- if we get here, both synonyms must be "abstract" + -- (NB: not done yet) + = if (con1 == con2) then + -- Good news! Same synonym constructors, so we can shortcut + -- by unifying their arguments and ignoring their expansions. + matchTys args1 args2 + else + -- Never mind. Just expand them and try again + matchTy ty1 ty2 + +-- Catch-all fails +matchTy templ ty = Nothing +\end{code} + +@matchTys@ matches corresponding elements of a list of templates and +types. + +\begin{code} +matchTys :: [UniType] -> [UniType] -> Maybe [(TyVarTemplate, UniType)] + +matchTys [] [] = Just [] +matchTys (templ:templs) (ty:tys) + = case (matchTy templ ty) of + Nothing -> Nothing + Just subst -> case (matchTys templs tys) of + Nothing -> Nothing + Just subst2 -> Just (subst ++ subst2) +#ifdef DEBUG +matchTys [] tys + = pprPanic "matchTys: out of templates!; tys:" (ppr PprDebug tys) +matchTys tmpls [] + = pprPanic "matchTys: out of types!; templates:" (ppr PprDebug tmpls) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[UniTyFuns-misc]{Misc @UniType@ functions} +%* * +%************************************************************************ + +\begin{code} +cmpUniTypeMaybeList :: [Maybe UniType] -> [Maybe UniType] -> TAG_ +cmpUniTypeMaybeList [] [] = EQ_ +cmpUniTypeMaybeList (x:xs) [] = GT_ +cmpUniTypeMaybeList [] (y:ys) = LT_ +cmpUniTypeMaybeList (x:xs) (y:ys) + = case cmp_maybe_ty x y of { EQ_ -> cmpUniTypeMaybeList xs ys; other -> other } + +cmp_maybe_ty Nothing Nothing = EQ_ +cmp_maybe_ty (Just x) Nothing = GT_ +cmp_maybe_ty Nothing (Just y) = LT_ +cmp_maybe_ty (Just x) (Just y) = cmpUniType True{-properly-} x y +\end{code} + +Identity function if the type is a @TauType@; panics otherwise. +\begin{code} +#ifdef DEBUG +verifyTauTy :: String -> TauType -> TauType + +verifyTauTy caller ty@(UniDict _ _) = pprPanic (caller++":verifyTauTy:dict") (ppr PprShowAll ty) +verifyTauTy caller ty@(UniForall _ _) = pprPanic (caller++":verifyTauTy:forall") (ppr PprShowAll ty) +verifyTauTy caller (UniSyn tycon tys expansion) = UniSyn tycon tys (verifyTauTy caller expansion) +verifyTauTy caller tau_ty = tau_ty + +#endif {- DEBUG -} +\end{code} + +\begin{code} +showTypeCategory :: UniType -> Char + {- + {C,I,F,D} char, int, float, double + T tuple + S other single-constructor type + {c,i,f,d} unboxed ditto + t *unpacked* tuple + s *unpacked" single-cons... + + v void# + a primitive array + + E enumeration type + + dictionary, unless it's a ... + L List + > function + M other (multi-constructor) data-con type + . other type + - reserved for others to mark as "uninteresting" + -} +showTypeCategory ty + = if isDictTy ty + then '+' + else + case getUniDataTyCon_maybe ty of + Nothing -> if isFunType ty + then '>' + else '.' + + Just (tycon,_,_) -> + if maybeToBool (maybeCharLikeTyCon tycon) then 'C' + else if maybeToBool (maybeIntLikeTyCon tycon) then 'I' + else if maybeToBool (maybeFloatLikeTyCon tycon) then 'F' + else if maybeToBool (maybeDoubleLikeTyCon tycon) then 'D' + else if tycon == integerTyCon then 'J' + else if tycon == charPrimTyCon then 'c' + else if (tycon == intPrimTyCon || tycon == wordPrimTyCon + || tycon == addrPrimTyCon) then 'i' + else if tycon == floatPrimTyCon then 'f' + else if tycon == doublePrimTyCon then 'd' + else if isPrimTyCon tycon {- array, we hope -} then 'A' + else if isEnumerationTyCon tycon then 'E' + else if isTupleTyCon tycon then 'T' + else if maybeToBool (maybeSingleConstructorTyCon tycon) then 'S' + else if tycon == listTyCon then 'L' + else 'M' -- oh, well... +\end{code} diff --git a/ghc/compiler/uniType/UniType.hi b/ghc/compiler/uniType/UniType.hi new file mode 100644 index 0000000..a1d880b --- /dev/null +++ b/ghc/compiler/uniType/UniType.hi @@ -0,0 +1,74 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UniType where +import Class(Class, ClassOp) +import Id(Id) +import InstEnv(InstTemplate) +import Maybes(Labda) +import NameTypes(FullName, ShortName) +import Outputable(Outputable) +import PreludePS(_PackedString) +import PrimKind(PrimKind) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import Unique(Unique) +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +type InstTyEnv = [(TyVarTemplate, UniType)] +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +type RhoType = UniType +type SigmaType = UniType +type TauType = UniType +type ThetaType = [(Class, UniType)] +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +data UniType = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType +alpha :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar alpha_tv] _N_ #-} +alpha_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar alpha_tyvar] _N_ #-} +beta :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar beta_tv] _N_ #-} +beta_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar beta_tyvar] _N_ #-} +cmpUniType :: Bool -> UniType -> UniType -> Int# + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +delta :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar delta_tv] _N_ #-} +delta_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar delta_tyvar] _N_ #-} +epsilon :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar epsilon_tv] _N_ #-} +epsilon_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar epsilon_tyvar] _N_ #-} +gamma :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar gamma_tv] _N_ #-} +gamma_ty :: UniType + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar gamma_tyvar] _N_ #-} +instantiateTauTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniType instantiateTy _N_ #-} +instantiateThetaTy :: [(TyVarTemplate, UniType)] -> [(Class, UniType)] -> [(Class, UniType)] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +instantiateTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-} +mkDictTy :: Class -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: UniType) -> _!_ _ORIG_ UniType UniDict [] [u0, u1] _N_ #-} +mkForallTy :: [TyVarTemplate] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mkRhoTy :: [(Class, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +mkSigmaTy :: [TyVarTemplate] -> [(Class, UniType)] -> UniType -> UniType + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ #-} +mkTyVarTemplateTy :: TyVarTemplate -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ UniType UniTyVarTemplate [] [u0] _N_ #-} +mkTyVarTy :: TyVar -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _!_ _ORIG_ UniType UniTyVar [] [u0] _N_ #-} +quantifyTy :: [TyVar] -> UniType -> ([TyVarTemplate], UniType) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +instance Eq UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_ + (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_, + (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +instance Outputable UniType + {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ + ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-} + diff --git a/ghc/compiler/uniType/UniType.lhs b/ghc/compiler/uniType/UniType.lhs new file mode 100644 index 0000000..7cbbe44 --- /dev/null +++ b/ghc/compiler/uniType/UniType.lhs @@ -0,0 +1,370 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[UniType]{The UniType data type} + +The module @AbsUniType@ is the normal interface to this datatype. +This interface is for ``Friends Only.'' + +\begin{code} +#include "HsVersions.h" + +module UniType ( + UniType(..), -- not abstract; usually grabbed through AbsUniType + + -- USEFUL SYNONYMS + SigmaType(..), RhoType(..), TauType(..), + ThetaType(..), -- synonym for [(Class,UniType)] + InstTyEnv(..), + + -- CONSTRUCTION + mkTyVarTy, mkTyVarTemplateTy, mkDictTy, + -- use applyTyCon to make UniDatas, UniSyns + mkRhoTy, mkForallTy, mkSigmaTy, -- ToDo: perhaps nuke one? + + -- QUANTIFICATION & INSTANTIATION + quantifyTy, + instantiateTy, instantiateTauTy, instantiateThetaTy, + + -- COMPARISON + cmpUniType, + + -- PRE-BUILT TYPES (for Prelude) + alpha, beta, gamma, delta, epsilon, -- these have templates in them + alpha_ty, beta_ty, gamma_ty, delta_ty, epsilon_ty, -- these have tyvars in them + + -- to make the interface self-sufficient... + Class, TyCon, TyVar, TyVarTemplate, Maybe + ) where + +IMPORT_Trace -- ToDo:rm (debugging only) + +#if USE_ATTACK_PRAGMAS +import Class ( cmpClass, getClassSig, Class(..), ClassOp(..) ) +#else +import Class ( cmpClass, getClassSig, Class, ClassOp ) +#endif +import Maybes ( assocMaybe, Maybe(..) ) +import Outputable -- the output class, etc. +import Pretty +import TyCon ( cmpTyCon, TyCon, Arity(..) ) +import TyVar -- various things +import UniTyFuns ( pprUniType, unDictifyTy + IF_ATTACK_PRAGMAS(COMMA pprTyCon) + ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[UniType-basics]{Basics of the @UniType@ datatype} +%* * +%************************************************************************ + +\begin{code} +data UniType + = + -- The free variables of a UniType are always TyVars. + UniTyVar TyVar + + | UniFun UniType -- Function type + UniType + + | UniData -- Application of a non SynonymTyCon + TyCon -- Must NOT be a SynonymTyCon + [UniType] -- Arguments to the type constructor + + | UniSyn -- Application of a SynonymTyCon + TyCon -- Must be a SynonymTyCon + [UniType] -- Arguments to the type constructor + UniType -- Expanded version (merely cached here) + + | UniDict Class + UniType + + -- The next two are to do with universal quantification + + -- TyVarTemplates only need be unique within a single UniType; + -- because they are always bound by an enclosing UniForall. + | UniTyVarTemplate + TyVarTemplate + + | UniForall TyVarTemplate + UniType +\end{code} + +Universal quantification is over @TyVarTemplate@s. A type containing +a @UniTyVarTemplate@ always has either an enclosing @UniForall@ which +binds it, or a ``nearby'' binding @TyVarTemplate@. The only example +of the latter is that a @ClassOp@ will have a free occurrence of the +@TyVarTemplate@ which is held in the @Class@ object. + +@UniTyVarTemplate@s are never encountered during unification. + +The reasons for this huff and puff over template variables are: +\begin{enumerate} +\item +It's nice to be able to identify them in the code. +\item +It saves worry about accidental capture when instantiating types, +because the types with which the template variables are being +instantiated never themselves contain @UniTyVarTemplates@. +\end{enumerate} + +Note: if not @do_properly@, then we treat @UniTyVarTemplates@ as +``wildcards;'' we use this {\em only} when comparing types in STG +land. It is the responsibility of the caller to strip the +@UniForalls@ off the front. + +\begin{code} +cmpUniType do_properly ty1 ty2 + = cmp_ty [] ty1 ty2 + where + cmp_ty equivs (UniTyVar tv1) (UniTyVar tv2) = tv1 `cmpTyVar` tv2 + + cmp_ty equivs (UniFun a1 b1) (UniFun a2 b2) + = case cmp_ty equivs a1 a2 of { EQ_ -> cmp_ty equivs b1 b2; other -> other } + + cmp_ty equivs (UniData tc1 tys1) (UniData tc2 tys2) + = case cmpTyCon tc1 tc2 of { EQ_ -> cmp_ty_lists equivs tys1 tys2; other -> other } + + cmp_ty equivs (UniForall tv1 ty1) (UniForall tv2 ty2) + = cmp_ty ((tv1,tv2) : equivs) ty1 ty2 +\end{code} + +Now we deal with the Dict/Dict case. If the two classes are the same +then all is straightforward. If not, the two dicts will usually +differ, but (rarely) we could still be looking at two equal +dictionaries! For example, + + class Foo a => Baz a where + +That is, Foo is the only superclass of Baz, and Baz has no methods. +Then a Baz dictionary will be represented simply by a Foo dictionary! + +We could sort this out by unDictifying, but that seems like a +sledgehammer to crack a (rather rare) nut. Instead we ``de-synonym'' +each class, by looking to see if it is one of these odd guys which has +no ops and just one superclass (if so, do the same to this +superclass), and then compare the results. + +\begin{code} + cmp_ty equivs (UniDict c1 ty1) (UniDict c2 ty2) + = case cmpClass c1 c2 of + EQ_ -> cmp_ty equivs ty1 ty2 + other -> case cmpClass (super_ify c1) (super_ify c2) of + EQ_ -> cmp_ty equivs ty1 ty2 + other -> other + where + super_ify :: Class -> Class -- Iff the arg is a class with just one + -- superclass and no operations, then + -- return super_ify of the superclass, + -- otherwise just return the original + super_ify clas + = case getClassSig clas of + (_, [super_clas], [{-no ops-}]) -> super_ify super_clas + other -> clas +\end{code} + +Back to more straightforward things. + +\begin{code} + cmp_ty equivs (UniTyVarTemplate tv1) (UniTyVarTemplate tv2) + | not do_properly -- STG case: tyvar templates are ``wildcards'' + = EQ_ + + | otherwise -- compare properly + = case (tv1 `cmp_tv_tmpl` tv2) of + EQ_ -> EQ_ + _ -> -- tv1 should Jolly Well be in the equivalents list + case assocMaybe equivs tv1 of + Just xx -> xx `cmp_tv_tmpl` tv2 + Nothing -> +#if defined(DEBUG) + case (pprPanic "cmpUniType:failed assoc:" (ppCat [ppr PprDebug tv1, ppr PprDebug tv2, ppr PprDebug ty1, ppr PprDebug ty2, ppr PprDebug equivs])) of +#else + case (panic "cmpUniType:failed assoc") of +#endif + s -> -- never get here (BUG) + cmp_ty equivs s s + + cmp_ty equivs a@(UniDict _ _) b = cmp_ty equivs (unDictifyTy a) b + cmp_ty equivs a b@(UniDict _ _) = cmp_ty equivs a (unDictifyTy b) + + cmp_ty equivs (UniSyn _ _ expand) b = cmp_ty equivs expand b + cmp_ty equivs a (UniSyn _ _ expand) = cmp_ty equivs a expand + + -- more special cases for STG case + cmp_ty equivs (UniTyVarTemplate _) b | not do_properly = EQ_ + cmp_ty equivs a (UniTyVarTemplate _) | not do_properly = EQ_ + + cmp_ty equivs other_1 other_2 + = let tag1 = tag other_1 + tag2 = tag other_2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + where + tag (UniTyVar _) = (ILIT(1) :: FAST_INT) + tag (UniFun _ _) = ILIT(2) + tag (UniData _ _) = ILIT(3) + tag (UniDict _ _) = ILIT(4) + tag (UniForall _ _) = ILIT(5) + tag (UniTyVarTemplate _) = ILIT(6) + tag (UniSyn _ _ _) = ILIT(7) + + cmp_tv_tmpl :: TyVarTemplate -> TyVarTemplate -> TAG_ + cmp_tv_tmpl tv1 tv2 + = if tv1 == tv2 then EQ_ else if tv1 < tv2 then LT_ else GT_ + + cmp_ty_lists equivs [] [] = EQ_ + cmp_ty_lists equivs (x:xs) [] = GT_ + cmp_ty_lists equivs [] (y:ys) = LT_ + cmp_ty_lists equivs (x:xs) (y:ys) + = case cmp_ty equivs x y of { EQ_ -> cmp_ty_lists equivs xs ys; other -> other } +\end{code} + +\begin{code} +instance Eq UniType where + a == b = case cmpUniType True{-properly-} a b of { EQ_ -> True; _ -> False } + a /= b = case cmpUniType True{-properly-} a b of { EQ_ -> False; _ -> True } +\end{code} + +Useful synonyms: + +\begin{code} +type SigmaType = UniType +type RhoType = UniType -- No UniForall, UniTyVarTemplate +type TauType = UniType -- No UniDict constructors either +type ThetaType = [(Class, TauType)] -- No UniForalls in the UniTypes + +type InstTyEnv = [(TyVarTemplate, TauType)] -- Used for instantiating types +\end{code} + +Using @UniType@, a @SigmaType@ such as (Eq a) => a -> [a] +is written as +\begin{verbatim} +UniForall TyVarTemplate + (UniFun (UniDict Class (UniTyVarTemplate TyVarTemplate)) + (UniFun (UniTyVarTemplate TyVarTemplate) + (UniData TyCon [(UniTyVar TyVarTemplate)]))) +\end{verbatim} + +NB: @mkFunTy@ comes from the prelude. + +\begin{code} +mkTyVarTy = UniTyVar +mkTyVarTemplateTy = UniTyVarTemplate +mkDictTy = UniDict +-- use applyTyCon to make UniDatas and UniSyns + +alpha = UniTyVarTemplate alpha_tv +beta = UniTyVarTemplate beta_tv +gamma = UniTyVarTemplate gamma_tv +delta = UniTyVarTemplate delta_tv +epsilon = UniTyVarTemplate epsilon_tv + +alpha_ty = UniTyVar alpha_tyvar +beta_ty = UniTyVar beta_tyvar +gamma_ty = UniTyVar gamma_tyvar +delta_ty = UniTyVar delta_tyvar +epsilon_ty = UniTyVar epsilon_tyvar + +mkRhoTy :: ThetaType -> TauType -> RhoType +mkRhoTy theta tau + = foldr mk_dict tau theta + where + mk_dict (clas,ty) ty_body = UniFun (UniDict clas ty) ty_body + +mkForallTy [] ty = ty +mkForallTy tyvars ty = foldr UniForall ty tyvars + +mkSigmaTy :: [TyVarTemplate] -> ThetaType -> TauType -> SigmaType +mkSigmaTy tyvars theta tau = foldr UniForall (mkRhoTy theta tau) tyvars +\end{code} + +@quantifyTy@ takes @TyVars@ (not templates) and a @SigmaType@, and quantifies +over them. It makes new template type variables, and substitutes for the +original variables in the body. + +\begin{code} +quantifyTy :: [TyVar] -> SigmaType -> ([TyVarTemplate], SigmaType) + +quantifyTy [] ty = ([], ty) -- Simple, common case + +quantifyTy tyvars ty + = (templates, foldr UniForall (quant ty) templates) + where + templates = mkTemplateTyVars tyvars + env = tyvars `zip` (map UniTyVarTemplate templates) + + quant :: SigmaType -> SigmaType -- Rename the quantified type variables + -- to their template equivalents + + quant old_ty@(UniTyVar v) = case (assocMaybe env v) of + Nothing -> old_ty -- We may not be quantifying + -- over all the type vars! + Just ty -> ty + + quant ty@(UniTyVarTemplate v) = ty + quant ty@(UniData con []) = ty + quant (UniData con tys) = UniData con (map quant tys) + quant (UniSyn con tys ty) = UniSyn con (map quant tys) (quant ty) + quant (UniFun ty1 ty2) = UniFun (quant ty1) (quant ty2) + quant (UniDict clas ty) = UniDict clas (quant ty) + + quant (UniForall tv ty) = +#ifdef DEBUG + -- Paranoia check here; shouldn't happen + if tv `elem` templates then + panic "quantifyTy" + else +#endif + UniForall tv (quant ty) +\end{code} + +@instantiateTy@ is the inverse. It instantiates the free @TyVarTemplates@ +of a type. We assume that no inner Foralls bind one of the variables +being instantiated. + +\begin{code} +instantiateTy :: InstTyEnv -> UniType -> UniType + +instantiateTy [] ty = ty -- Simple, common case + +instantiateTy env ty + = inst ty + where + inst ty@(UniTyVar v) = ty + inst ty@(UniData con []) = ty + inst (UniData con tys) = UniData con (map inst tys) + inst (UniFun ty1 ty2) = UniFun (inst ty1) (inst ty2) + inst (UniSyn con tys ty) = UniSyn con (map inst tys) (inst ty) + inst (UniDict clas ty) = UniDict clas (inst ty) + inst (UniForall v ty) = UniForall v (inst ty) + + inst old_ty@(UniTyVarTemplate v) = case (assocMaybe env v) of + Nothing -> old_ty -- May partially instantiate + Just ty -> ty +\end{code} +The case mentioned in the comment (ie when the template isn't in the envt) +occurs when we instantiate a class op type before instantiating with the class +variable itself. +\begin{code} +instantiateTauTy :: InstTyEnv -> TauType -> TauType +instantiateTauTy tenv ty = instantiateTy tenv ty + +instantiateThetaTy :: InstTyEnv -> ThetaType -> ThetaType +instantiateThetaTy tenv theta + = [(clas,instantiateTauTy tenv ty) | (clas,ty) <- theta] +\end{code} + +%************************************************************************ +%* * +\subsection[UniType-instances]{Instance declarations for @UniType@} +%* * +%************************************************************************ + +\begin{code} +instance Outputable UniType where + ppr = pprUniType +\end{code} diff --git a/ghc/compiler/utils/Bag.hi b/ghc/compiler/utils/Bag.hi new file mode 100644 index 0000000..caf1465 --- /dev/null +++ b/ghc/compiler/utils/Bag.hi @@ -0,0 +1,27 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Bag where +import Outputable(Outputable) +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +bagToList :: Bag a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +emptyBag :: Bag a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Bag EmptyBag [u0] [] _N_ #-} +filterBag :: (a -> Bool) -> Bag a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +isEmptyBag :: Bag a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +listToBag :: [a] -> Bag a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +partitionBag :: (a -> Bool) -> Bag a -> (Bag a, Bag a) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +snocBag :: Bag a -> a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +unionBags :: Bag a -> Bag a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 1 2 CC 13 _/\_ u0 -> \ (u1 :: Bag u0) (u2 :: Bag u0) -> case u1 of { _ALG_ _ORIG_ Bag EmptyBag -> u2; (u3 :: Bag u0) -> case u2 of { _ALG_ _ORIG_ Bag EmptyBag -> u3; (u4 :: Bag u0) -> _!_ _ORIG_ Bag TwoBags [u0] [u1, u2] } } _N_ #-} +unionManyBags :: [Bag a] -> Bag a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: [Bag u0]) -> case u1 of { _ALG_ (:) (u2 :: Bag u0) (u3 :: [Bag u0]) -> _!_ _ORIG_ Bag ListOfBags [u0] [u1]; _NIL_ -> _!_ _ORIG_ Bag EmptyBag [u0] []; _NO_DEFLT_ } _N_ #-} +unitBag :: a -> Bag a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ Bag UnitBag [u0] [u1] _N_ #-} +instance Outputable a => Outputable (Bag a) + {-# GHC_PRAGMA _M_ Bag {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs new file mode 100644 index 0000000..3734df5 --- /dev/null +++ b/ghc/compiler/utils/Bag.lhs @@ -0,0 +1,110 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Bags]{@Bag@: an unordered collection with duplicates} + +\begin{code} +module Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, +#if ! defined(COMPILING_GHC) + elemBag, +#endif + filterBag, partitionBag, + isEmptyBag, snocBag, listToBag, bagToList + ) where + +#if defined(COMPILING_GHC) +import Id ( Id ) +import Outputable +import Pretty +import Util +#endif + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least + -- one branch is non-empty. + | ListOfBags [Bag a] -- The list is non-empty + +emptyBag = EmptyBag +unitBag = UnitBag + +#if ! defined(COMPILING_GHC) +-- not used in GHC +elemBag :: Eq a => a -> Bag a -> Bool +elemBag x EmptyBag = False +elemBag x (UnitBag y) = x==y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListOfBags bs) = any (x `elemBag`) bs +#endif + +unionManyBags [] = EmptyBag +unionManyBags xs = ListOfBags xs + +-- This one is a bit stricter! The bag will get completely evaluated. + + +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +snocBag :: Bag a -> a -> Bag a +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag EmptyBag = True +isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe +isEmptyBag (ListOfBags bs) = all isEmptyBag bs +isEmptyBag other = False + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag pred EmptyBag = EmptyBag +filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag +filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 + where + sat1 = filterBag pred b1 + sat2 = filterBag pred b2 +filterBag pred (ListOfBags bs) = ListOfBags sats + where + sats = [filterBag pred b | b <- bs] + + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, + Bag a {- Don't -}) +partitionBag pred EmptyBag = (EmptyBag, EmptyBag) +partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b) +partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where + (sat1,fail1) = partitionBag pred b1 + (sat2,fail2) = partitionBag pred b2 +partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails) + where + (sats, fails) = unzip [partitionBag pred b | b <- bs] + + +listToBag :: [a] -> Bag a +listToBag lst = foldr TwoBags EmptyBag (map UnitBag lst) + +bagToList :: Bag a -> [a] +bagToList b = b_to_l b [] + where + -- (b_to_l b xs) flattens b and puts xs on the end. + b_to_l EmptyBag xs = xs + b_to_l (UnitBag x) xs = x:xs + b_to_l (TwoBags b1 b2) xs = b_to_l b1 (b_to_l b2 xs) + b_to_l (ListOfBags bs) xs = foldr b_to_l xs bs +\end{code} + +\begin{code} +#if defined(COMPILING_GHC) + +instance (Outputable a) => Outputable (Bag a) where + ppr sty EmptyBag = ppStr "emptyBag" + ppr sty (UnitBag a) = ppr sty a + ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2] + ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack] + +#endif {- COMPILING_GHC -} +\end{code} diff --git a/ghc/compiler/utils/BitSet.hi b/ghc/compiler/utils/BitSet.hi new file mode 100644 index 0000000..92300ab --- /dev/null +++ b/ghc/compiler/utils/BitSet.hi @@ -0,0 +1,16 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface BitSet where +data BitSet {-# GHC_PRAGMA MkBS Word# #-} +emptyBS :: BitSet + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 case _#_ int2Word# [] [0#] of { _PRIM_ (u0 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u0] } _N_ #-} +listBS :: BitSet -> [Int] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +minusBS :: BitSet -> BitSet -> BitSet + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Word#) (u1 :: Word#) -> case _#_ not# [] [u1] of { _PRIM_ (u2 :: Word#) -> case _#_ and# [] [u0, u2] of { _PRIM_ (u3 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u3] } } _N_} _F_ _IF_ARGS_ 0 2 CC 6 \ (u0 :: BitSet) (u1 :: BitSet) -> case u0 of { _ALG_ _ORIG_ BitSet MkBS (u2 :: Word#) -> case u1 of { _ALG_ _ORIG_ BitSet MkBS (u3 :: Word#) -> case _#_ not# [] [u3] of { _PRIM_ (u4 :: Word#) -> case _#_ and# [] [u2, u4] of { _PRIM_ (u5 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u5] } }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +mkBS :: [Int] -> BitSet + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +singletonBS :: Int -> BitSet + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: Int#) -> case _#_ int2Word# [] [1#] of { _PRIM_ (u1 :: Word#) -> case _#_ shiftL# [] [u1, u0] of { _PRIM_ (u2 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u2] } } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Int) -> case u0 of { _ALG_ I# (u1 :: Int#) -> case _#_ int2Word# [] [1#] of { _PRIM_ (u2 :: Word#) -> case _#_ shiftL# [] [u2, u1] of { _PRIM_ (u3 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u3] } }; _NO_DEFLT_ } _N_ #-} +unionBS :: BitSet -> BitSet -> BitSet + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Word#) (u1 :: Word#) -> case _#_ or# [] [u0, u1] of { _PRIM_ (u2 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u2] } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: BitSet) (u1 :: BitSet) -> case u0 of { _ALG_ _ORIG_ BitSet MkBS (u2 :: Word#) -> case u1 of { _ALG_ _ORIG_ BitSet MkBS (u3 :: Word#) -> case _#_ or# [] [u2, u3] of { _PRIM_ (u4 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u4] }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/utils/BitSet.lhs b/ghc/compiler/utils/BitSet.lhs new file mode 100644 index 0000000..eb6b523 --- /dev/null +++ b/ghc/compiler/utils/BitSet.lhs @@ -0,0 +1,197 @@ +% +% (c) The GRASP Project, Glasgow University, 1994-1995 +% +\section[BitSet]{An implementation of very small sets} + +Bit sets are a fast implementation of sets of integers ranging from 0 +to one less than the number of bits in a machine word (typically 31). +If any element exceeds the maximum value for a particular machine +architecture, the results of these operations are undefined. You have +been warned. If you put any safety checks in this code, I will have +to kill you. + +Note: the Yale Haskell implementation won't provide a full 32 bits. +However, if you can handle the performance loss, you could change to +Integer and get virtually unlimited sets. + +\begin{code} + +module BitSet ( + BitSet, -- abstract type + mkBS, listBS, emptyBS, singletonBS, + unionBS, minusBS +#if ! defined(COMPILING_GHC) + , elementBS, intersectBS, isEmptyBS +#endif + ) where + +#ifdef __GLASGOW_HASKELL__ +-- nothing to import +#elif defined(__YALE_HASKELL__) +{-hide import from mkdependHS-} +import + LogOpPrims +#else +{-hide import from mkdependHS-} +import + Word +#endif + +#ifdef __GLASGOW_HASKELL__ + +data BitSet = MkBS Word# + +emptyBS :: BitSet +emptyBS = MkBS (int2Word# 0#) + +mkBS :: [Int] -> BitSet +mkBS xs = foldr (unionBS . singletonBS) emptyBS xs + +singletonBS :: Int -> BitSet +singletonBS x = case x of + I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#) + +unionBS :: BitSet -> BitSet -> BitSet +unionBS (MkBS x#) (MkBS y#) = MkBS (x# `or#` y#) + +minusBS :: BitSet -> BitSet -> BitSet +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 + 0# -> True + _ -> False + +intersectBS :: BitSet -> BitSet -> BitSet +intersectBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` y#) + +elementBS :: Int -> BitSet -> Bool +elementBS x (MkBS s#) = case x of + I# i# -> case word2Int# (((int2Word# 1#) `shiftL#` i#) `and#` s#) of + 0# -> False + _ -> True +#endif + +listBS :: BitSet -> [Int] +listBS s = listify s 0 + where listify (MkBS s#) n = + case word2Int# s# of + 0# -> [] + _ -> let s' = (MkBS (s# `shiftr` 1#)) + more = listify s' (n + 1) + in case word2Int# (s# `and#` (int2Word# 1#)) of + 0# -> more + _ -> n : more +# if __GLASGOW_HASKELL__ >= 23 + shiftr x y = shiftRL# x y +# else + shiftr x y = shiftR# x y +# endif + +#elif defined(__YALE_HASKELL__) + +data BitSet = MkBS Int + +emptyBS :: BitSet +emptyBS = MkBS 0 + +mkBS :: [Int] -> BitSet +mkBS xs = foldr (unionBS . singletonBS) emptyBS xs + +singletonBS :: Int -> BitSet +singletonBS x = MkBS (1 `ashInt` x) + +unionBS :: BitSet -> BitSet -> BitSet +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 + 0 -> True + _ -> False + +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 + 0 -> False + _ -> True +#endif + +minusBS :: BitSet -> BitSet -> BitSet +minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y) + +-- rewritten to avoid right shifts (which would give nonsense on negative +-- values. +listBS :: BitSet -> [Int] +listBS (MkBS s) = listify s 0 1 + where listify s n m = + case s of + 0 -> [] + _ -> let n' = n+1; m' = m+m in + case logbitpInt s m of + 0 -> listify s n' m' + _ -> n : listify (s `logandc2Int` m) n' m' + +#else /* HBC, perhaps? */ + +data BitSet = MkBS Word + +emptyBS :: BitSet +emptyBS = MkBS 0 + +mkBS :: [Int] -> BitSet +mkBS xs = foldr (unionBS . singletonBS) emptyBS xs + +singletonBS :: Int -> BitSet +singletonBS x = MkBS (1 `bitLsh` x) + +unionBS :: BitSet -> BitSet -> BitSet +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 + 0 -> True + _ -> False + +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 + 0 -> False + _ -> True +#endif + +minusBS :: BitSet -> BitSet -> BitSet +minusBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` (bitCompl y)) + +listBS :: BitSet -> [Int] +listBS (MkBS s) = listify s 0 + where listify s n = + case s of + 0 -> [] + _ -> let s' = s `bitRsh` 1 + more = listify s' (n + 1) + in case (s `bitAnd` 1) of + 0 -> more + _ -> n : more + +#endif + +\end{code} + + + + diff --git a/ghc/compiler/utils/CharSeq.hi b/ghc/compiler/utils/CharSeq.hi new file mode 100644 index 0000000..3d22652 --- /dev/null +++ b/ghc/compiler/utils/CharSeq.hi @@ -0,0 +1,26 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface CharSeq where +import PreludePS(_PackedString) +import Stdio(_FILE) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +cAppend :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-} +cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)SL" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cCh :: Char -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-} +cIndent :: Int -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CIndent [] [u0, u1] _N_ #-} +cInt :: Int -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-} +cNL :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNewline [] [] _N_ #-} +cNil :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-} +cPStr :: _PackedString -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-} +cShow :: CSeq -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +cStr :: [Char] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-} + diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs new file mode 100644 index 0000000..d552027 --- /dev/null +++ b/ghc/compiler/utils/CharSeq.lhs @@ -0,0 +1,282 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[CharSeq]{Characters sequences: the @CSeq@ type} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +#else +# define FAST_STRING String +# define FAST_INT Int +# define ILIT(x) (x) +# define IBOX(x) (x) +# define _GE_ >= +# define _ADD_ + +# define _SUB_ - +# define FAST_BOOL Bool +# define _TRUE_ True +# define _FALSE_ False +#endif + +module CharSeq ( + CSeq, + cNil, cAppend, cIndent, cNL, cStr, cPStr, cCh, cInt, +#if ! defined(COMPILING_GHC) + cLength, + cShows, +#endif + cShow + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + , cAppendFile + ) where + +#if __GLASGOW_HASKELL__ < 26 +import PreludePrimIO +#endif +import PreludeGlaST + +#else + ) where +#endif +\end{code} + +%************************************************ +%* * + \subsection{The interface} +%* * +%************************************************ + +\begin{code} +cShow :: CSeq -> [Char] + +#if ! defined(COMPILING_GHC) +-- not used in GHC +cShows :: CSeq -> ShowS +cLength :: CSeq -> Int +#endif + +cNil :: CSeq +cAppend :: CSeq -> CSeq -> CSeq +cIndent :: Int -> CSeq -> CSeq +cNL :: CSeq +cStr :: [Char] -> CSeq +cPStr :: FAST_STRING -> CSeq +cCh :: Char -> CSeq +cInt :: Int -> CSeq + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + +# if __GLASGOW_HASKELL__ < 23 +# define _FILE _Addr +# endif + +cAppendFile :: _FILE -> CSeq -> PrimIO () +#endif +\end{code} + +%************************************************ +%* * + \subsection{The representation} +%* * +%************************************************ + +\begin{code} +data CSeq + = CNil + | CAppend CSeq CSeq + | CIndent Int CSeq + | CNewline -- Move to start of next line, unless we're + -- already at the start of a line. + | CStr [Char] + | CCh Char + | CInt Int -- equiv to "CStr (show the_int)" +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 + | CPStr _PackedString +#endif +\end{code} + +The construction functions do pattern matching, to ensure that +redundant CNils are eliminated. This is bound to have some effect on +evaluation order, but quite what I don't know. + +\begin{code} +cNil = CNil +\end{code} + +The following special cases were eating our lunch! They make the whole +thing too strict. A classic strictness bug! +\begin{code} +-- cAppend CNil cs2 = cs2 +-- cAppend cs1 CNil = cs1 + +cAppend cs1 cs2 = CAppend cs1 cs2 + +cIndent n cs = CIndent n cs + +cNL = CNewline +cStr = CStr +cCh = CCh +cInt = CInt + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 +cPStr = CPStr +#else +cPStr = CStr +#endif + +cShow seq = flatten ILIT(0) _TRUE_ seq [] + +#if ! defined(COMPILING_GHC) +cShows seq rest = cShow seq ++ rest +cLength seq = length (cShow seq) -- *not* the best way to do this! +#endif + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 +cAppendFile file_star seq + = flattenIO file_star seq +#endif +\end{code} + +This code is {\em hammered}. We are not above doing sleazy +non-standard things. (WDP 94/10) + +\begin{code} +data WorkItem = WI FAST_INT CSeq -- indentation, and sequence + +flatten :: FAST_INT -- Indentation + -> FAST_BOOL -- True => just had a newline + -> CSeq -- Current seq to flatten + -> [WorkItem] -- Work list with indentation + -> String + +flatten n nlp CNil seqs = flattenS nlp seqs + +flatten n nlp (CAppend seq1 seq2) seqs = flatten n nlp seq1 ((WI n seq2) : seqs) +flatten n nlp (CIndent IBOX(n2) seq) seqs = flatten (n2 _ADD_ n) nlp seq seqs + +flatten n _FALSE_ CNewline seqs = '\n' : flattenS _TRUE_ seqs +flatten n _TRUE_ CNewline seqs = flattenS _TRUE_ seqs -- Already at start of line + +flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs +flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs +flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 +flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs +#endif + +flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs) +flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs) +flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs) +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 +flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs) +#endif +\end{code} + +\begin{code} +flattenS :: FAST_BOOL -> [WorkItem] -> String +flattenS nlp [] = "" +flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs +\end{code} + +\begin{code} +mkIndent :: FAST_INT -> String -> String +mkIndent ILIT(0) s = s +mkIndent n s + = if (n _GE_ ILIT(8)) + then '\t' : mkIndent (n _SUB_ ILIT(8)) s + else ' ' : mkIndent (n _SUB_ ILIT(1)) s + -- Hmm.. a little Unix-y. +\end{code} + +Now the I/O version. +This code is massively {\em hammered}. +It {\em ignores} indentation. + +\begin{code} +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + +flattenIO :: _FILE -- file we are writing to + -> CSeq -- Seq to print + -> PrimIO () + +flattenIO file sq +# if __GLASGOW_HASKELL__ >= 23 + | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-) + | otherwise +# endif + = flat sq + where + flat CNil = BSCC("flatCNil") returnPrimIO () ESCC + + flat (CIndent n2 seq) = BSCC("flatCIndent") flat seq ESCC + + flat (CAppend seq1 seq2) + = BSCC("flatCAppend") + flat seq1 `seqPrimIO` flat seq2 + ESCC + + flat CNewline = BSCC("flatCNL") _ccall_ stg_putc '\n' file ESCC + + flat (CCh c) = BSCC("flatCCh") _ccall_ stg_putc c file ESCC + + flat (CInt i) = BSCC("flatCInt") _ccall_ fprintf file percent_d i ESCC + + flat (CStr s) = BSCC("flatCStr") put_str s ESCC + +# if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23 + flat (CPStr s) = BSCC("flatCPStr") put_pstr s ESCC +# endif + + ----- + put_str, put_str2 :: String -> PrimIO () + + put_str str + = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO` + put_str2 str + + put_str2 [] = BSCC("putNil") returnPrimIO () ESCC + + put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs) + = BSCC("put4") + _ccall_ stg_putc c1 file `seqPrimIO` + _ccall_ stg_putc c2 file `seqPrimIO` + _ccall_ stg_putc c3 file `seqPrimIO` + _ccall_ stg_putc c4 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + + put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs) + = BSCC("put3") + _ccall_ stg_putc c1 file `seqPrimIO` + _ccall_ stg_putc c2 file `seqPrimIO` + _ccall_ stg_putc c3 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + + put_str2 (c1@(C# _) : c2@(C# _) : cs) + = BSCC("put2") + _ccall_ stg_putc c1 file `seqPrimIO` + _ccall_ stg_putc c2 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + + put_str2 (c1@(C# _) : cs) + = BSCC("put1") + _ccall_ stg_putc c1 file `seqPrimIO` + put_str2 cs -- efficiency hack? who knows... (WDP 94/10) + ESCC + +# if __GLASGOW_HASKELL__ >= 23 + put_pstr ps = _putPS file ps +# endif + +# if __GLASGOW_HASKELL__ >= 23 +percent_d = _psToByteArray SLIT("%d") +# else +percent_d = "%d" +# endif + +#endif {- __GLASGOW_HASKELL__ >= 22 -} +\end{code} diff --git a/ghc/compiler/utils/Digraph.hi b/ghc/compiler/utils/Digraph.hi new file mode 100644 index 0000000..98e65fe --- /dev/null +++ b/ghc/compiler/utils/Digraph.hi @@ -0,0 +1,11 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Digraph where +import Maybes(MaybeErr) +data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-} +dfs :: (a -> a -> Bool) -> (a -> [a]) -> ([a], [a]) -> [a] -> ([a], [a]) + {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(LL)S" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-} +stronglyConnComp :: (a -> a -> Bool) -> [(a, a)] -> [a] -> [[a]] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +topologicalSort :: (a -> a -> Bool) -> [(a, a)] -> [a] -> MaybeErr [a] [[a]] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs new file mode 100644 index 0000000..84cf220 --- /dev/null +++ b/ghc/compiler/utils/Digraph.lhs @@ -0,0 +1,159 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Digraph]{An implementation of directed graphs} + +\begin{code} +module Digraph ( + stronglyConnComp, +--OLD: whichCycle, -- MOVED: isCyclic, + topologicalSort, + dfs, -- deforester + MaybeErr + ) where + +import Maybes ( MaybeErr(..) ) +import Util +\end{code} + +This module implements at least part of an abstract data type for +directed graphs. The part implemented is what we need for doing +dependency analyses. + +>type Edge vertex = (vertex, vertex) +>type Cycle vertex = [vertex] + +%************************************************************************ +%* * +%* Strongly connected components * +%* * +%************************************************************************ + +John Launchbury provided the basic code for doing strongly-connected +components. + +The result is a list of cycles (each of which is a list of vertices), +and these cycles are topologically sorted, so that if there is an edge from +cycle A to cycle B, then A occurs after B in the result list. + +\begin{code} +stronglyConnComp :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] -> [[vertex]] + +stronglyConnComp eq edges vertices + = snd (span_tree (new_range reversed_edges) + ([],[]) + ( snd (dfs (new_range edges) ([],[]) vertices) ) + ) + where + reversed_edges = map swap edges + + swap (x,y) = (y, x) + + -- new_range :: Eq v => [Edge v] -> v -> [v] + + new_range [] w = [] + new_range ((x,y):xys) w + = if x `eq` w + then (y : (new_range xys w)) + else (new_range xys w) + + elem x [] = False + elem x (y:ys) = x `eq` y || x `elem` ys + +{- span_tree :: Eq v => (v -> [v]) + -> ([v], [[v]]) + -> [v] + -> ([v], [[v]]) +-} + span_tree r (vs,ns) [] = (vs,ns) + span_tree r (vs,ns) (x:xs) + | x `elem` vs = span_tree r (vs,ns) xs + | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') -> + span_tree r (vs',(x:ns'):ns) xs } + +{- dfs :: Eq v => (v -> [v]) + -> ([v], [v]) + -> [v] + -> ([v], [v]) +-} + dfs r (vs,ns) [] = (vs,ns) + dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs + | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') -> + dfs r (vs',(x:ns')++ns) xs } +\end{code} + +\begin{code} +dfs :: (v -> v -> Bool) + -> (v -> [v]) + -> ([v], [v]) + -> [v] + -> ([v], [v]) + +dfs eq r (vs,ns) [] = (vs,ns) +dfs eq r (vs,ns) (x:xs) + | any (eq x) vs = dfs eq r (vs,ns) xs + | True = case (dfs eq r (x:vs,[]) (r x)) of + (vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs + +\end{code} + + +@isCyclic@ expects to be applied to an element of the result of a +stronglyConnComp; it tells whether such an element is a cycle. The +answer is True if it is not a singleton, of course, but if it is a +singleton we have to look up in the edges to see if it refers to +itself. + +\begin{code} +{- MOVED TO POINT OF SINGLE USE: RenameBinds4 (WDP 95/02) + +isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool + +isCyclic edges [] = panic "isCyclic: empty component" +isCyclic edges [v] = (v,v) `is_elem` edges where { is_elem = isIn "isCyclic" } +isCyclic edges vs = True +-} +\end{code} + +OLD: The following @whichCycle@ should be called only when the given +@vertex@ is known to be in one of the cycles. This isn't difficult to +achieve if the call follows the creation of the list of components by +@cycles@ (NB: strictness analyser) with all vertices of interest in +them. + +>{- UNUSED: +>whichCycle :: Eq vertex => [Cycle vertex] -> vertex -> (Cycle vertex) +>whichCycle vss v = head [vs | vs <-vss, v `is_elem` vs] where { is_elem = isIn "whichCycle" } +>-} + +%************************************************************************ +%* * +%* Topological sort * +%* * +%************************************************************************ + +Topological sort fails if it finds any cycles, returning the offending cycles. + +If it succeeds, the result is a list of vertices, such that if there is +an edge from vertex A to vertex B then A occurs after B in the result list. + +\begin{code} +topologicalSort :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] + -> MaybeErr [vertex] -- Success: the sorted list + [[vertex]] -- Failure: the cycles + +topologicalSort eq edges vertices + = case (stronglyConnComp eq edges vertices) of { sccs -> + case (partition (is_cyclic edges) sccs) of { (cycles, singletons) -> + if null cycles + then Succeeded [ v | [v] <- singletons ] + else Failed cycles + }} + where + is_cyclic es [] = panic "is_cyclic: empty component" + is_cyclic es [v] = (v,v) `elem` es + is_cyclic es vs = True + + elem (x,y) [] = False + elem z@(x,y) ((a,b):cs) = (x `eq` a && y `eq` b) || z `elem` cs +\end{code} diff --git a/ghc/compiler/utils/FiniteMap.hi b/ghc/compiler/utils/FiniteMap.hi new file mode 100644 index 0000000..4d31462 --- /dev/null +++ b/ghc/compiler/utils/FiniteMap.hi @@ -0,0 +1,58 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface FiniteMap where +import Maybes(Labda) +import Outputable(Outputable) +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +type FiniteSet a = FiniteMap a () +data Labda a {-# GHC_PRAGMA Hamna | Ni a #-} +addListToFM :: Ord a => FiniteMap a b -> [(a, b)] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ } #-} +addListToFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> [(a, b)] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLLS" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ } #-} +addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 1122 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ } #-} +delListFromFM :: Ord a => FiniteMap a b -> [a] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ } #-} +elemFM :: Ord a => a -> FiniteMap a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _SPECIALISE_ [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-} +elementOf :: Ord a => a -> FiniteMap a () -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap elemFM { u0 } { () } _N_ #-} +eltsFM :: FiniteMap a b -> [b] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +emptyFM :: FiniteMap a b + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, u1] [] _N_ #-} +emptySet :: FiniteMap a () + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-} +fmToList :: FiniteMap a b -> [(a, b)] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isEmptyFM :: FiniteMap a b -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isEmptySet :: FiniteMap a () -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap isEmptyFM { u0 } { () } _N_ #-} +keysFM :: FiniteMap b a -> [b] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +listToFM :: Ord a => [(a, b)] -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 21 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +lookupFM :: Ord a => FiniteMap a b -> a -> Labda b + {-# GHC_PRAGMA _A_ 1 _U_ 112 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +lookupWithDefaultFM :: Ord a => FiniteMap a b -> b -> a -> b + {-# GHC_PRAGMA _A_ 1 _U_ 1112 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ } #-} +minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ } #-} +minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a () + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-} +mkSet :: Ord a => [a] -> FiniteMap a () + {-# GHC_PRAGMA _A_ 1 _U_ 21 _N_ _N_ _N_ _N_ #-} +plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ } #-} +plusFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> FiniteMap a b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 1 _U_ 2221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 221 _N_ _S_ "LSS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 221 _N_ _S_ "LSS" _N_ _N_ } #-} +setToList :: FiniteMap a () -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-} +singletonFM :: a -> b -> FiniteMap a b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a () + {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-} +instance Outputable a => Outputable (FiniteMap a b) + {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs new file mode 100644 index 0000000..03f087a --- /dev/null +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -0,0 +1,851 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[FiniteMap]{An implementation of finite maps} + +``Finite maps'' are the heart of the compiler's +lookup-tables/environments and its implementation of sets. Important +stuff! + +This code is derived from that in the paper: +\begin{display} + S Adams + "Efficient sets: a balancing act" + Journal of functional programming 3(4) Oct 1993, pp553-562 +\end{display} + +The code is SPECIALIZEd to various highly-desirable types (e.g., Id) +near the end (only \tr{#ifdef COMPILING_GHC}). + +\begin{code} +#if defined(COMPILING_GHC) +#include "HsVersions.h" +#define IF_NOT_GHC(a) {--} +#else +#define ASSERT(e) {--} +#define IF_NOT_GHC(a) a +#define COMMA , +#endif + +#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */ +#define OUTPUTABLE_key , Outputable key +#else +#define OUTPUTABLE_key {--} +#endif + +module FiniteMap ( + FiniteMap, -- abstract type + + emptyFM, singletonFM, listToFM, + + addToFM, addListToFM, + IF_NOT_GHC(addToFM_C COMMA) + addListToFM_C, + IF_NOT_GHC(delFromFM COMMA) + delListFromFM, + + plusFM, plusFM_C, + IF_NOT_GHC(intersectFM COMMA intersectFM_C COMMA) + minusFM, -- exported for GHCI only + + IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA) + + IF_NOT_GHC(sizeFM COMMA) + isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, + + fmToList, keysFM, eltsFM{-used in GHCI-} + +#if defined(COMPILING_GHC) + , FiniteSet(..), emptySet, mkSet, isEmptySet + , elementOf, setToList, union, minusSet{-exported for GHCI-} +#endif + + -- To make it self-sufficient +#if __HASKELL1__ < 3 + , Maybe +#endif + ) where + +import Maybes + +#if defined(COMPILING_GHC) +import AbsUniType +import Pretty +import Outputable +import Util +import CLabelInfo ( CLabel ) -- for specialising +#if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) -- ditto +#define IF_NCG(a) a +#else +#define IF_NCG(a) {--} +#endif +#endif + +-- SIGH: but we use unboxed "sizes"... +#if __GLASGOW_HASKELL__ +#define IF_GHC(a,b) a +#else /* not GHC */ +#define IF_GHC(a,b) b +#endif /* not GHC */ +\end{code} + + +%************************************************************************ +%* * +\subsection{The signature of the module} +%* * +%************************************************************************ + +\begin{code} +-- BUILDING +emptyFM :: FiniteMap key elt +singletonFM :: key -> elt -> FiniteMap key elt +listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt + -- In the case of duplicates, the last is taken + +-- ADDING AND DELETING + -- Throws away any previous binding + -- In the list case, the items are added starting with the + -- first one in the list +addToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt +addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt + + -- Combines with previous binding +addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> key -> elt + -> FiniteMap key elt +addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> [(key,elt)] + -> FiniteMap key elt + + -- Deletion doesn't complain if you try to delete something + -- which isn't there +delFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt +delListFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt + +-- COMBINING + -- Bindings in right argument shadow those in the left +plusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + + -- Combines bindings for the same thing with the given function +plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt + +minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt + -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2 + +intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt +intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt) + -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt + +-- MAPPING, FOLDING, FILTERING +foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a +mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 +filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool) + -> FiniteMap key elt -> FiniteMap key elt + +-- INTERROGATING +sizeFM :: FiniteMap key elt -> Int +isEmptyFM :: FiniteMap key elt -> Bool + +elemFM :: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool +lookupFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt +lookupWithDefaultFM + :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt + -- lookupWithDefaultFM supplies a "default" elt + -- to return for an unmapped key + +-- LISTIFYING +fmToList :: FiniteMap key elt -> [(key,elt)] +keysFM :: FiniteMap key elt -> [key] +eltsFM :: FiniteMap key elt -> [elt] +\end{code} + +%************************************************************************ +%* * +\subsection{The @FiniteMap@ data type, and building of same} +%* * +%************************************************************************ + +Invariants about @FiniteMap@: +\begin{enumerate} +\item +all keys in a FiniteMap are distinct +\item +all keys in left subtree are $<$ key in Branch and +all keys in right subtree are $>$ key in Branch +\item +size field of a Branch gives number of Branch nodes in the tree +\item +size of left subtree is differs from size of right subtree by a +factor of at most \tr{sIZE_RATIO} +\end{enumerate} + +\begin{code} +data FiniteMap key elt + = EmptyFM + | Branch key elt -- Key and elt stored here + IF_GHC(Int#,Int{-STRICT-}) -- Size >= 1 + (FiniteMap key elt) -- Children + (FiniteMap key elt) +\end{code} + +\begin{code} +emptyFM = EmptyFM +{- +emptyFM + = Branch bottom bottom IF_GHC(0#,0) bottom bottom + where + bottom = panic "emptyFM" +-} + +-- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _) + +singletonFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM + +listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs +\end{code} + +%************************************************************************ +%* * +\subsection{Adding to and deleting from @FiniteMaps@} +%* * +%************************************************************************ + +\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 (Branch key elt size fm_l fm_r) new_key new_elt +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp new_key key of + _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r + _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) + _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r +#else + | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r + | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt) + | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r +#endif + +addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs + +addListToFM_C combiner fm key_elt_pairs + = foldl add fm key_elt_pairs -- foldl adds from the left + where + add fmap (key,elt) = addToFM_C combiner fmap key elt +\end{code} + +\begin{code} +delFromFM EmptyFM del_key = emptyFM +delFromFM (Branch key elt size fm_l fm_r) del_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp del_key key of + _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key) + _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r + _EQ -> glueBal fm_l fm_r +#else + | del_key > key + = mkBalBranch key elt fm_l (delFromFM fm_r del_key) + + | del_key < key + = mkBalBranch key elt (delFromFM fm_l del_key) fm_r + + | key == del_key + = glueBal fm_l fm_r +#endif + +delListFromFM fm keys = foldl delFromFM fm keys +\end{code} + +%************************************************************************ +%* * +\subsection{Combining @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +plusFM_C combiner EmptyFM fm2 = fm2 +plusFM_C combiner fm1 EmptyFM = fm1 +plusFM_C combiner fm1 (Branch split_key elt2 _ left right) + = mkVBalBranch split_key new_elt + (plusFM_C combiner lts left) + (plusFM_C combiner gts right) + where + lts = splitLT fm1 split_key + gts = splitGT fm1 split_key + new_elt = case lookupFM fm1 split_key of + Nothing -> elt2 + Just elt1 -> combiner elt1 elt2 + +-- It's worth doing plusFM specially, because we don't need +-- to do the lookup in fm1. + +plusFM EmptyFM fm2 = fm2 +plusFM fm1 EmptyFM = fm1 +plusFM fm1 (Branch split_key elt1 _ left right) + = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right) + where + lts = splitLT fm1 split_key + gts = splitGT fm1 split_key + +minusFM EmptyFM fm2 = emptyFM +minusFM fm1 EmptyFM = fm1 +minusFM fm1 (Branch split_key elt _ left right) + = glueVBal (minusFM lts left) (minusFM gts right) + -- The two can be way different, so we need glueVBal + where + lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones + gts = splitGT fm1 split_key -- are not in either. + +intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2 + +intersectFM_C combiner fm1 EmptyFM = emptyFM +intersectFM_C combiner EmptyFM fm2 = emptyFM +intersectFM_C combiner fm1 (Branch split_key elt2 _ left right) + + | maybeToBool maybe_elt1 -- split_elt *is* in intersection + = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left) + (intersectFM_C combiner gts right) + + | otherwise -- split_elt is *not* in intersection + = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right) + + where + lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones + gts = splitGT fm1 split_key -- are not in either. + + maybe_elt1 = lookupFM fm1 split_key + Just elt1 = maybe_elt1 +\end{code} + +%************************************************************************ +%* * +\subsection{Mapping, folding, and filtering with @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +foldFM k z EmptyFM = z +foldFM k z (Branch key elt _ fm_l fm_r) + = foldFM k (k key elt (foldFM k z fm_r)) fm_l + +mapFM f EmptyFM = emptyFM +mapFM f (Branch key elt size fm_l fm_r) + = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r) + +filterFM p EmptyFM = emptyFM +filterFM p (Branch key elt _ fm_l fm_r) + | p key elt -- Keep the item + = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r) + + | otherwise -- Drop the item + = glueVBal (filterFM p fm_l) (filterFM p fm_r) +\end{code} + +%************************************************************************ +%* * +\subsection{Interrogating @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +--{-# INLINE sizeFM #-} +sizeFM EmptyFM = 0 +sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size) + +isEmptyFM fm = sizeFM fm == 0 + +lookupFM EmptyFM key = Nothing +lookupFM (Branch key elt _ fm_l fm_r) key_to_find +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp key_to_find key of + _LT -> lookupFM fm_l key_to_find + _GT -> lookupFM fm_r key_to_find + _EQ -> Just elt +#else + | key_to_find < key = lookupFM fm_l key_to_find + | key_to_find > key = lookupFM fm_r key_to_find + | otherwise = Just elt +#endif + +key `elemFM` fm + = case (lookupFM fm key) of { Nothing -> False; Just elt -> True } + +lookupWithDefaultFM fm deflt key + = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt } +\end{code} + +%************************************************************************ +%* * +\subsection{Listifying @FiniteMaps@} +%* * +%************************************************************************ + +\begin{code} +fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm +keysFM fm = foldFM (\ key elt rest -> key : rest) [] fm +eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm +\end{code} + + +%************************************************************************ +%* * +\subsection{The implementation of balancing} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection{Basic construction of a @FiniteMap@} +%* * +%************************************************************************ + +@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@.) + +\begin{code} +sIZE_RATIO :: Int +sIZE_RATIO = 5 + +mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only + => Int + -> key -> elt + -> FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +mkBranch which key elt fm_l fm_r + = --ASSERT( left_ok && right_ok && balance_ok ) +#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS) + if not ( left_ok && right_ok && balance_ok ) then + pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok], + ppr PprDebug key, + ppr PprDebug fm_l, + ppr PprDebug fm_r]) + else +#endif + let + result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r + in +-- if sizeFM result <= 8 then + result +-- else +-- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) ( +-- result +-- ) + where + left_ok = case fm_l of + EmptyFM -> True + Branch left_key _ _ _ _ -> let + biggest_left_key = fst (findMax fm_l) + in + biggest_left_key < key + right_ok = case fm_r of + EmptyFM -> True + Branch right_key _ _ _ _ -> let + smallest_right_key = fst (findMin fm_r) + in + key < smallest_right_key + balance_ok = True -- sigh +{- LATER: + balance_ok + = -- Both subtrees have one or no elements... + (left_size + right_size <= 1) +-- NO || left_size == 0 -- ??? +-- NO || right_size == 0 -- ??? + -- ... or the number of elements in a subtree does not exceed + -- sIZE_RATIO times the number of elements in the other subtree + || (left_size * sIZE_RATIO >= right_size && + right_size * sIZE_RATIO >= left_size) +-} + + left_size = sizeFM fm_l + right_size = sizeFM fm_r + +#ifdef __GLASGOW_HASKELL__ + unbox :: Int -> Int# + unbox (I# size) = size +#else + unbox :: Int -> Int + unbox x = x +#endif +\end{code} + +%************************************************************************ +%* * +\subsubsection{{\em Balanced} construction of a @FiniteMap@} +%* * +%************************************************************************ + +@mkBalBranch@ rebalances, assuming that the subtrees aren't too far +out of whack. + +\begin{code} +mkBalBranch :: (Ord key OUTPUTABLE_key) + => key -> elt + -> FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +mkBalBranch key elt fm_L fm_R + + | size_l + size_r < 2 + = mkBranch 1{-which-} key elt fm_L fm_R + + | size_r > sIZE_RATIO * size_l -- Right tree too big + = case fm_R of + Branch _ _ _ fm_rl fm_rr + | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R + | otherwise -> double_L fm_L fm_R + -- Other case impossible + + | size_l > sIZE_RATIO * size_r -- Left tree too big + = case fm_L of + Branch _ _ _ fm_ll fm_lr + | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R + | otherwise -> double_R fm_L fm_R + -- Other case impossible + + | otherwise -- No imbalance + = mkBranch 2{-which-} key elt fm_L fm_R + + where + size_l = sizeFM fm_L + size_r = sizeFM fm_R + + single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr) + = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr + + double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr) + = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll) + (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr) + + single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r + = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r) + + double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r + = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl) + (mkBranch 12{-which-} key elt fm_lrr fm_r) +\end{code} + + +\begin{code} +mkVBalBranch :: (Ord key OUTPUTABLE_key) + => key -> elt + -> FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +-- Assert: in any call to (mkVBalBranch_C comb key elt l r), +-- (a) all keys in l are < all keys in r +-- (b) all keys in l are < key +-- (c) all keys in r are > key + +mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt +mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt + +mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr) + fm_r@(Branch key_r elt_r _ fm_rl fm_rr) + | sIZE_RATIO * size_l < size_r + = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr + + | sIZE_RATIO * size_r < size_l + = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r) + + | otherwise + = mkBranch 13{-which-} key elt fm_l fm_r + + where + size_l = sizeFM fm_l + size_r = sizeFM fm_r +\end{code} + +%************************************************************************ +%* * +\subsubsection{Gluing two trees together} +%* * +%************************************************************************ + +@glueBal@ assumes its two arguments aren't too far out of whack, just +like @mkBalBranch@. But: all keys in first arg are $<$ all keys in +second. + +\begin{code} +glueBal :: (Ord key OUTPUTABLE_key) + => FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +glueBal EmptyFM fm2 = fm2 +glueBal fm1 EmptyFM = fm1 +glueBal fm1 fm2 + -- The case analysis here (absent in Adams' program) is really to deal + -- with the case where fm2 is a singleton. Then deleting the minimum means + -- we pass an empty tree to mkBalBranch, which breaks its invariant. + | sizeFM fm2 > sizeFM fm1 + = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2) + + | otherwise + = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2 + where + (mid_key1, mid_elt1) = findMax fm1 + (mid_key2, mid_elt2) = findMin fm2 +\end{code} + +@glueVBal@ copes with arguments which can be of any size. +But: all keys in first arg are $<$ all keys in second. + +\begin{code} +glueVBal :: (Ord key OUTPUTABLE_key) + => FiniteMap key elt -> FiniteMap key elt + -> FiniteMap key elt + +glueVBal EmptyFM fm2 = fm2 +glueVBal fm1 EmptyFM = fm1 +glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr) + fm_r@(Branch key_r elt_r _ fm_rl fm_rr) + | sIZE_RATIO * size_l < size_r + = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr + + | sIZE_RATIO * size_r < size_l + = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r) + + | otherwise -- We now need the same two cases as in glueBal above. + = glueBal fm_l fm_r + where + (mid_key_l,mid_elt_l) = findMax fm_l + (mid_key_r,mid_elt_r) = findMin fm_r + size_l = sizeFM fm_l + size_r = sizeFM fm_r +\end{code} + +%************************************************************************ +%* * +\subsection{Local utilities} +%* * +%************************************************************************ + +\begin{code} +splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt + +-- splitLT fm split_key = fm restricted to keys < split_key +-- splitGE fm split_key = fm restricted to keys >= split_key (UNUSED) +-- splitGT fm split_key = fm restricted to keys > split_key + +splitLT EmptyFM split_key = emptyFM +splitLT (Branch key elt _ fm_l fm_r) split_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp split_key key of + _LT -> splitLT fm_l split_key + _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key) + _EQ -> fm_l +#else + | split_key < key = splitLT fm_l split_key + | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key) + | otherwise = fm_l +#endif + +{- UNUSED: +splitGE EmptyFM split_key = emptyFM +splitGE (Branch key elt _ fm_l fm_r) split_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp split_key key of + _GT -> splitGE fm_r split_key + _LT -> mkVBalBranch key elt (splitGE fm_l split_key) fm_r + _EQ -> mkVBalBranch key elt emptyFM fm_r +#else + | split_key > key = splitGE fm_r split_key + | split_key < key = mkVBalBranch key elt (splitGE fm_l split_key) fm_r + | otherwise = mkVBalBranch key elt emptyFM fm_r +#endif +-} + +splitGT EmptyFM split_key = emptyFM +splitGT (Branch key elt _ fm_l fm_r) split_key +#ifdef __GLASGOW_HASKELL__ + = case _tagCmp split_key key of + _GT -> splitGT fm_r split_key + _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r + _EQ -> fm_r +#else + | split_key > key = splitGT fm_r split_key + | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r + | otherwise = fm_r +#endif + +findMin :: FiniteMap key elt -> (key,elt) +findMin (Branch key elt _ EmptyFM _) = (key,elt) +findMin (Branch key elt _ fm_l _) = findMin fm_l + +deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt +deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r +deleteMin (Branch key elt _ fm_l fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r + +findMax :: FiniteMap key elt -> (key,elt) +findMax (Branch key elt _ _ EmptyFM) = (key,elt) +findMax (Branch key elt _ _ fm_r) = findMax fm_r + +deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt +deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l +deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r) +\end{code} + +%************************************************************************ +%* * +\subsection{Output-ery} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) + +{- this is the real one actually... +instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where + ppr sty fm = ppr sty (fmToList fm) +-} + +-- temp debugging (ToDo: rm) +instance (Outputable key) => Outputable (FiniteMap key elt) where + ppr sty fm = pprX sty fm + +pprX sty EmptyFM = ppChar '!' +pprX sty (Branch key elt sz fm_l fm_r) + = ppBesides [ppLparen, pprX sty fm_l, ppSP, + ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP, + pprX sty fm_r, ppRparen] +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{FiniteSets---a thin veneer} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) + +type FiniteSet key = FiniteMap key () +emptySet :: FiniteSet key +mkSet :: (Ord key OUTPUTABLE_key) => [key] -> FiniteSet key +isEmptySet :: FiniteSet key -> Bool +elementOf :: (Ord key OUTPUTABLE_key) => key -> FiniteSet key -> Bool +minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key +setToList :: FiniteSet key -> [key] +union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key + +emptySet = emptyFM +mkSet xs = listToFM [ (x, ()) | x <- xs] +isEmptySet = isEmptyFM +elementOf = elemFM +minusSet = minusFM +setToList = keysFM +union = plusFM + +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Efficiency pragmas for GHC} +%* * +%************************************************************************ + +When the FiniteMap module is used in GHC, we specialise it for +\tr{Uniques}, for dastardly efficiency reasons. + +\begin{code} +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ + -- the __GLASGOW_HASKELL__ chk avoids an hbc 0.999.7 bug + +{-# SPECIALIZE listToFM + :: [(Int,elt)] -> FiniteMap Int elt, + [(CLabel,elt)] -> FiniteMap CLabel elt, + [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt, + [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE addToFM + :: FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt, + FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt, + FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE addListToFM + :: FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt, + FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) + #-} +{-NOT EXPORTED!! # SPECIALIZE addToFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE addListToFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) + #-} +{-NOT EXPORTED!!! # SPECIALIZE delFromFM + :: FiniteMap Int elt -> Int -> FiniteMap Int elt, + FiniteMap CLabel elt -> CLabel -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE delListFromFM + :: FiniteMap Int elt -> [Int] -> FiniteMap Int elt, + FiniteMap CLabel elt -> [CLabel] -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE elemFM + :: FAST_STRING -> FiniteMap FAST_STRING elt -> Bool + #-} +{-not EXPORTED!!! # SPECIALIZE filterFM + :: (Int -> elt -> Bool) -> FiniteMap Int elt -> FiniteMap Int elt, + (CLabel -> elt -> Bool) -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA (Reg -> elt -> Bool) -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-NOT EXPORTED!!! # SPECIALIZE intersectFM + :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-not EXPORTED !!!# SPECIALIZE intersectFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE lookupFM + :: FiniteMap Int elt -> Int -> Maybe elt, + FiniteMap CLabel elt -> CLabel -> Maybe elt, + FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt, + FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt) + #-} +{-# SPECIALIZE lookupWithDefaultFM + :: FiniteMap Int elt -> elt -> Int -> elt, + FiniteMap CLabel elt -> elt -> CLabel -> elt + IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt) + #-} +{-# SPECIALIZE minusFM + :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt, + FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt, + FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE plusFM + :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt, + FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} +{-# SPECIALIZE plusFM_C + :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, + (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) + #-} + +#endif {- compiling for GHC -} +\end{code} diff --git a/ghc/compiler/utils/LiftMonad.hi b/ghc/compiler/utils/LiftMonad.hi new file mode 100644 index 0000000..fd54066 --- /dev/null +++ b/ghc/compiler/utils/LiftMonad.hi @@ -0,0 +1,5 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface LiftMonad where +bogusLiftMonadThing :: Bool + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_ #-} + diff --git a/ghc/compiler/utils/LiftMonad.lhs b/ghc/compiler/utils/LiftMonad.lhs new file mode 100644 index 0000000..40a84e5 --- /dev/null +++ b/ghc/compiler/utils/LiftMonad.lhs @@ -0,0 +1,39 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[LiftMonad]{A lifting monad} + +\begin{code} +#if defined(__GLASGOW_HASKELL__) +module LiftMonad where { bogusLiftMonadThing = True } + +#else +module LiftMonad ( + LiftM, -- abstract + thenLft, returnLft, mapLft + ) where + +infixr 9 `thenLft` + +data LiftM a = MkLiftM a + -- Just add a bottom element under the domain +\end{code} + +Notice that @thenLft@ is strict in its first argument. + +\begin{code} +thenLft :: LiftM a -> (a -> b) -> b +(MkLiftM x) `thenLft` cont = cont x + +returnLft :: a -> LiftM a +returnLft a = MkLiftM a + +mapLft :: (a -> LiftM b) -> [a] -> LiftM [b] +mapLft f [] = returnLft [] +mapLft f (x:xs) + = f x `thenLft` \ x2 -> + mapLft f xs `thenLft` \ xs2 -> + returnLft (x2 : xs2) + +#endif +\end{code} diff --git a/ghc/compiler/utils/ListSetOps.hi b/ghc/compiler/utils/ListSetOps.hi new file mode 100644 index 0000000..d7e73e2 --- /dev/null +++ b/ghc/compiler/utils/ListSetOps.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface ListSetOps where +intersectLists :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-} +minusList :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +unionLists :: Eq a => [a] -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-} + diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs new file mode 100644 index 0000000..dbc749c --- /dev/null +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -0,0 +1,95 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[ListSetOps]{Set-like operations on lists} + +\begin{code} +module ListSetOps ( + unionLists, + intersectLists, + minusList +#if ! defined(COMPILING_GHC) + , disjointLists, intersectingLists +#endif + ) where + +#if defined(COMPILING_GHC) +import Util +# ifdef USE_ATTACK_PRAGMAS +import AbsUniType +import Id ( Id ) +# endif +#endif +\end{code} + +\begin{code} +unionLists :: (Eq a) => [a] -> [a] -> [a] +unionLists [] [] = [] +unionLists [] b = b +unionLists a [] = a +unionLists (a:as) b + | a `is_elem` b = unionLists as b + | otherwise = a : unionLists as b + where +#if defined(COMPILING_GHC) + is_elem = isIn "unionLists" +#else + is_elem = elem +#endif + +intersectLists :: (Eq a) => [a] -> [a] -> [a] +intersectLists [] [] = [] +intersectLists [] b = [] +intersectLists a [] = [] +intersectLists (a:as) b + | a `is_elem` b = a : intersectLists as b + | otherwise = intersectLists as b + where +#if defined(COMPILING_GHC) + is_elem = isIn "intersectLists" +#else + is_elem = elem +#endif +\end{code} + +Everything in the first list that is not in the second list: +\begin{code} +minusList :: (Eq a) => [a] -> [a] -> [a] +minusList xs ys = [ x | x <- xs, x `not_elem` ys] + where +#if defined(COMPILING_GHC) + not_elem = isn'tIn "minusList" +#else + not_elem = notElem +#endif +\end{code} + +\begin{code} +#if ! defined(COMPILING_GHC) + +disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool + +disjointLists [] bs = True +disjointLists (a:as) bs + | a `elem` bs = False + | otherwise = disjointLists as bs + +intersectingLists xs ys = not (disjointLists xs ys) +#endif +\end{code} + +\begin{code} +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS + +{-# SPECIALIZE unionLists :: [TyVar] -> [TyVar] -> [TyVar] #-} +{-# SPECIALIZE intersectLists :: [TyVar] -> [TyVar] -> [TyVar] #-} + +{-# SPECIALIZE minusList :: [TyVar] -> [TyVar] -> [TyVar], + [Id] -> [Id] -> [Id], + [Int] -> [Int] -> [Int] + #-} + +# endif +#endif +\end{code} diff --git a/ghc/compiler/utils/Maybes.hi b/ghc/compiler/utils/Maybes.hi new file mode 100644 index 0000000..d4c5c14 --- /dev/null +++ b/ghc/compiler/utils/Maybes.hi @@ -0,0 +1,31 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Maybes where +data Labda a = Hamna | Ni a +data MaybeErr a b = Succeeded a | Failed b +allMaybes :: [Labda a] -> Labda [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +assocMaybe :: Eq a => [(a, b)] -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ [Char], _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-} +catMaybes :: [Labda a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +failMaB :: b -> MaybeErr a b + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 2 1 X 2 _/\_ u0 u1 -> \ (u2 :: u1) -> _!_ _ORIG_ Maybes Failed [u0, u1] [u2] _N_ #-} +failMaybe :: Labda a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Maybes Hamna [u0] [] _N_ #-} +firstJust :: [Labda a] -> Labda a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +mapMaybe :: (a -> Labda b) -> [a] -> Labda [b] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +maybeToBool :: Labda a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 4 _/\_ u0 -> \ (u1 :: Labda u0) -> case u1 of { _ALG_ _ORIG_ Maybes Hamna -> _!_ False [] []; _ORIG_ Maybes Ni (u2 :: u0) -> _!_ True [] []; _NO_DEFLT_ } _N_ #-} +mkLookupFun :: (a -> a -> Bool) -> [(a, b)] -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-} +returnMaB :: a -> MaybeErr a b + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 2 1 X 2 _/\_ u0 u1 -> \ (u2 :: u0) -> _!_ _ORIG_ Maybes Succeeded [u0, u1] [u2] _N_ #-} +returnMaybe :: a -> Labda a + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ Maybes Ni [u0] [u1] _N_ #-} +thenMaB :: MaybeErr a c -> (a -> MaybeErr b c) -> MaybeErr b c + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _F_ _IF_ARGS_ 3 2 CX 6 _/\_ u0 u1 u2 -> \ (u3 :: MaybeErr u0 u2) (u4 :: u0 -> MaybeErr u1 u2) -> case u3 of { _ALG_ _ORIG_ Maybes Succeeded (u5 :: u0) -> _APP_ u4 [ u5 ]; _ORIG_ Maybes Failed (u6 :: u2) -> _!_ _ORIG_ Maybes Failed [u1, u2] [u6]; _NO_DEFLT_ } _N_ #-} +thenMaybe :: Labda a -> (a -> Labda b) -> Labda b + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _F_ _IF_ARGS_ 2 2 CX 5 _/\_ u0 u1 -> \ (u2 :: Labda u0) (u3 :: u0 -> Labda u1) -> case u2 of { _ALG_ _ORIG_ Maybes Hamna -> _!_ _ORIG_ Maybes Hamna [u1] []; _ORIG_ Maybes Ni (u4 :: u0) -> _APP_ u3 [ u4 ]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs new file mode 100644 index 0000000..66c1279 --- /dev/null +++ b/ghc/compiler/utils/Maybes.lhs @@ -0,0 +1,222 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Maybes]{The `Maybe' types and associated utility functions} + +\begin{code} +#if defined(COMPILING_GHC) +#include "HsVersions.h" +#endif + +module Maybes ( + Maybe(..), MaybeErr(..), + + allMaybes, -- GHCI only + assocMaybe, + catMaybes, + failMaB, + failMaybe, + firstJust, + mapMaybe, -- GHCI only + maybeToBool, + mkLookupFun, + returnMaB, + returnMaybe, -- GHCI only + thenMaB, + thenMaybe -- GHCI only + +#if ! defined(COMPILING_GHC) + , findJust + , foldlMaybeErrs + , listMaybeErrs +#endif + ) where + +#if defined(COMPILING_GHC) +import AbsUniType +import Id +import IdInfo +import Name +import Outputable +#if USE_ATTACK_PRAGMAS +import Util +#endif +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection[Maybe type]{The @Maybe@ type} +%* * +%************************************************************************ + +\begin{code} +#if __HASKELL1__ < 3 +data Maybe a + = Nothing + | Just a +#endif +\end{code} + +\begin{code} +maybeToBool :: Maybe a -> Bool +maybeToBool Nothing = False +maybeToBool (Just x) = True +\end{code} + +@catMaybes@ takes a list of @Maybe@s and returns a list of +the contents of all the @Just@s in it. @allMaybes@ collects +a list of @Justs@ into a single @Just@, returning @Nothing@ if there +are any @Nothings@. + +\begin{code} +catMaybes :: [Maybe a] -> [a] +catMaybes [] = [] +catMaybes (Nothing : xs) = catMaybes xs +catMaybes (Just x : xs) = (x : catMaybes xs) + +allMaybes :: [Maybe a] -> Maybe [a] +allMaybes [] = Just [] +allMaybes (Nothing : ms) = Nothing +allMaybes (Just x : ms) = case (allMaybes ms) of + Nothing -> Nothing + Just xs -> Just (x:xs) +\end{code} + +@firstJust@ takes a list of @Maybes@ and returns the +first @Just@ if there is one, or @Nothing@ otherwise. + +\begin{code} +firstJust :: [Maybe a] -> Maybe a +firstJust [] = Nothing +firstJust (Just x : ms) = Just x +firstJust (Nothing : ms) = firstJust ms +\end{code} + +\begin{code} +findJust :: (a -> Maybe b) -> [a] -> Maybe b +findJust f [] = Nothing +findJust f (a:as) = case f a of + Nothing -> findJust f as + b -> b +\end{code} + +@assocMaybe@ looks up in an assocation list, returning +@Nothing@ if it fails. + +\begin{code} +assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +#if defined(COMPILING_GHC) +{-# SPECIALIZE assocMaybe + :: [(String, b)] -> String -> Maybe b, + [(Id, b)] -> Id -> Maybe b, + [(Class, b)] -> Class -> Maybe b, + [(Int, b)] -> Int -> Maybe b, + [(Name, b)] -> Name -> Maybe b, + [(TyVar, b)] -> TyVar -> Maybe b, + [(TyVarTemplate, b)] -> TyVarTemplate -> Maybe b + #-} +#endif +\end{code} + +@mkLookupFun alist s@ is a function which looks up +@s@ in the association list @alist@, returning a Maybe type. + +\begin{code} +mkLookupFun :: (key -> key -> Bool) -- Equality predicate + -> [(key,val)] -- The assoc list + -> key -- The key + -> Maybe val -- The corresponding value + +mkLookupFun eq alist s + = case [a | (s',a) <- alist, s' `eq` s] of + [] -> Nothing + (a:_) -> Just a +\end{code} + +\begin{code} +#if __HASKELL1__ < 3 +thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b +m `thenMaybe` k = case m of + Nothing -> Nothing + Just a -> k a +#endif +returnMaybe :: a -> Maybe a +returnMaybe = Just + +failMaybe :: Maybe a +failMaybe = Nothing + +mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b] +mapMaybe f [] = returnMaybe [] +mapMaybe f (x:xs) = f x `thenMaybe` (\ x' -> + mapMaybe f xs `thenMaybe` (\ xs' -> + returnMaybe (x':xs') )) +\end{code} + +%************************************************************************ +%* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +%* * +%************************************************************************ + +\begin{code} +data MaybeErr val err = Succeeded val | Failed err +\end{code} + +\begin{code} +thenMaB :: MaybeErr val1 err -> (val1 -> MaybeErr val2 err) -> MaybeErr val2 err +thenMaB m k + = case m of + Succeeded v -> k v + Failed e -> Failed e + +returnMaB :: val -> MaybeErr val err +returnMaB v = Succeeded v + +failMaB :: err -> MaybeErr val err +failMaB e = Failed e +\end{code} + + +@listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed, returns +a @Succeeded@ of a list of their values. If any fail, it returns a +@Failed@ of the list of all the errors in the list. + +\begin{code} +listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err] +listMaybeErrs + = foldr combine (Succeeded []) + where + combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs) + combine (Failed err) (Succeeded _) = Failed [err] + combine (Succeeded v) (Failed errs) = Failed errs + combine (Failed err) (Failed errs) = Failed (err:errs) +\end{code} + +@foldlMaybeErrs@ works along a list, carrying an accumulator; it +applies the given function to the accumulator and the next list item, +accumulating any errors that occur. + +\begin{code} +foldlMaybeErrs :: (acc -> input -> MaybeErr acc err) + -> acc + -> [input] + -> MaybeErr acc [err] + +foldlMaybeErrs k accum ins = do_it [] accum ins + where + do_it [] acc [] = Succeeded acc + do_it errs acc [] = Failed errs + do_it errs acc (v:vs) = case (k acc v) of + Succeeded acc' -> do_it errs acc' vs + Failed err -> do_it (err:errs) acc vs +\end{code} diff --git a/ghc/compiler/utils/Outputable.hi b/ghc/compiler/utils/Outputable.hi new file mode 100644 index 0000000..8b67652 --- /dev/null +++ b/ghc/compiler/utils/Outputable.hi @@ -0,0 +1,100 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Outputable where +import CharSeq(CSeq) +import Class(Class) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import Pretty(Delay, PprStyle(..), Pretty(..), PrettyRep) +import SrcLoc(SrcLoc) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import UniType(UniType) +import Unique(Unique) +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> ExportFlag) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AASAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> (_PackedString, _PackedString)) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> _PackedString) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [_PackedString]) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> SrcLoc) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAASAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Unique) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> UniType) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAS)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data ExportFlag = ExportAll | ExportAbs | NotExported +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +getLocalName :: NamedThing a => a -> _PackedString + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AASAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: u0 -> (_PackedString, _PackedString)) (u2 :: u0) -> case _APP_ u1 [ u2 ] of { _ALG_ _TUP_2 (u3 :: _PackedString) (u4 :: _PackedString) -> u4; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> case u1 of { _ALG_ _TUP_10 (u3 :: u0 -> ExportFlag) (u4 :: u0 -> Bool) (u5 :: u0 -> (_PackedString, _PackedString)) (u6 :: u0 -> _PackedString) (u7 :: u0 -> [_PackedString]) (u8 :: u0 -> SrcLoc) (u9 :: u0 -> Unique) (ua :: u0 -> Bool) (ub :: u0 -> UniType) (uc :: u0 -> Bool) -> case _APP_ u5 [ u2 ] of { _ALG_ _TUP_2 (ud :: _PackedString) (ue :: _PackedString) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _SPECIALISE_ [ ShortName ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: _PackedString) -> case _APP_ _WRKR_ _CONSTM_ NamedThing getOrigName (ShortName) [ u0 ] of { _ALG_ _TUP_2 (u1 :: _PackedString) (u2 :: _PackedString) -> u2; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> case _APP_ _WRKR_ _CONSTM_ NamedThing getOrigName (ShortName) [ u1 ] of { _ALG_ _TUP_2 (u3 :: _PackedString) (u4 :: _PackedString) -> u4; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +ifPprDebug :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprDebug -> u1; (u2 :: PprStyle) -> \ (u3 :: Int) (u4 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u3 ] } _N_ #-} +ifPprInterface :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprInterface (u2 :: GlobalSwitch -> Bool) -> u1; (u3 :: PprStyle) -> \ (u4 :: Int) (u5 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u4 ] } _N_ #-} +ifPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprShowAll -> u1; (u2 :: PprStyle) -> \ (u3 :: Int) (u4 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u3 ] } _N_ #-} +ifnotPprForUser :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprForUser -> \ (u2 :: Int) (u3 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u2 ]; (u4 :: PprStyle) -> u1 } _N_ #-} +ifnotPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprShowAll -> \ (u2 :: Int) (u3 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u2 ]; (u4 :: PprStyle) -> u1 } _N_ #-} +interpp'SP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ Id ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ UniType ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ }, [ ProtoName ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ (Id, Id) ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ } #-} +interppSP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ Id ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ } #-} +isAconop :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isAvarid :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isAvarop :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isConop :: _PackedString -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +isExported :: NamedThing a => a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(SAAAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ }, [ Class ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ExportFlag) -> case u0 of { _ALG_ _ORIG_ Outputable NotExported -> _!_ False [] []; (u1 :: ExportFlag) -> _!_ True [] [] } _N_} _N_ _N_ } #-} +isOpLexeme :: NamedThing a => a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ } #-} +ltLexical :: (NamedThing a, NamedThing b) => a -> b -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "U(ASSAAAAAAA)U(ALSAAAAAAA)LL" {_A_ 5 _U_ 11122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id, Id ] 2 { _A_ 2 _U_ 11 _N_ _S_ "U(LAAS)U(LAAS)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon, TyCon ] 2 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Class, Class ] 2 { _A_ 2 _U_ 11 _N_ _S_ "U(AU(LLSAAA)AAAAAAAA)U(AU(LLLAAA)AAAAAAAA)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +pprNonOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 122222 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 4 _U_ 112222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 2 { _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 2 { _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ } #-} +pprOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 122222 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 4 _U_ 112222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 2 { _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +instance (Outputable a, Outputable b) => Outputable (a, b) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-} +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-} +instance Outputable Bool + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_ + ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +instance Outputable a => Outputable [a] + {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs new file mode 100644 index 0000000..2e9a382 --- /dev/null +++ b/ghc/compiler/utils/Outputable.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP Project, Glasgow University, 1992-1995 +% +\section[Outputable]{Classes for pretty-printing} + +Defines classes for pretty-printing and forcing, both forms of +``output.'' + +\begin{code} +#include "HsVersions.h" + +module Outputable ( + -- NAMED-THING-ERY + NamedThing(..), -- class + ExportFlag(..), + isExported, getLocalName, ltLexical, + + -- PRINTERY AND FORCERY + Outputable(..), -- class + PprStyle(..), -- style-ry (re-exported) + + interppSP, interpp'SP, +--UNUSED: ifPprForUser, + ifnotPprForUser, + ifPprDebug, --UNUSED: ifnotPprDebug, + ifPprShowAll, ifnotPprShowAll, + ifPprInterface, --UNUSED: ifnotPprInterface, +--UNUSED: ifPprForC, ifnotPprForC, +--UNUSED: ifPprUnfolding, ifnotPprUnfolding, + + isOpLexeme, pprOp, pprNonOp, + isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid, + + -- and to make the interface self-sufficient... + Pretty(..), GlobalSwitch, + PrettyRep, UniType, Unique, SrcLoc + ) where + +import AbsUniType ( UniType, + TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + IF_ATTACK_PRAGMAS(COMMA cmpTyVar) + IF_ATTACK_PRAGMAS(COMMA cmpTyCon) + ) +import Id ( Id ) -- for specialising +import NameTypes -- for specialising +import ProtoName -- for specialising +import Pretty +import SrcLoc ( SrcLoc ) +import Unique ( Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[NamedThing-class]{The @NamedThing@ class} +%* * +%************************************************************************ + +\begin{code} +class NamedThing a where + getExportFlag :: a -> ExportFlag + isLocallyDefined :: a -> Bool + getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-}) + getOccurrenceName :: a -> FAST_STRING + getInformingModules :: a -> [FAST_STRING] + getSrcLoc :: a -> SrcLoc + getTheUnique :: a -> Unique + hasType :: a -> Bool + getType :: a -> UniType + fromPreludeCore :: a -> Bool + -- see also friendly functions that follow... +\end{code} + +\begin{description} +\item[@getExportFlag@:] +Obvious. + +\item[@getOrigName@:] +Obvious. + +\item[@isLocallyDefined@:] +Whether the thing is defined in this module or not. + +\item[@getOccurrenceName@:] +Gets the name by which a thing is known in this module (e.g., if +renamed, or whatever)... + +\item[@getInformingModules@:] +Gets the name of the modules that told me about this @NamedThing@. + +\item[@getSrcLoc@:] +Obvious. + +\item[@hasType@ and @getType@:] +In pretty-printing @AbsSyntax@, we need to query if a datatype has +types attached yet or not. We use @hasType@ to see if there are types +available; and @getType@ if we want to grab one... (Ugly but effective) + +\item[@fromPreludeCore@:] +Tests a quite-delicate property: it is \tr{True} iff the entity is +actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if +it is re-exported by \tr{PreludeCore}. See the @FullName@ type in +module \tr{NameTypes}. + +NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test. +This is a bummer for types that are wired into the compiler. +\end{description} + +Some functions to go with: +\begin{code} +isExported a + = case (getExportFlag a) of + NotExported -> False + _ -> True + +getLocalName :: (NamedThing a) => a -> FAST_STRING + +getLocalName = snd . getOrigName + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isExported :: Class -> Bool #-} +{-# SPECIALIZE isExported :: Id -> Bool #-} +{-# SPECIALIZE isExported :: TyCon -> Bool #-} +{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-} +#endif +\end{code} + +@ltLexical@ is used for sorting things into lexicographical order, so +as to canonicalize interfaces. [Regular @(<)@ should be used for fast +comparison.] + +\begin{code} +a `ltLexical` b + = BIND isLocallyDefined a _TO_ a_local -> + BIND isLocallyDefined b _TO_ b_local -> + BIND getOrigName a _TO_ (a_mod, a_name) -> + BIND getOrigName b _TO_ (b_mod, b_name) -> + if a_local || b_local then + a_name < b_name -- can't compare module names + else + case _CMP_STRING_ a_mod b_mod of + LT_ -> True + EQ_ -> a_name < b_name + GT__ -> False + BEND BEND BEND BEND + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-} +{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-} +{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-} +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +%* * +%************************************************************************ + +The export flag @ExportAll@ means `export all there is', so there are +times when it is attached to a class or data type which has no +ops/constructors (if the class/type was imported abstractly). In +fact, @ExportAll@ is attached to everything except to classes/types +which are being {\em exported} abstractly, regardless of how they were +imported. + +\begin{code} +data ExportFlag + = ExportAll -- export with all constructors/methods + | ExportAbs -- export abstractly + | NotExported +\end{code} + +%************************************************************************ +%* * +\subsection[Outputable-class]{The @Outputable@ class} +%* * +%************************************************************************ + +\begin{code} +class Outputable a where + ppr :: PprStyle -> a -> Pretty +\end{code} + +\begin{code} +-- the ppSep in the ppInterleave puts in the spaces +-- Death to ppSep! (WDP 94/11) + +interppSP :: Outputable a => PprStyle -> [a] -> Pretty +interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs) + +interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty +interpp'SP sty xs + = ppInterleave sep (map (ppr sty) xs) + where + sep = ppBeside ppComma ppSP + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-} +{-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-} + +{-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-} +{-# SPECIALIZE interpp'SP :: PprStyle -> [UniType] -> Pretty #-} +#endif +\end{code} + +\begin{code} +--UNUSED: ifPprForUser sty p = case sty of PprForUser -> p ; _ -> ppNil +ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil +ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil +ifPprInterface sty p = case sty of PprInterface _ -> p ; _ -> ppNil +--UNUSED: ifPprForC sty p = case sty of PprForC _ -> p ; _ -> ppNil +--UNUSED: ifPprUnfolding sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil + +ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p +--UNUSED: ifnotPprDebug sty p = case sty of PprDebug -> ppNil ; _ -> p +ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p +--UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p +--UNUSED: ifnotPprForC sty p = case sty of PprForC _ -> ppNil; _ -> p +--UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> ppNil; _ -> p +\end{code} + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. Normally applied as in, e.g., +@isConop (getOccurrenceName foo)@... [just for pretty-printing] + +\begin{code} +isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool + +isConop cs + | _NULL_ cs = False + | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s + | otherwise = isUpper c || c == ':' + where + c = _HEAD_ cs + +{- UNUSED: +isAconid [] = False +isAconid ('_':cs) = isAconid cs +isAconid (c:cs) = isUpper c +-} + +isAconop cs + | _NULL_ cs = False + | otherwise = c == ':' + where + c = _HEAD_ cs + +isAvarid cs + | _NULL_ cs = False + | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s + | otherwise = isLower c + where + c = _HEAD_ cs + +isAvarop cs + | _NULL_ cs = False + | isLower c = False -- shortcut + | isUpper c = False -- ditto + | otherwise = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus + where + c = _HEAD_ cs +\end{code} + +And one ``higher-level'' interface to those: + +\begin{code} +isOpLexeme :: NamedThing a => a -> Bool + +isOpLexeme v + = let str = getOccurrenceName v in isAvarop str || isAconop str + +-- print `vars`, (op) correctly +pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty + +pprOp sty var + = if isOpLexeme var + then ppr sty var + else ppBesides [ppChar '`', ppr sty var, ppChar '`'] + +pprNonOp sty var + = if isOpLexeme var + then ppBesides [ppLparen, ppr sty var, ppRparen] + else ppr sty var + +#ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isOpLexeme :: Id -> Bool #-} +{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-} +{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-} +{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-} +#endif +\end{code} + +\begin{code} +instance Outputable Bool where + ppr sty True = ppPStr SLIT("True") + ppr sty False = ppPStr SLIT("False") + +instance (Outputable a) => Outputable [a] where + ppr sty xs = + ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ] + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr sty (x,y) = + ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen) + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr sty (x,y,z) = + ppSep [ ppBesides [ppLparen, ppr sty x, ppComma], + ppBeside (ppr sty y) ppComma, + ppBeside (ppr sty z) ppRparen ] +\end{code} diff --git a/ghc/compiler/utils/Pretty.hi b/ghc/compiler/utils/Pretty.hi new file mode 100644 index 0000000..50f7652 --- /dev/null +++ b/ghc/compiler/utils/Pretty.hi @@ -0,0 +1,81 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Pretty where +import CharSeq(CSeq) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Stdio(_FILE) +import Unpretty(Unpretty(..)) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data Delay a {-# GHC_PRAGMA MkDelay a #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep = MkPrettyRep CSeq (Delay Int) Bool Bool +type Unpretty = CSeq +codeStyle :: PprStyle -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: PprStyle) -> case u0 of { _ALG_ _ORIG_ Pretty PprForC (u1 :: GlobalSwitch -> Bool) -> _!_ True [] []; _ORIG_ Pretty PprForAsm (u2 :: GlobalSwitch -> Bool) (u3 :: Bool) (u4 :: [Char] -> [Char]) -> _!_ True [] []; (u5 :: PprStyle) -> _!_ False [] [] } _N_ #-} +pp'SP :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ Pretty ppStr [ _NOREP_S_ ", " ] _N_ #-} +ppAbove :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 1120 _N_ _S_ "SLLA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppAboves :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [Int -> Bool -> PrettyRep]) -> case u0 of { _ALG_ (:) (u1 :: Int -> Bool -> PrettyRep) (u2 :: [Int -> Bool -> PrettyRep]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { (Int -> Bool -> PrettyRep) } [ _ORIG_ Pretty ppAbove, u0 ]; _NIL_ -> _ORIG_ Pretty ppNil; _NO_DEFLT_ } _N_ #-} +ppAppendFile :: _FILE -> Int -> (Int -> Bool -> PrettyRep) -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _S_ "U(P)LSL" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppBeside :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 1120 _N_ _S_ "SLLA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppBesides :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [Int -> Bool -> PrettyRep]) -> case u0 of { _ALG_ (:) (u1 :: Int -> Bool -> PrettyRep) (u2 :: [Int -> Bool -> PrettyRep]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { (Int -> Bool -> PrettyRep) } [ _ORIG_ Pretty ppBeside, u0 ]; _NIL_ -> _ORIG_ Pretty ppNil; _NO_DEFLT_ } _N_ #-} +ppCat :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-} +ppChar :: Char -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppComma :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppDouble :: Double -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppEquals :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppFloat :: Float -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 210 _N_ _N_ _N_ _N_ #-} +ppHang :: (Int -> Bool -> PrettyRep) -> Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 12222 _N_ _S_ "SLLLL" _N_ _N_ #-} +ppInt :: Int -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 110 _N_ _S_ "LLA" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppInteger :: Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppInterleave :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +ppIntersperse :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-} +ppLbrack :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppLparen :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppNest :: Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLE" _N_ _N_ #-} +ppNil :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "LA" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppPStr :: _PackedString -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppRbrack :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppRparen :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppSP :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppSemi :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-} +ppSep :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-} +ppShow :: Int -> (Int -> Bool -> PrettyRep) -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +ppStr :: [Char] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +prettyToUn :: (Int -> Bool -> PrettyRep) -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs new file mode 100644 index 0000000..f416925 --- /dev/null +++ b/ghc/compiler/utils/Pretty.lhs @@ -0,0 +1,439 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Pretty]{Pretty-printing data type} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +#else +# define FAST_STRING String +# define _LENGTH_ length +#endif + +module Pretty ( + Pretty(..), + +#if defined(COMPILING_GHC) + PprStyle(..), + prettyToUn, + codeStyle, -- UNUSED: stySwitch, +#endif + ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger, + ppFloat, ppDouble, +#if __GLASGOW_HASKELL__ >= 23 + -- may be able to *replace* ppDouble + ppRational, +#endif + ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, + ppSemi, ppComma, ppEquals, + + ppCat, ppBeside, ppBesides, ppAbove, ppAboves, + ppNest, ppSep, ppHang, ppInterleave, ppIntersperse, + ppShow, +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 + ppAppendFile, +#endif + + -- abstract type, to complete the interface... + PrettyRep(..), CSeq, Delay +#if defined(COMPILING_GHC) + , GlobalSwitch, Unpretty(..) +#endif + ) where + +import CharSeq +#if defined(COMPILING_GHC) +import Unpretty ( Unpretty(..) ) +import CmdLineOpts ( GlobalSwitch ) +#endif +\end{code} + +Based on John Hughes's pretty-printing library. For now, that code +and notes for it are in files \tr{pp-rjmh*} (ToDo: rm). + +%************************************************ +%* * + \subsection{The interface} +%* * +%************************************************ + +\begin{code} +ppNil :: Pretty +ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty + +ppStr :: [Char] -> Pretty +ppPStr :: FAST_STRING -> Pretty +ppChar :: Char -> Pretty +ppInt :: Int -> Pretty +ppInteger :: Integer -> Pretty +ppDouble :: Double -> Pretty +ppFloat :: Float -> Pretty +#if __GLASGOW_HASKELL__ >= 23 +ppRational :: Rational -> Pretty +#endif + +ppBeside :: Pretty -> Pretty -> Pretty +ppBesides :: [Pretty] -> Pretty +ppBesideSP :: Pretty -> Pretty -> Pretty +ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP + +ppAbove :: Pretty -> Pretty -> Pretty +ppAboves :: [Pretty] -> Pretty + +ppInterleave :: Pretty -> [Pretty] -> Pretty +ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep +ppSep :: [Pretty] -> Pretty +ppHang :: Pretty -> Int -> Pretty -> Pretty +ppNest :: Int -> Pretty -> Pretty + +ppShow :: Int -> Pretty -> [Char] + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 +# if __GLASGOW_HASKELL__ < 23 +# define _FILE _Addr +# endif +ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO () +#endif +\end{code} + +%************************************************ +%* * + \subsection{The representation} +%* * +%************************************************ + +\begin{code} +type Pretty = Int -- The width to print in + -> Bool -- True => vertical context + -> PrettyRep + +data PrettyRep + = MkPrettyRep CSeq -- The text + (Delay Int) -- No of chars in last line + Bool -- True if empty object + Bool -- Fits on a single line in specified width + +data Delay a = MkDelay a + +forceDel (MkDelay _) r = r + +forceBool True r = r +forceBool False r = r + +forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r)) + +ppShow width p + = case (p width False) of + MkPrettyRep seq ll emp sl -> cShow seq + +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22 +ppAppendFile f width p + = case (p width False) of + MkPrettyRep seq ll emp sl -> cAppendFile f seq +#endif + +ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0) + -- Doesn't fit if width < 0, otherwise, ppNil + -- will make ppBesides always return True. + +ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) + where ls = length s +ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls) + where ls = _LENGTH_ s +ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1) + +ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) + where s = show n; ls = length s + +ppInteger n = ppStr (show n) +ppDouble n = ppStr (show n) +ppFloat n = ppStr (show n) +#if __GLASGOW_HASKELL__ >= 23 +--ppRational n = ppStr (_showRational 30 n) +ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n) +#endif + +ppSP = ppChar ' ' +pp'SP = ppStr ", " +ppLbrack = ppChar '[' +ppRbrack = ppChar ']' +ppLparen = ppChar '(' +ppRparen = ppChar ')' +ppSemi = ppChar ';' +ppComma = ppChar ',' +ppEquals = ppChar '=' + +ppInterleave sep ps = ppSep (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (ppBeside x sep) : pi xs +\end{code} + +ToDo: this could be better: main pt is: no extra spaces in between. + +\begin{code} +ppIntersperse sep ps = ppBesides (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (ppBeside x sep) : pi xs +\end{code} + +Laziness is important in @ppBeside@. If the first thing is not a +single line it will return @False@ for the single-line boolean without +laying out the second. + +\begin{code} +ppBeside p1 p2 width is_vert + = case (p1 width False) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2)) + (MkDelay (ll1 + ll2)) + (emp1 && emp2) + ((width >= 0) && (sl1 && sl2)) + -- This sequence of (&&)'s ensures that ppBeside + -- returns a False for sl as soon as possible. + where -- NB: for case alt + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False + -- ToDo: if emp{1,2} then we really + -- should be passing on "is_vert" to p{2,1}. + +ppBesides [] = ppNil +ppBesides ps = foldr1 ppBeside ps +\end{code} + +@ppBesideSP@ puts two things beside each other separated by a space. + +\begin{code} +ppBesideSP p1 p2 width is_vert + = case (p1 width False) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2))) + (MkDelay (li + ll2)) + (emp1 && emp2) + ((width >= wi) && (sl1 && sl2)) + where -- NB: for case alt + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False + li, wi :: Int + li = if emp1 then 0 else ll1+1 + wi = if emp1 then 0 else 1 + sp = if emp1 || emp2 then cNil else (cCh ' ') +\end{code} + +@ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@. + +\begin{code} +ppCat [] = ppNil +ppCat ps = foldr1 ppBesideSP ps +\end{code} + +\begin{code} +ppAbove p1 p2 width is_vert + = case (p1 width True) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2)) + (MkDelay ll2) + -- ToDo: make ll depend on empties? + (emp1 && emp2) + False + where -- NB: for case alt + nl = if emp1 || emp2 then cNil else cNL + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 -- Don't "optimise" this away! + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True + -- ToDo: ditto about passing is_vert if empties + +ppAboves [] = ppNil +ppAboves ps = foldr1 ppAbove ps +\end{code} + +\begin{code} +ppNest n p width False = p width False +ppNest n p width True + = case (p (width-n) True) of + MkPrettyRep seq (MkDelay ll) emp sl -> + MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl +\end{code} + +The length-check below \tr{(ll1+ll2+1) <= width} should really check for +max widths not the width of the last line. + +\begin{code} +ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could + -- be made with a little more effort. + -- Eg the output always starts with seq1 + = case (p1 width False) of + MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> + if emp1 then + p2 width is_vert + else + if (ll1 <= n) || sl2 then -- very ppBesideSP'ish + -- Hang it if p1 shorter than indent or if it doesn't fit + MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2))) + (MkDelay (ll1 + 1 + ll2)) + False + (sl1 && sl2) + else + -- Nest it (pretty ppAbove-ish) + MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2'))) + (MkDelay ll2') -- ToDo: depend on empties + False + False + where -- NB: for case alt + seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 + MkDelay ll2 = x_ll2 + MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False + -- ToDo: more "is_vert if empty" stuff + + seq2' = forceInfo x_ll2' emp2' sl2' x_seq2' + MkDelay ll2' = x_ll2' -- Don't "optimise" this away! + MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True? +\end{code} + +\begin{code} +ppSep [] width is_vert = ppNil width is_vert +ppSep [p] width is_vert = p width is_vert + +-- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable +-- ppSep [a, ppSep[b, ppSep [c, ... ]]] + +ppSep ps width is_vert + = case (ppCat ps width is_vert) of + MkPrettyRep seq x_ll emp sl -> + if sl then -- Fits on one line + MkPrettyRep seq x_ll emp sl + else + ppAboves ps width is_vert -- Takes several lines +\end{code} + +%************************************************************************ +%* * +\subsection[Outputable-print]{Pretty-printing stuff} +%* * +%************************************************************************ + +ToDo: this is here for no-original-name reasons (mv?). + +There is no clearly definitive list of @PprStyles@; I suggest the +following: + +\begin{code} +#if defined(COMPILING_GHC) + -- to the end of file + +data PprStyle + = PprForUser -- Pretty-print in a way that will + -- make sense to the ordinary user; + -- must be very close to Haskell + -- syntax, etc. ToDo: how diff is + -- this from what pprInterface must + -- do? + | PprDebug -- Standard debugging output + | PprShowAll -- Debugging output which leaves + -- nothing to the imagination + | PprInterface -- Interface generation + (GlobalSwitch -> Bool) -- (we can look at cmd-line flags) + | PprForC -- must print out C-acceptable names + (GlobalSwitch -> Bool) -- (ditto) + | PprUnfolding -- for non-interface intermodule info + (GlobalSwitch -> Bool) -- the compiler writes/reads + | PprForAsm -- must print out assembler-acceptable names + (GlobalSwitch -> Bool) -- (ditto) + Bool -- prefix CLabel with underscore? + (String -> String) -- format AsmTempLabel +\end{code} + +The following test decides whether or not we are actually generating +code (either C or assembly). +\begin{code} +codeStyle :: PprStyle -> Bool +codeStyle (PprForC _) = True +codeStyle (PprForAsm _ _ _) = True +codeStyle _ = False + +{- UNUSED: +stySwitch :: PprStyle -> GlobalSwitch -> Bool +stySwitch (PprInterface sw) = sw +stySwitch (PprForC sw) = sw +stySwitch (PprForAsm sw _ _) = sw +-} +\end{code} + +Orthogonal to these printing styles are (possibly) some command-line +flags that affect printing (often carried with the style). The most +likely ones are variations on how much type info is shown. + +\begin{code} +prettyToUn :: Pretty -> Unpretty + +prettyToUn p + = case (p 999999{-totally bogus width-} False{-also invented-}) of + MkPrettyRep seq ll emp sl -> seq + +#endif {-COMPILING_GHC-} +\end{code} + +----------------------------------- +\begin{code} +-- from Lennart +fromRationalX :: (RealFloat a) => Rational -> a + +fromRationalX r = + let + h = ceiling (huge `asTypeOf` x) + b = toInteger (floatRadix x) + x = fromRat 0 r + fromRat e0 r' = + let d = denominator r' + n = numerator r' + in if d > h then + let e = integerLogBase b (d `div` h) + 1 + in fromRat (e0-e) (n % (d `div` (b^e))) + else if abs n > h then + let e = integerLogBase b (abs n `div` h) + 1 + in fromRat (e0+e) ((n `div` (b^e)) % d) + else + scaleFloat e0 (fromRational r') + in x + +-- Compute the discrete log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, but that would +-- be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i = + if i < b then + 0 + else + -- Try squaring the base first to cut down the number of divisions. + let l = 2 * integerLogBase (b*b) i + + doDiv :: Integer -> Int -> Int + doDiv j k = if j < b then k else doDiv (j `div` b) (k+1) + in + doDiv (i `div` (b^l)) l + + +------------ + +-- Compute smallest and largest floating point values. +{- +tiny :: (RealFloat a) => a +tiny = + let (l, _) = floatRange x + x = encodeFloat 1 (l-1) + in x +-} + +huge :: (RealFloat a) => a +huge = + let (_, u) = floatRange x + d = floatDigits x + x = encodeFloat (floatRadix x ^ d - 1) (u - d) + in x +\end{code} diff --git a/ghc/compiler/utils/UniqFM.hi b/ghc/compiler/utils/UniqFM.hi new file mode 100644 index 0000000..6947486 --- /dev/null +++ b/ghc/compiler/utils/UniqFM.hi @@ -0,0 +1,59 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UniqFM where +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Maybes(Labda) +import NameTypes(ShortName) +import Outputable(NamedThing) +import TyVar(TyVar) +import UniType(UniType) +import Unique(Unique, u2i) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +addToUFM_Directly :: UniqFM a -> Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "SU(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +isNullUFM :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: UniqFM u0) -> case u1 of { _ALG_ _ORIG_ UniqFM EmptyUFM -> _!_ True [] []; (u2 :: UniqFM u0) -> _!_ False [] [] } _N_ #-} +listToUFM :: NamedThing a => [(a, b)] -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +listToUFM_Directly :: [(Unique, a)] -> UniqFM a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +lookupDirectlyUFM :: UniqFM a -> Unique -> Labda a + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +mapUFM :: (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +minusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-} +singletonDirectlyUFM :: Unique -> a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-} +singletonUFM :: NamedThing a => a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +sizeUFM :: UniqFM a -> Int + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +ufmToList :: UniqFM a -> [(Unique, a)] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs new file mode 100644 index 0000000..92839cb --- /dev/null +++ b/ghc/compiler/utils/UniqFM.lhs @@ -0,0 +1,881 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[UniqFM]{Specialised finite maps, for things with @Uniques@} + +Based on @FiniteMaps@ (as you would expect). + +Basically, the things need to be in class @NamedThing@, and we use the +@getTheUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +@IdEnv@ and @TyVarEnv@ are the (backward-compatible?) specialisations +of this stuff for Ids and TyVars, respectively. + +\begin{code} +#if defined(COMPILING_GHC) +#include "HsVersions.h" +#define IF_NOT_GHC(a) {--} +#else +#define ASSERT(e) {--} +#define IF_NOT_GHC(a) a +#endif + +module UniqFM ( + UniqFM, -- abstract type + + emptyUFM, + singletonUFM, + singletonDirectlyUFM, + listToUFM, + listToUFM_Directly, + addToUFM, + IF_NOT_GHC(addListToUFM COMMA) + addToUFM_Directly, + IF_NOT_GHC(addToUFM_C COMMA) + IF_NOT_GHC(addListToUFM_C COMMA) + delFromUFM, + delListFromUFM, + plusUFM, + plusUFM_C, + minusUFM, + intersectUFM, + IF_NOT_GHC(intersectUFM_C COMMA) + IF_NOT_GHC(foldUFM COMMA) + mapUFM, + filterUFM, + sizeUFM, + isNullUFM, + lookupUFM, + lookupDirectlyUFM, + IF_NOT_GHC(lookupWithDefaultUFM COMMA) + eltsUFM, + ufmToList, + + -- to make the interface self-sufficient + Id, TyVar, Unique + IF_ATTACK_PRAGMAS(COMMA u2i) -- profiling + ) where + +import AbsUniType -- for specialisation to TyVars +import Id -- for specialisation to Ids +import IdInfo -- sigh +import Maybes ( maybeToBool, Maybe(..) ) +import Name +import Outputable +import Unique ( u2i, mkUniqueGrimily, Unique ) +import Util +#if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +#define IF_NCG(a) a +#else +#define IF_NCG(a) {--} +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +We use @FiniteMaps@, with a (@getTheUnique@-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 + :: Unique -> elt -> UniqFM elt +listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt +listToUFM_Directly + :: [(Unique, elt)] -> UniqFM elt + +addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt +addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addToUFM_Directly + :: UniqFM elt -> Unique -> elt -> UniqFM elt + +addToUFM_C :: NamedThing key => (elt -> elt -> elt) + -> UniqFM elt -> key -> elt -> UniqFM elt +addListToUFM_C :: NamedThing key => (elt -> elt -> elt) + -> UniqFM elt -> [(key,elt)] + -> UniqFM elt + +delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt +delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> UniqFM elt + +plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt + +plusUFM_C :: (elt -> elt -> elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt + +minusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt + +intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +intersectUFM_C :: (elt -> elt -> elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt + +sizeUFM :: UniqFM elt -> Int + +lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt +lookupDirectlyUFM -- when you've got the Unique already + :: UniqFM elt -> Unique -> Maybe elt +lookupWithDefaultUFM + :: NamedThing key => UniqFM elt -> elt -> key -> elt + +eltsUFM :: UniqFM elt -> [elt] +ufmToList :: UniqFM elt -> [(Unique, elt)] +\end{code} + +%************************************************************************ +%* * +\subsection{The @IdFinMap@ and @TyVarFinMap@ specialisations for Ids/TyVars} +%* * +%************************************************************************ + +\begin{code} +type IdFinMap elt = UniqFM elt +type TyVarFinMap elt = UniqFM elt +type NameFinMap elt = UniqFM elt +type RegFinMap elt = UniqFM elt +\end{code} + +\begin{code} +#ifdef __GLASGOW_HASKELL__ +-- I don't think HBC was too happy about this (WDP 94/10) + +{-# SPECIALIZE + singletonUFM :: Id -> elt -> IdFinMap elt, + TyVar -> elt -> TyVarFinMap elt, + Name -> elt -> NameFinMap elt + IF_NCG(COMMA Reg -> elt -> RegFinMap elt) + #-} +{-# SPECIALIZE + listToUFM :: [(Id, elt)] -> IdFinMap elt, + [(TyVar,elt)] -> TyVarFinMap elt, + [(Name, elt)] -> NameFinMap elt + IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt) + #-} +{-# SPECIALIZE + addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt, + TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt, + NameFinMap elt -> Name -> elt -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt) + #-} +{-# SPECIALIZE + addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt, + TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt, + NameFinMap elt -> [(Name,elt)] -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt) + #-} +{-# SPECIALIZE + addToUFM_C :: (elt -> elt -> elt) + -> IdFinMap elt -> Id -> elt -> IdFinMap elt, + (elt -> elt -> elt) + -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt, + (elt -> elt -> elt) + -> NameFinMap elt -> Name -> elt -> NameFinMap elt + IF_NCG(COMMA (elt -> elt -> elt) + -> RegFinMap elt -> Reg -> elt -> RegFinMap elt) + #-} +{-# SPECIALIZE + addListToUFM_C :: (elt -> elt -> elt) + -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt, + (elt -> elt -> elt) + -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt, + (elt -> elt -> elt) + -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt + IF_NCG(COMMA (elt -> elt -> elt) + -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt) + #-} +{-# SPECIALIZE + delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt, + TyVarFinMap elt -> TyVar -> TyVarFinMap elt, + NameFinMap elt -> Name -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt) + #-} +{-# SPECIALIZE + delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt, + TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt, + NameFinMap elt -> [Name] -> NameFinMap elt + IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt) + #-} + +{-# SPECIALIZE + lookupUFM :: IdFinMap elt -> Id -> Maybe elt, + TyVarFinMap elt -> TyVar -> Maybe elt, + NameFinMap elt -> Name -> Maybe elt + IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt) + #-} +{-# SPECIALIZE + lookupWithDefaultUFM + :: IdFinMap elt -> elt -> Id -> elt, + TyVarFinMap elt -> elt -> TyVar -> elt, + NameFinMap elt -> elt -> Name -> elt + IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt) + #-} + +#endif {- __GLASGOW_HASKELL__ -} +\end{code} + +%************************************************************************ +%* * +\subsection{Andy Gill's underlying @UniqFM@ machinery} +%* * +%************************************************************************ + +``Uniq Finite maps'' are the heart and soul of the compiler's +lookup-tables/environments. Important stuff! It works well with +Dense and Sparse ranges. +Both @Uq@ Finite maps and @Hash@ Finite Maps +are built ontop of Int Finite Maps. + +This code is explained in the paper: +\begin{display} + A Gill, S Peyton Jones, B O'Sullivan, W Partain and Aqua Friends + "A Cheap balancing act that grows on a tree" + Glasgow FP Workshop, Sep 1994, pp??-?? +\end{display} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +@UniqFM a@ is a mapping from Unique to a. + +First, the DataType itself; which is either a Node, a Leaf, or an Empty. + +\begin{code} +data UniqFM ele + = EmptyUFM + | LeafUFM FAST_INT ele + | NodeUFM FAST_INT -- the switching + FAST_INT -- the delta + (UniqFM ele) + (UniqFM ele) + +-- for debugging only :-) +{- +instance Text (UniqFM a) where + showsPrec _ (NodeUFM a b t1 t2) = + showString "NodeUFM " . shows (IBOX(a)) + . showString " " . shows (IBOX(b)) + . showString " (" . shows t1 + . showString ") (" . shows t2 + . showString ")" + showsPrec _ (LeafUFM x a) = showString "LeafUFM " . shows (IBOX(x)) + showsPrec _ (EmptyUFM) = id +-} +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ functions} +%* * +%************************************************************************ + +First the ways of building a UniqFM. + +\begin{code} +emptyUFM = EmptyUFM +singletonUFM key elt = mkLeafUFM (u2i (getTheUnique key)) elt +singletonDirectlyUFM key elt = mkLeafUFM (u2i key) elt + +listToUFM key_elt_pairs + = addListToUFM_C use_snd EmptyUFM key_elt_pairs + +listToUFM_Directly uniq_elt_pairs + = addListToUFM_directly_C use_snd EmptyUFM uniq_elt_pairs +\end{code} + +Now ways of adding things to UniqFMs. + +There is an alternative version of @addListToUFM_C@, that uses @plusUFM@, +but the semantics of this operation demands a linear insertion; +perhaps the version without the combinator function +could be optimised using it. + +\begin{code} +addToUFM fm key elt = addToUFM_C use_snd fm key elt + +addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt + +addToUFM_C combiner fm key elt + = insert_ele combiner fm (u2i (getTheUnique key)) elt + +addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs + +addListToUFM_C combiner fm key_elt_pairs + = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getTheUnique k)) e) + fm key_elt_pairs + +addListToUFM_directly_C combiner fm uniq_elt_pairs + = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i k) e) + fm uniq_elt_pairs +\end{code} + +Now ways of removing things from UniqFM. + +\begin{code} +delListFromUFM fm lst = foldl delFromUFM fm lst + +delFromUFM fm key = delete fm (u2i (getTheUnique key)) + +delete EmptyUFM _ = EmptyUFM +delete fm key = del_ele fm + where + del_ele :: UniqFM a -> UniqFM a + + del_ele lf@(LeafUFM j _) + | j _EQ_ key = EmptyUFM + | otherwise = lf -- no delete! + + del_ele nd@(NodeUFM j p t1 t2) + | j _GT_ key + = mkSLNodeUFM (NodeUFMData j p) (del_ele t1) t2 + | otherwise + = mkLSNodeUFM (NodeUFMData j p) t1 (del_ele t2) + + del_ele _ = panic "Found EmptyUFM FM when rec-deleting" +\end{code} + +Now ways of adding two UniqFM's together. + +\begin{code} +plusUFM tr1 tr2 = plusUFM_C use_snd tr1 tr2 + +plusUFM_C f EmptyUFM tr = tr +plusUFM_C f tr EmptyUFM = tr +plusUFM_C f fm1 fm2 = mix_trees fm1 fm2 + where + mix_trees (LeafUFM i a) t2 = insert_ele (flip f) t2 i a + mix_trees t1 (LeafUFM i a) = insert_ele f t1 i a + + mix_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2') + = mix_branches + (ask_about_common_ancestor + (NodeUFMData j p) + (NodeUFMData j' p')) + where + -- Given a disjoint j,j' (p >^ p' && p' >^ p): + -- + -- j j' (C j j') + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' j j' + -- / \ / \ + -- t1 t2 t1' t2' + -- Fast, Ehh ! + -- + mix_branches (NewRoot nd False) + = mkLLNodeUFM nd left_t right_t + mix_branches (NewRoot nd True) + = mkLLNodeUFM nd right_t left_t + + -- Now, if j == j': + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 + t1' t2 + t2' + -- + mix_branches (SameRoot) + = mkSSNodeUFM (NodeUFMData j p) + (mix_trees t1 t1') + (mix_trees t2 t2') + -- Now the 4 different other ways; all like this: + -- + -- Given j >^ j' (and, say, j > j') + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 t2 + j' + -- / \ + -- t1' t2' + mix_branches (LeftRoot Left) -- | trace "LL" True + = mkSLNodeUFM + (NodeUFMData j p) + (mix_trees t1 right_t) + t2 + + mix_branches (LeftRoot Right) -- | trace "LR" True + = mkLSNodeUFM + (NodeUFMData j p) + t1 + (mix_trees t2 right_t) + + mix_branches (RightRoot Left) -- | trace "RL" True + = mkSLNodeUFM + (NodeUFMData j' p') + (mix_trees left_t t1') + t2' + + mix_branches (RightRoot Right) -- | trace "RR" True + = mkLSNodeUFM + (NodeUFMData j' p') + t1' + (mix_trees left_t t2') + + mix_trees _ _ = panic "EmptyUFM found when inserting into plusInt" +\end{code} + +And ways of subtracting them. First the base cases, +then the full D&C approach. + +\begin{code} +minusUFM EmptyUFM _ = EmptyUFM +minusUFM t1 EmptyUFM = t1 +minusUFM fm1 fm2 = minus_trees fm1 fm2 + where + -- + -- Notice the asymetry of subtraction + -- + minus_trees lf@(LeafUFM i a) t2 = + case lookup t2 i of + Nothing -> lf + Just b -> EmptyUFM + + minus_trees t1 (LeafUFM i _) = delete t1 i + + minus_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2') + = minus_branches + (ask_about_common_ancestor + (NodeUFMData j p) + (NodeUFMData j' p')) + where + -- Given a disjoint j,j' (p >^ p' && p' >^ p): + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 t2 + -- + -- + -- Fast, Ehh ! + -- + minus_branches (NewRoot nd _) = left_t + + -- Now, if j == j': + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 + t1' t2 + t2' + -- + minus_branches (SameRoot) + = mkSSNodeUFM (NodeUFMData j p) + (minus_trees t1 t1') + (minus_trees t2 t2') + -- Now the 4 different other ways; all like this: + -- again, with asymatry + + -- + -- The left is above the right + -- + minus_branches (LeftRoot Left) + = mkSLNodeUFM + (NodeUFMData j p) + (minus_trees t1 right_t) + t2 + minus_branches (LeftRoot Right) + = mkLSNodeUFM + (NodeUFMData j p) + t1 + (minus_trees t2 right_t) + + -- + -- The right is above the left + -- + minus_branches (RightRoot Left) + = minus_trees left_t t1' + minus_branches (RightRoot Right) + = minus_trees left_t t2' + + minus_trees _ _ = panic "EmptyUFM found when insering into plusInt" +\end{code} + +And taking the intersection of two UniqFM's. + +\begin{code} +intersectUFM t1 t2 = intersectUFM_C use_snd t1 t2 + +intersectUFM_C f EmptyUFM _ = EmptyUFM +intersectUFM_C f _ EmptyUFM = EmptyUFM +intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2 + where + intersect_trees (LeafUFM i a) t2 = + case lookup t2 i of + Nothing -> EmptyUFM + Just b -> mkLeafUFM i (f a b) + + intersect_trees t1 (LeafUFM i a) = + case lookup t1 i of + Nothing -> EmptyUFM + Just b -> mkLeafUFM i (f b a) + + intersect_trees left_t@(NodeUFM j p t1 t2) right_t@(NodeUFM j' p' t1' t2') + = intersect_branches + (ask_about_common_ancestor + (NodeUFMData j p) + (NodeUFMData j' p')) + where + -- Given a disjoint j,j' (p >^ p' && p' >^ p): + -- + -- j j' + -- / \ + / \ ==> EmptyUFM + -- t1 t2 t1' t2' + -- + -- Fast, Ehh ! + -- + intersect_branches (NewRoot nd _) = EmptyUFM + + -- Now, if j == j': + -- + -- j j' j + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1 x t1' t2 x t2' + -- + intersect_branches (SameRoot) + = mkSSNodeUFM (NodeUFMData j p) + (intersect_trees t1 t1') + (intersect_trees t2 t2') + -- Now the 4 different other ways; all like this: + -- + -- Given j >^ j' (and, say, j > j') + -- + -- j j' t2 + j' + -- / \ + / \ ==> / \ + -- t1 t2 t1' t2' t1' t2' + -- + -- This does cut down the search space quite a bit. + + intersect_branches (LeftRoot Left) + = intersect_trees t1 right_t + intersect_branches (LeftRoot Right) + = intersect_trees t2 right_t + intersect_branches (RightRoot Left) + = intersect_trees left_t t1' + intersect_branches (RightRoot Right) + = intersect_trees left_t t2' + + intersect_trees x y = panic ("EmptyUFM found when intersecting trees") +\end{code} + +Now the usual set of `collection' operators, like map, fold, etc. + +\begin{code} +foldUFM fn a EmptyUFM = a +foldUFM fn a fm = fold_tree fn a fm + +mapUFM fn EmptyUFM = EmptyUFM +mapUFM fn fm = map_tree fn fm + +filterUFM fn EmptyUFM = EmptyUFM +filterUFM fn fm = filter_tree fn fm +\end{code} + +Note, this takes a long time, O(n), but +because we dont want to do this very often, we put up with this. +O'rable, but how often do we look at the size of +a finite map? + +\begin{code} +sizeUFM EmptyUFM = 0 +sizeUFM (NodeUFM _ _ t1 t2) = sizeUFM t1 + sizeUFM t2 +sizeUFM (LeafUFM _ _) = 1 + +isNullUFM EmptyUFM = True +isNullUFM _ = False +\end{code} + +looking up in a hurry is the {\em whole point} of this binary tree lark. +Lookup up a binary tree is easy (and fast). + +\begin{code} +lookupUFM fm key = lookup fm (u2i (getTheUnique key)) +lookupDirectlyUFM fm key = lookup fm (u2i key) + +lookupWithDefaultUFM fm deflt key + = case lookup fm (u2i (getTheUnique key)) of + Nothing -> deflt + Just elt -> elt + +lookup EmptyUFM _ = Nothing +lookup fm i = lookup_tree fm + where + lookup_tree :: UniqFM a -> Maybe a + + lookup_tree (LeafUFM j b) + | j _EQ_ i = Just b + | otherwise = Nothing + lookup_tree (NodeUFM j p t1 t2) + | j _GT_ i = lookup_tree t1 + | otherwise = lookup_tree t2 + + lookup_tree EmptyUFM = panic "lookup Failed" +\end{code} + +folds are *wonderful* things. + +\begin{code} +eltsUFM EmptyUFM = [] +eltsUFM fm = fold_tree (:) [] fm + +ufmToList EmptyUFM = [] +ufmToList fm + = fold_tree (\ iu elt rest -> (mkUniqueGrimily iu, elt) : rest) [] fm + where + fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1 + fold_tree f a (LeafUFM iu obj) = f iu obj a + + fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM" +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and its functions} +%* * +%************************************************************************ + +You should always use these to build the tree. +There are 4 versions of mkNodeUFM, depending on +the strictness of the two sub-tree arguments. +The strictness is used *both* to prune out +empty trees, *and* to improve performance, +stoping needless thunks lying around. +The rule of thumb (from experence with these trees) +is make thunks strict, but data structures lazy. +If in doubt, use mkSSNodeUFM, which has the `strongest' +functionality, but may do a few needless evaluations. + +\begin{code} +mkLeafUFM :: FAST_INT -> a -> UniqFM a +mkLeafUFM i a = LeafUFM i a + +-- The *ONLY* ways of building a NodeUFM. + +mkSSNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2 +mkSSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1 +mkSSNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +mkSLNodeUFM (NodeUFMData j p) EmptyUFM t2 = t2 +mkSLNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +mkLSNodeUFM (NodeUFMData j p) t1 EmptyUFM = t1 +mkLSNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +mkLLNodeUFM (NodeUFMData j p) t1 t2 + = ASSERT(correctNodeUFM (IBOX(j)) (IBOX(p)) t1 t2) + NodeUFM j p t1 t2 + +correctNodeUFM + :: Int + -> Int + -> UniqFM a + -> UniqFM a + -> Bool + +correctNodeUFM j p t1 t2 + = correct (j-p) (j-1) p t1 && correct j ((j-1)+p) p t2 + where + correct low high _ (LeafUFM i _) + = low <= IBOX(i) && IBOX(i) <= high + correct low high above_p (NodeUFM j p _ _) + = low <= IBOX(j) && IBOX(j) <= high && above_p > IBOX(p) + correct _ _ _ EmptyUFM = panic "EmptyUFM stored inside a tree" +\end{code} + +Note: doing SAT on this by hand seems to make it worse. Todo: Investigate, +and if necessary do $\lambda$ lifting on our functions that are bound. + +\begin{code} +insert_ele + :: (a -> a -> a) + -> UniqFM a + -> FAST_INT + -> a + -> UniqFM a + +insert_ele f EmptyUFM i new = mkLeafUFM i new + +insert_ele f (LeafUFM j old) i new + | j _GT_ i = + mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + (indexToRoot j)) + (mkLeafUFM i new) + (mkLeafUFM j old) + | j _EQ_ i = mkLeafUFM j (f old new) + | otherwise = + mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + (indexToRoot j)) + (mkLeafUFM j old) + (mkLeafUFM i new) + +insert_ele f n@(NodeUFM j p t1 t2) i a + | i _LT_ j + = if (i _GE_ (j _SUB_ p)) + then mkSLNodeUFM (NodeUFMData j p) (insert_ele f t1 i a) t2 + else mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + ((NodeUFMData j p))) + (mkLeafUFM i a) + n + | otherwise + = if (i _LE_ ((j _SUB_ ILIT(1)) _ADD_ p)) + then mkLSNodeUFM (NodeUFMData j p) t1 (insert_ele f t2 i a) + else mkLLNodeUFM (getCommonNodeUFMData + (indexToRoot i) + ((NodeUFMData j p))) + n + (mkLeafUFM i a) +\end{code} + +This has got a left to right ordering. + +\begin{code} +fold_tree f a (NodeUFM _ _ t1 t2) = fold_tree f (fold_tree f a t2) t1 +fold_tree f a (LeafUFM _ obj) = f obj a + +fold_tree f a EmptyUFM = panic "Should Never fold over an EmptyUFM" +\end{code} + +\begin{code} +map_tree f (NodeUFM j p t1 t2) + = mkSSNodeUFM (NodeUFMData j p) (map_tree f t1) (map_tree f t2) +map_tree f (LeafUFM i obj) + = mkLeafUFM i (f obj) + +map_tree f _ = panic "map_tree failed" +\end{code} + +\begin{code} +filter_tree f nd@(NodeUFM j p t1 t2) + = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2) + +filter_tree f lf@(LeafUFM i obj) + | f obj = lf + | otherwise = EmptyUFM +\end{code} + +%************************************************************************ +%* * +\subsubsection{The @UniqFM@ type, and signatures for the functions} +%* * +%************************************************************************ + +Now some Utilities; + +This is the information that is held inside a NodeUFM, packaged up for +consumer use. + +\begin{code} +data NodeUFMData + = NodeUFMData FAST_INT + FAST_INT +\end{code} + +This is the information used when computing new NodeUFMs. + +\begin{code} +data Side = Left | Right +data CommonRoot + = LeftRoot Side -- which side is the right down ? + | RightRoot Side -- which side is the left down ? + | SameRoot -- they are the same ! + | NewRoot NodeUFMData -- here's the new, common, root + Bool -- do you need to swap left and right ? +\end{code} + +This specifies the relationship between NodeUFMData and CalcNodeUFMData. + +\begin{code} +indexToRoot :: FAST_INT -> NodeUFMData + +indexToRoot i + = let + l = (ILIT(1) :: FAST_INT) + in + NodeUFMData (((i `shiftR_` l) `shiftL_` l) _ADD_ ILIT(1)) l + +getCommonNodeUFMData :: NodeUFMData -> NodeUFMData -> NodeUFMData + +getCommonNodeUFMData (NodeUFMData i p) (NodeUFMData i2 p2) + | p _EQ_ p2 = getCommonNodeUFMData_ p j j2 + | p _LT_ p2 = getCommonNodeUFMData_ p2 (j _QUOT_ (p2 _QUOT_ p)) j2 + | otherwise = getCommonNodeUFMData_ p j (j2 _QUOT_ (p _QUOT_ p2)) + where + l = (ILIT(1) :: FAST_INT) + j = i _QUOT_ (p `shiftL_` l) + j2 = i2 _QUOT_ (p2 `shiftL_` l) + + getCommonNodeUFMData_ :: FAST_INT -> FAST_INT -> FAST_INT -> NodeUFMData + + getCommonNodeUFMData_ p j j_ + | j _EQ_ j_ + = NodeUFMData (((j `shiftL_` l) _ADD_ l) _MUL_ p) p + | otherwise + = getCommonNodeUFMData_ (p `shiftL_` l) (j `shiftR_` l) (j_ `shiftR_` l) + +ask_about_common_ancestor :: NodeUFMData -> NodeUFMData -> CommonRoot + +ask_about_common_ancestor x@(NodeUFMData j p) y@(NodeUFMData j2 p2) + | j _EQ_ j2 = SameRoot + | otherwise + = case getCommonNodeUFMData x y of + nd@(NodeUFMData j3 p3) + | j3 _EQ_ j -> LeftRoot (decideSide (j _GT_ j2)) + | j3 _EQ_ j2 -> RightRoot (decideSide (j _LT_ j2)) + | otherwise -> NewRoot nd (j _GT_ j2) + where + decideSide :: Bool -> Side + decideSide True = Left + decideSide False = Right +\end{code} + +This might be better in Util.lhs ? + + +Now the bit twiddling functions. +\begin{code} +shiftL_ :: FAST_INT -> FAST_INT -> FAST_INT +shiftR_ :: FAST_INT -> FAST_INT -> FAST_INT + +#if __GLASGOW_HASKELL__ +{-# INLINE shiftL_ #-} +{-# INLINE shiftR_ #-} +shiftL_ n p = word2Int#((int2Word# n) `shiftL#` p) +shiftR_ n p = word2Int#((int2Word# n) `shiftr` p) +# if __GLASGOW_HASKELL__ >= 23 + where + shiftr x y = shiftRA# x y +# else + shiftr x y = shiftR# x y +# endif + +#else {- not GHC -} +shiftL_ n p = n * (2 ^ p) +shiftR_ n p = n `quot` (2 ^ p) + +#endif {- not GHC -} +\end{code} + +Andy's extras: ToDo: to Util. + +\begin{code} +use_fst :: a -> b -> a +use_fst a b = a + +use_snd :: a -> b -> b +use_snd a b = b +\end{code} diff --git a/ghc/compiler/utils/UniqSet.hi b/ghc/compiler/utils/UniqSet.hi new file mode 100644 index 0000000..1abe6e0 --- /dev/null +++ b/ghc/compiler/utils/UniqSet.hi @@ -0,0 +1,61 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UniqSet where +import Id(Id, IdDetails) +import IdInfo(IdInfo) +import Name(Name) +import NameTypes(FullName, ShortName) +import Outputable(NamedThing) +import PreludePS(_PackedString) +import TyCon(TyCon) +import TyVar(TyVar) +import UniType(UniType) +import UniqFM(UniqFM, eltsUFM, emptyUFM, intersectUFM, isNullUFM, minusUFM, plusUFM, singletonUFM) +import Unique(Unique, u2i) +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +type IdSet = UniqFM Id +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +type NameSet = UniqFM Name +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +type TyVarSet = UniqFM TyVar +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +type UniqSet a = UniqFM a +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +elementOfUniqSet :: NamedThing a => a -> UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LS" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)S" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Name ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ } #-} +eltsUFM :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +emptyUFM :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +emptyUniqSet :: UniqFM a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-} +intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +intersectUniqSets :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM intersectUFM _N_ #-} +isEmptyUniqSet :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM isNullUFM _N_ #-} +isNullUFM :: UniqFM a -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: UniqFM u0) -> case u1 of { _ALG_ _ORIG_ UniqFM EmptyUFM -> _!_ True [] []; (u2 :: UniqFM u0) -> _!_ False [] [] } _N_ #-} +mapUniqSet :: NamedThing b => (a -> b) -> UniqFM a -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ _N_, TyVar ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ }, [ _N_, Id ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ }, [ _N_, Name ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ } #-} +minusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +minusUniqSet :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM minusUFM _N_ #-} +mkUniqSet :: NamedThing a => [a] -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Name ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-} +plusUFM :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +singletonUFM :: NamedThing a => a -> b -> UniqFM b + {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-} +singletonUniqSet :: NamedThing a => a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAAAAASAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ UniqFM singletonUFM { u0 } { u0 } [ u1, u2, u2 ] _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ UniqFM singletonUFM [ (TyVar), _N_ ] { TyVar } [ u0, u0 ] _N_ }, [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(U(P)LLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [Id] [u5, u0]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ }, [ Name ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Name) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ UniqFM singletonUFM [ (Name), _N_ ] { Name } [ u0, u0 ] _N_ } #-} +u2i :: Unique -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-} +unionManyUniqSets :: [UniqFM a] -> UniqFM a + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +unionUniqSets :: UniqFM a -> UniqFM a -> UniqFM a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM _N_ #-} +uniqSetToList :: UniqFM a -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM eltsUFM _N_ #-} + diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs new file mode 100644 index 0000000..3adc33b --- /dev/null +++ b/ghc/compiler/utils/UniqSet.lhs @@ -0,0 +1,164 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1995 +% +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @NamedThing@. + +We also export specialisations for @Ids@ and @TyVars@. + +\begin{code} +#include "HsVersions.h" + +module UniqSet ( + UniqSet(..), -- abstract type: NOT + + mkUniqSet, uniqSetToList, emptyUniqSet, singletonUniqSet, + unionUniqSets, unionManyUniqSets, minusUniqSet, + elementOfUniqSet, mapUniqSet, + intersectUniqSets, isEmptyUniqSet, + + -- specalised for Ids: + IdSet(..), + + -- specalised for TyVars: + TyVarSet(..), + + -- specalised for Names: + NameSet(..), + + -- to make the interface self-sufficient + Id, TyVar, Name, + + UniqFM, Unique + + -- and to be pragma friendly +#ifdef USE_ATTACK_PRAGMAS + , emptyUFM, intersectUFM, isNullUFM, minusUFM, singletonUFM, + plusUFM, eltsUFM, + u2i +#endif + ) where + +import UniqFM +import Id -- for specialisation to Ids +import IdInfo -- sigh +import Maybes ( maybeToBool, Maybe(..) ) +import Name +import Outputable +import AbsUniType -- for specialisation to TyVars +import Util +#if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +#define IF_NCG(a) a +#else +#define IF_NCG(a) {--} +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{The @UniqSet@ type} +%* * +%************************************************************************ + +We use @UniqFM@, with a (@getTheUnique@-able) @Unique@ as ``key'' +and the thing itself as the ``value'' (for later retrieval). + +\begin{code} +--data UniqSet a = MkUniqSet (FiniteMap Unique a) : NOT + +type UniqSet a = UniqFM a +#define MkUniqSet {--} + +emptyUniqSet :: UniqSet a +emptyUniqSet = MkUniqSet emptyUFM + +singletonUniqSet :: NamedThing a => a -> UniqSet a +singletonUniqSet x = MkUniqSet (singletonUFM x x) + +uniqSetToList :: UniqSet a -> [a] +uniqSetToList (MkUniqSet set) = BSCC("uniqSetToList") eltsUFM set ESCC + +mkUniqSet :: NamedThing a => [a] -> UniqSet a +mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs]) + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a + -- = foldr unionUniqSets emptyUniqSet ss +unionManyUniqSets [] = emptyUniqSet +unionManyUniqSets [s] = s +unionManyUniqSets (s:ss) = s `unionUniqSets` unionManyUniqSets ss + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2) + +elementOfUniqSet :: NamedThing a => a -> UniqSet a -> Bool +elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x) + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-} + +mapUniqSet :: NamedThing b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f (MkUniqSet set) + = MkUniqSet (listToUFM [ let + mapped_thing = f thing + in + (mapped_thing, mapped_thing) + | thing <- eltsUFM set ]) +\end{code} + +%************************************************************************ +%* * +\subsection{The @IdSet@ and @TyVarSet@ specialisations for sets of Ids/TyVars} +%* * +%************************************************************************ + +@IdSet@ is a specialised version, optimised for sets of Ids. + +\begin{code} +type IdSet = UniqSet Id +type TyVarSet = UniqSet TyVar +type NameSet = UniqSet Name +#if ! OMIT_NATIVE_CODEGEN +type RegSet = UniqSet Reg +#endif + +#if __GLASGOW_HASKELL__ + -- avoid hbc bug (0.999.7) +{-# SPECIALIZE + singletonUniqSet :: Id -> IdSet, + TyVar -> TyVarSet, + Name -> NameSet + IF_NCG(COMMA Reg -> RegSet) + #-} + +{-# SPECIALIZE + mkUniqSet :: [Id] -> IdSet, + [TyVar] -> TyVarSet, + [Name] -> NameSet + IF_NCG(COMMA [Reg] -> RegSet) + #-} + +{-# SPECIALIZE + elementOfUniqSet :: Id -> IdSet -> Bool, + TyVar -> TyVarSet -> Bool, + Name -> NameSet -> Bool + IF_NCG(COMMA Reg -> RegSet -> Bool) + #-} + +{-# SPECIALIZE + mapUniqSet :: (Id -> Id) -> IdSet -> IdSet, + (TyVar -> TyVar) -> TyVarSet -> TyVarSet, + (Name -> Name) -> NameSet -> NameSet + IF_NCG(COMMA (Reg -> Reg) -> RegSet -> RegSet) + #-} +#endif +\end{code} diff --git a/ghc/compiler/utils/Unpretty.hi b/ghc/compiler/utils/Unpretty.hi new file mode 100644 index 0000000..3cc0005 --- /dev/null +++ b/ghc/compiler/utils/Unpretty.hi @@ -0,0 +1,67 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Unpretty where +import CharSeq(CSeq, cAppendFile, cInt) +import CmdLineOpts(GlobalSwitch) +import PreludePS(_PackedString) +import Pretty(PprStyle(..)) +import Stdio(_FILE) +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) +type Unpretty = CSeq +cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)SL" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-} +cInt :: Int -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-} +uppAbove :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-} +uppAboves :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uppAppendFile :: _FILE -> Int -> CSeq -> _State _RealWorld -> ((), _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 1022 _N_ _S_ "U(P)ASL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +uppBeside :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-} +uppBesides :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uppCat :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +uppChar :: Char -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-} +uppComma :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppEquals :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppInt :: Int -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-} +uppInteger :: Integer -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-} +uppInterleave :: CSeq -> [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +uppIntersperse :: CSeq -> [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +uppLbrack :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppLparen :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppNest :: Int -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AS" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CSeq) -> u0 _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int) (u1 :: CSeq) -> u1 _N_ #-} +uppNil :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-} +uppPStr :: _PackedString -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-} +uppRbrack :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppRparen :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppSP :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppSemi :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +uppSep :: [CSeq] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ Unpretty uppBesides _N_ #-} +uppShow :: Int -> CSeq -> [Char] + {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ CharSeq cShow _N_} _F_ _IF_ARGS_ 0 2 XX 2 \ (u0 :: Int) (u1 :: CSeq) -> _APP_ _ORIG_ CharSeq cShow [ u1 ] _N_ #-} +uppStr :: [Char] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-} + diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs new file mode 100644 index 0000000..2cdf8d4 --- /dev/null +++ b/ghc/compiler/utils/Unpretty.lhs @@ -0,0 +1,170 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Unpretty]{Unpretty-printing data type} + +\begin{code} +#include "HsVersions.h" + +module Unpretty ( + Unpretty(..), + PprStyle(..), -- re-exported from Pretty + uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger, --UNUSED: uppDouble, + uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, -- UNUSED: upp'SP, + uppSemi, uppComma, uppEquals, + + uppCat, uppBeside, uppBesides, uppAbove, uppAboves, + uppNest, uppSep, uppInterleave, uppIntersperse, --UNUSED: uppHang, + uppShow, +#ifdef __GLASGOW_HASKELL__ + uppAppendFile, + IF_ATTACK_PRAGMAS(cAppendFile COMMA) + IF_ATTACK_PRAGMAS(cInt COMMA) +#endif +#ifdef DPH + unprettyToStr, +#endif {- Data Parallel Haskell -} + + -- abstract type, to complete the interface... + CSeq, GlobalSwitch + ) where + +import CharSeq +import Outputable +import Pretty ( PprStyle(..), Pretty(..), GlobalSwitch ) +import Util +\end{code} + +Same interface as @Pretty@, but doesn't do anything. + +The pretty type is redefined here: +\begin{code} +type Unpretty = CSeq +\end{code} + +%************************************************ +%* * + \subsection{The interface} +%* * +%************************************************ + +\begin{code} +uppNil :: Unpretty +uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals :: Unpretty +--UNUSED: upp'SP :: Unpretty + +uppStr :: [Char] -> Unpretty +uppPStr :: FAST_STRING -> Unpretty +uppChar :: Char -> Unpretty +uppInt :: Int -> Unpretty +uppInteger :: Integer -> Unpretty +--UNUSED:uppDouble :: Double -> Unpretty + +uppBeside :: Unpretty -> Unpretty -> Unpretty +uppBesides :: [Unpretty] -> Unpretty +ppBesideSP :: Unpretty -> Unpretty -> Unpretty +uppCat :: [Unpretty] -> Unpretty -- i.e., ppBesidesSP + +uppAbove :: Unpretty -> Unpretty -> Unpretty +uppAboves :: [Unpretty] -> Unpretty + +uppInterleave :: Unpretty -> [Unpretty] -> Unpretty +uppIntersperse :: Unpretty -> [Unpretty] -> Unpretty -- no spaces between +uppSep :: [Unpretty] -> Unpretty +--UNUSED:uppHang :: Unpretty -> Int -> Unpretty -> Unpretty +uppNest :: Int -> Unpretty -> Unpretty + +uppShow :: Int -> Unpretty -> [Char] + +#ifdef __GLASGOW_HASKELL__ +uppAppendFile :: _FILE -> Int -> Unpretty -> PrimIO () +#endif +\end{code} + +%************************************************ +%* * + \subsection{The representation} +%* * +%************************************************ + +\begin{code} +uppShow _ p = cShow p + +#ifdef __GLASGOW_HASKELL__ +uppAppendFile f _ p = cAppendFile f p +#endif + +uppNil = cNil +uppStr s = cStr s +uppPStr s = cPStr s +uppChar c = cCh c +uppInt n = cInt n + +uppInteger n = cStr (show n) +--UNUSED:uppDouble n = cStr (show n) + +uppSP = cCh ' ' +--UNUSED:upp'SP = cStr ", " +uppLbrack = cCh '[' +uppRbrack = cCh ']' +uppLparen = cCh '(' +uppRparen = cCh ')' +uppSemi = cCh ';' +uppComma = cCh ',' +uppEquals = cCh '=' + +uppInterleave sep ps = uppSep (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (cAppend{-uppBeside-} x sep) : pi xs +\end{code} + +\begin{code} +uppIntersperse sep ps = uppBesides (pi ps) + where + pi [] = [] + pi [x] = [x] + pi (x:xs) = (cAppend{-uppBeside-} x sep) : pi xs +\end{code} + +\begin{code} +uppBeside p1 p2 = p1 `cAppend` p2 + +uppBesides [] = cNil{-uppNil-} +uppBesides [p] = p +uppBesides (p:ps) = p `cAppend`{-uppBeside-} uppBesides ps +\end{code} + +\begin{code} +ppBesideSP p1 p2 = p1 `cAppend` (cCh ' ') `cAppend` p2 +\end{code} + +@uppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@. + +\begin{code} +uppCat [] = cNil{-uppNil-} +uppCat [p] = p +uppCat (p:ps) = ppBesideSP p (uppCat ps) + +uppAbove p1 p2 = p1 `cAppend` (cCh '\n') `cAppend` p2 + +uppAboves [] = cNil{-uppNil-} +uppAboves [p] = p +uppAboves (p:ps) = p `cAppend` (cCh '\n') `cAppend` (uppAboves ps) + +uppNest n p = p +\end{code} + +\begin{code} +--UNUSED: uppHang p1 n p2 = ppBesideSP p1 p2 + +uppSep ps = uppBesides ps +\end{code} + +\begin{code} +#ifdef DPH +unprettyToStr:: Unpretty -> String +unprettyToStr thing = uppShow 80 thing +#endif {- Data Parallel Haskell -} +\end{code} diff --git a/ghc/compiler/utils/Util.hi b/ghc/compiler/utils/Util.hi new file mode 100644 index 0000000..0483090 --- /dev/null +++ b/ghc/compiler/utils/Util.hi @@ -0,0 +1,390 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface Util where +import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo) +import AbsSyn(Module) +import Bag(Bag, emptyBag, snocBag) +import BasicLit(BasicLit, kindOfBasicLit, typeOfBasicLit) +import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC) +import CLabelInfo(CLabel) +import CgBindery(StableLoc, VolatileLoc) +import CgMonad(EndOfBlockInfo, Sequel, StubFlag) +import CharSeq(CSeq, cAppend, cCh, cNil, cPStr, cShow, cStr) +import Class(Class, ClassOp) +import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo) +import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult, switchIsOn) +import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr, pprCoreBinding, pprCoreExpr) +import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC) +import FiniteMap(FiniteMap, emptyFM) +import HeapOffs(HeapOffset) +import HsBinds(Bind, Binds, MonoBinds, Sig) +import HsCore(UfCostCentre, UfId, UnfoldingCoreAlts, UnfoldingCoreAtom, UnfoldingCoreBinding, UnfoldingCoreDefault, UnfoldingCoreExpr, UnfoldingPrimOp) +import HsDecls(ClassDecl, ConDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl) +import HsExpr(ArithSeqInfo, Expr, Qual) +import HsImpExp(IE, IfaceImportDecl, ImportedInterface, Interface, Renaming) +import HsLit(Literal) +import HsMatches(GRHS, GRHSsAndBinds, Match) +import HsPat(InPat, TypecheckedPat, typeOfPat) +import HsPragmas(ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, ImpStrictness, ImpUnfolding, InstancePragmas, TypePragmas) +import HsTypes(MonoType, PolyType) +import Id(Id, IdDetails, cmpId, eqId, getIdKind, getIdUniType) +import IdEnv(IdEnv(..)) +import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, nullSpecEnv) +import Inst(Inst, InstOrigin, OverloadedLit) +import InstEnv(InstTemplate, InstTy) +import MagicUFs(MagicUnfoldingFun) +import Maybes(Labda(..)) +import Name(Name, cmpName, eqName) +import NameTypes(FullName, Provenance, ShortName) +import OrdList(OrdList) +import Outputable(ExportFlag, NamedThing(..), Outputable(..)) +import PreludePS(_PackedString) +import PreludeRatio(Ratio(..)) +import Pretty(Delay, PprStyle, Pretty(..), PrettyRep, ppDouble, ppInt, ppInteger, ppNil, ppRational, ppStr) +import PrimKind(PrimKind) +import PrimOps(PrimOp, pprPrimOp, tagOf_PrimOp) +import ProtoName(ProtoName, cmpByLocalName, cmpProtoName, eqByLocalName, eqProtoName) +import SMRep(SMRep, SMSpecRepKind, SMUpdateKind) +import SimplEnv(EnclosingCcDetails, FormSummary, IdVal, SimplEnv, UnfoldConApp, UnfoldEnv, UnfoldItem, UnfoldingDetails, UnfoldingGuidance) +import SimplMonad(SimplCount, TickType) +import SplitUniq(SplitUniqSupply) +import SrcLoc(SrcLoc, mkUnknownSrcLoc) +import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr, StgRhs, UpdateFlag) +import TyCon(TyCon) +import TyVar(TyVar, TyVarTemplate) +import TyVarEnv(TyVarEnv(..)) +import UniTyFuns(kindFromType, pprTyCon, pprUniType) +import UniType(UniType) +import UniqFM(UniqFM) +import Unique(Unique, UniqueSupply, cmpUnique, eqUnique, showUnique) +class OptIdInfo a where + noInfo :: a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-} + getInfo :: IdInfo -> a + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-} + addInfo :: IdInfo -> a -> IdInfo + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-} + ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-} +class NamedThing a where + getExportFlag :: a -> ExportFlag + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-} + isLocallyDefined :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-} + getOrigName :: a -> (_PackedString, _PackedString) + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-} + getOccurrenceName :: a -> _PackedString + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-} + getInformingModules :: a -> [_PackedString] + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-} + getSrcLoc :: a -> SrcLoc + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-} + getTheUnique :: a -> Unique + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-} + hasType :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-} + getType :: a -> UniType + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-} + fromPreludeCore :: a -> Bool + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_ + {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-} +class Outputable a where + ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_ + {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-} +data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-} +data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-} +data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-} +data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-} +data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-} +data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-} +data ReturnInfo {-# GHC_PRAGMA DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode #-} +data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-} +data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-} +data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-} +data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-} +data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-} +data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-} +data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-} +data CLabel +data StableLoc {-# GHC_PRAGMA NoStableLoc | VirAStkLoc Int | VirBStkLoc Int | LitLoc BasicLit | StableAmodeLoc CAddrMode #-} +data VolatileLoc {-# GHC_PRAGMA NoVolatileLoc | TempVarLoc Unique | RegLoc MagicId | VirHpLoc HeapOffset | VirNodeLoc HeapOffset #-} +data EndOfBlockInfo {-# GHC_PRAGMA EndOfBlockInfo Int Int Sequel #-} +data Sequel {-# GHC_PRAGMA InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))) #-} +data StubFlag {-# GHC_PRAGMA Stubbed | NotStubbed #-} +data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-} +data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-} +data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-} +data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-} +data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-} +data StandardFormInfo {-# GHC_PRAGMA NonStandardThunk | SelectorThunk Id Id Int | VapThunk Id [StgAtom Id] Bool #-} +data GlobalSwitch + {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-} +data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-} +data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-} +data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-} +data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-} +data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-} +data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-} +data CoreCaseDefault a b {-# GHC_PRAGMA CoNoDefault | CoBindDefault a (CoreExpr a b) #-} +data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-} +data CcKind {-# GHC_PRAGMA UserCC _PackedString | AutoCC Id | DictCC Id #-} +data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-} +data IsCafCC {-# GHC_PRAGMA IsCafCC | IsNotCafCC #-} +data IsDupdCC {-# GHC_PRAGMA AnOriginalCC | ADupdCC #-} +data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-} +data HeapOffset +data Bind a b {-# GHC_PRAGMA EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) #-} +data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-} +data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-} +data Sig a {-# GHC_PRAGMA Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc #-} +data UfCostCentre a {-# GHC_PRAGMA UfPreludeDictsCC Bool | UfAllDictsCC _PackedString _PackedString Bool | UfUserCC _PackedString _PackedString _PackedString Bool Bool | UfAutoCC (UfId a) _PackedString _PackedString Bool Bool | UfDictCC (UfId a) _PackedString _PackedString Bool Bool #-} +data UfId a {-# GHC_PRAGMA BoringUfId a | SuperDictSelUfId a a | ClassOpUfId a a | DictFunUfId a (PolyType a) | ConstMethodUfId a a (PolyType a) | DefaultMethodUfId a a | SpecUfId (UfId a) [Labda (MonoType a)] | WorkerUfId (UfId a) #-} +data UnfoldingCoreAlts a {-# GHC_PRAGMA UfCoAlgAlts [(a, [(a, PolyType a)], UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) #-} +data UnfoldingCoreAtom a {-# GHC_PRAGMA UfCoVarAtom (UfId a) | UfCoLitAtom BasicLit #-} +data UnfoldingCoreBinding a {-# GHC_PRAGMA UfCoNonRec (a, PolyType a) (UnfoldingCoreExpr a) | UfCoRec [((a, PolyType a), UnfoldingCoreExpr a)] #-} +data UnfoldingCoreDefault a {-# GHC_PRAGMA UfCoNoDefault | UfCoBindDefault (a, PolyType a) (UnfoldingCoreExpr a) #-} +data UnfoldingCoreExpr a {-# GHC_PRAGMA UfCoVar (UfId a) | UfCoLit BasicLit | UfCoCon a [PolyType a] [UnfoldingCoreAtom a] | UfCoPrim (UnfoldingPrimOp a) [PolyType a] [UnfoldingCoreAtom a] | UfCoLam [(a, PolyType a)] (UnfoldingCoreExpr a) | UfCoTyLam a (UnfoldingCoreExpr a) | UfCoApp (UnfoldingCoreExpr a) (UnfoldingCoreAtom a) | UfCoTyApp (UnfoldingCoreExpr a) (PolyType a) | UfCoCase (UnfoldingCoreExpr a) (UnfoldingCoreAlts a) | UfCoLet (UnfoldingCoreBinding a) (UnfoldingCoreExpr a) | UfCoSCC (UfCostCentre a) (UnfoldingCoreExpr a) #-} +data UnfoldingPrimOp a {-# GHC_PRAGMA UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp #-} +data ClassDecl a b {-# GHC_PRAGMA ClassDecl [(a, a)] a a [Sig a] (MonoBinds a b) (ClassPragmas a) SrcLoc #-} +data ConDecl a {-# GHC_PRAGMA ConDecl a [MonoType a] SrcLoc #-} +data DataTypeSig a {-# GHC_PRAGMA AbstractTypeSig a SrcLoc | SpecDataSig a (MonoType a) SrcLoc #-} +data DefaultDecl a {-# GHC_PRAGMA DefaultDecl [MonoType a] SrcLoc #-} +data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-} +data InstDecl a b {-# GHC_PRAGMA InstDecl [(a, a)] a (MonoType a) (MonoBinds a b) Bool _PackedString _PackedString [Sig a] (InstancePragmas a) SrcLoc #-} +data SpecialisedInstanceSig a {-# GHC_PRAGMA InstSpecSig a (MonoType a) SrcLoc #-} +data TyDecl a {-# GHC_PRAGMA TyData [(a, a)] a [a] [ConDecl a] [a] (DataPragmas a) SrcLoc | TySynonym a [a] (MonoType a) TypePragmas SrcLoc #-} +data ArithSeqInfo a b {-# GHC_PRAGMA From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) #-} +data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-} +data Qual a b {-# GHC_PRAGMA GeneratorQual b (Expr a b) | FilterQual (Expr a b) #-} +data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-} +data IfaceImportDecl {-# GHC_PRAGMA IfaceImportDecl _PackedString [IE] [Renaming] SrcLoc #-} +data ImportedInterface a b {-# GHC_PRAGMA ImportAll (Interface a b) [Renaming] | ImportSome (Interface a b) [IE] [Renaming] | ImportButHide (Interface a b) [IE] [Renaming] #-} +data Interface a b {-# GHC_PRAGMA MkInterface _PackedString [IfaceImportDecl] [FixityDecl a] [TyDecl a] [ClassDecl a b] [InstDecl a b] [Sig a] SrcLoc #-} +data Renaming {-# GHC_PRAGMA MkRenaming _PackedString _PackedString #-} +data Literal {-# GHC_PRAGMA CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) #-} +data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-} +data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-} +data Match a b {-# GHC_PRAGMA PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) #-} +data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-} +data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-} +data ClassOpPragmas a {-# GHC_PRAGMA NoClassOpPragmas | ClassOpPragmas (GenPragmas a) (GenPragmas a) #-} +data ClassPragmas a {-# GHC_PRAGMA NoClassPragmas | SuperDictPragmas [GenPragmas a] #-} +data DataPragmas a {-# GHC_PRAGMA DataPragmas [ConDecl a] [[Labda (MonoType a)]] #-} +data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-} +data ImpStrictness a {-# GHC_PRAGMA NoImpStrictness | ImpStrictness Bool [Demand] (GenPragmas a) #-} +data ImpUnfolding a {-# GHC_PRAGMA NoImpUnfolding | ImpMagicUnfolding _PackedString | ImpUnfolding UnfoldingGuidance (UnfoldingCoreExpr a) #-} +data InstancePragmas a {-# GHC_PRAGMA NoInstancePragmas | SimpleInstancePragma (GenPragmas a) | ConstantInstancePragma (GenPragmas a) [(a, GenPragmas a)] | SpecialisedInstancePragma (GenPragmas a) [([Labda (MonoType a)], Int, InstancePragmas a)] #-} +data TypePragmas {-# GHC_PRAGMA NoTypePragmas | AbstractTySynonym #-} +data MonoType a {-# GHC_PRAGMA MonoTyVar a | MonoTyCon a [MonoType a] | FunMonoTy (MonoType a) (MonoType a) | ListMonoTy (MonoType a) | TupleMonoTy [PolyType a] | MonoTyVarTemplate a | MonoDict a (MonoType a) #-} +data PolyType a {-# GHC_PRAGMA UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) #-} +data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-} +data IdDetails {-# GHC_PRAGMA LocalId ShortName Bool | SysLocalId ShortName Bool | SpecPragmaId ShortName (Labda SpecInfo) Bool | ImportedId FullName | PreludeId FullName | TopLevId FullName | DataConId FullName Int [TyVarTemplate] [(Class, UniType)] [UniType] TyCon | TupleConId Int | SuperDictSelId Class Class | ClassOpId Class ClassOp | DefaultMethodId Class ClassOp Bool | DictFunId Class UniType Bool | ConstMethodId Class UniType ClassOp Bool | InstId Inst | SpecId Id [Labda UniType] Bool | WorkerId Id #-} +type IdEnv a = UniqFM a +data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-} +data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-} +data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-} +data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-} +data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-} +data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-} +data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-} +data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-} +data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-} +data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-} +data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-} +data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-} +data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-} +data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-} +data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-} +data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-} +data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-} +data OverloadedLit {-# GHC_PRAGMA OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id #-} +data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-} +data InstTy {-# GHC_PRAGMA DictTy Class UniType | MethodTy Id [UniType] #-} +data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-} +data Labda a = Hamna | Ni a +data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-} +data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-} +data Provenance {-# GHC_PRAGMA ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString] #-} +data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-} +data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-} +data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-} +data Delay a {-# GHC_PRAGMA MkDelay a #-} +data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-} +type Pretty = Int -> Bool -> PrettyRep +data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-} +data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-} +data PrimOp + {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-} +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-} +data SMSpecRepKind {-# GHC_PRAGMA SpecRep | ConstantRep | CharLikeRep | IntLikeRep #-} +data SMUpdateKind {-# GHC_PRAGMA SMNormalForm | SMSingleEntry | SMUpdatable #-} +data EnclosingCcDetails {-# GHC_PRAGMA NoEnclosingCcDetails | EnclosingCC CostCentre #-} +data FormSummary {-# GHC_PRAGMA WhnfForm | BottomForm | OtherForm #-} +data IdVal {-# GHC_PRAGMA InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id) #-} +data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-} +data UnfoldConApp {-# GHC_PRAGMA UCA Id [UniType] [CoreAtom Id] #-} +data UnfoldEnv {-# GHC_PRAGMA UFE (UniqFM UnfoldItem) (UniqFM Id) (FiniteMap UnfoldConApp Id) #-} +data UnfoldItem {-# GHC_PRAGMA UnfoldItem Id UnfoldingDetails EnclosingCcDetails #-} +data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-} +data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-} +data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-} +data TickType {-# GHC_PRAGMA UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction #-} +data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-} +data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-} +data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-} +data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-} +data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-} +data StgCaseAlternatives a b {-# GHC_PRAGMA StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) #-} +data StgCaseDefault a b {-# GHC_PRAGMA StgNoDefault | StgBindDefault a Bool (StgExpr a b) #-} +data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-} +data StgRhs a b {-# GHC_PRAGMA StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] #-} +data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-} +data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-} +data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-} +data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-} +type TyVarEnv a = UniqFM a +data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-} +data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-} +data Unique {-# GHC_PRAGMA MkUnique Int# #-} +data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-} +assoc :: Eq a => [Char] -> [(a, b)] -> a -> b + {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _S_ "LLSL" _N_ _SPECIALISE_ [ [Char], _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ UniType, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ PrimKind, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ } #-} +emptyBag :: Bag a + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Bag EmptyBag [u0] [] _N_ #-} +snocBag :: Bag a -> a -> Bag a + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-} +kindOfBasicLit :: BasicLit -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +typeOfBasicLit :: BasicLit -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +cAppend :: CSeq -> CSeq -> CSeq + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-} +cCh :: Char -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-} +cNil :: CSeq + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-} +cPStr :: _PackedString -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-} +cShow :: CSeq -> [Char] + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-} +cStr :: [Char] -> CSeq + {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-} +emptyFM :: FiniteMap a b + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, u1] [] _N_ #-} +cmpId :: Id -> Id -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +eqId :: Id -> Id -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +getIdKind :: Id -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns kindFromType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns kindFromType [ u5 ] _N_ #-} +getIdUniType :: Id -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_ #-} +cmpName :: Name -> Name -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqName :: Name -> Name -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-} +cmpByLocalName :: ProtoName -> ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpPString :: _PackedString -> _PackedString -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpProtoName :: ProtoName -> ProtoName -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqByLocalName :: ProtoName -> ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +eqProtoName :: ProtoName -> ProtoName -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-} +cmpUnique :: Unique -> Unique -> Int# + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> 0#; False -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> -1#; False -> 1#; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +eqUnique :: Unique -> Unique -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-} +equivClasses :: (a -> a -> Int#) -> [a] -> [[a]] + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +hasNoDups :: Eq a => [a] -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ } #-} +isIn :: Eq a => [Char] -> a -> [a] -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 1021 _N_ _S_ "LALS" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ _PackedString ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVar ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Name ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Class ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Id ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ BasicLit ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ MagicId ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Unique ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ } #-} +isSingleton :: [a] -> Bool + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +isn'tIn :: Eq a => [Char] -> a -> [a] -> Bool + {-# GHC_PRAGMA _A_ 4 _U_ 1021 _N_ _S_ "LALS" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVar ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Id ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ MagicId ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ (Id, Id) ] 1 { _A_ 0 _U_ 021 _N_ _N_ _N_ _N_ } #-} +kindFromType :: UniType -> PrimKind + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +lengthExceeds :: [a] -> Int -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SU(P)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-} +mapAccumB :: (b -> c -> a -> (b, c, d)) -> b -> c -> [a] -> (b, c, [d]) + {-# GHC_PRAGMA _A_ 4 _U_ 2221 _N_ _S_ "LLLS" _N_ _N_ #-} +mapAccumL :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c]) + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +mapAccumR :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c]) + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +mkUnknownSrcLoc :: SrcLoc + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +nOfThem :: Int -> a -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-} +naturalMergeSortLe :: (a -> a -> Bool) -> [a] -> [a] + {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-} +nullSpecEnv :: SpecEnv + {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-} +panic :: [Char] -> a + {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-} +pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLS" _N_ _N_ #-} +pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-} +ppDouble :: Double -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppInt :: Int -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 110 _N_ _S_ "LLA" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppInteger :: Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppNil :: Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "LA" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-} +ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-} +ppStr :: [Char] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-} +pprPanic :: [Char] -> (Int -> Bool -> PrettyRep) -> a + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ _!_ _N_ _N_ #-} +pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +pprTrace :: [Char] -> (Int -> Bool -> PrettyRep) -> a -> a + {-# GHC_PRAGMA _A_ 2 _U_ 112 _N_ _N_ _N_ _N_ #-} +switchIsOn :: (a -> SwitchResult) -> a -> Bool + {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-} +typeOfPat :: TypecheckedPat -> UniType + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +tagOf_PrimOp :: PrimOp -> Int# + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-} +pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-} +pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep + {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-} +removeDups :: (a -> a -> Int#) -> [a] -> ([a], [[a]]) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-} +runs :: (a -> a -> Bool) -> [a] -> [[a]] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +showUnique :: Unique -> _PackedString + {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-} +sortLt :: (a -> a -> Bool) -> [a] -> [a] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +transitiveClosure :: (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a] + {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-} +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-} +zipEqual :: [a] -> [b] -> [(a, b)] + {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-} + diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs new file mode 100644 index 0000000..7f0d406 --- /dev/null +++ b/ghc/compiler/utils/Util.lhs @@ -0,0 +1,1056 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Util]{Highly random utility functions} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +# define IF_NOT_GHC(a) {--} +#else +# define panic error +# define TAG_ _CMP_TAG +# define LT_ _LT +# define EQ_ _EQ +# define GT_ _GT +# define GT__ _ +# define tagCmp_ _tagCmp +# define FAST_STRING String +# define ASSERT(x) {-nothing-} +# define IF_NOT_GHC(a) a +# define COMMA , +#endif + +#ifndef __GLASGOW_HASKELL__ +# undef TAG_ +# undef LT_ +# undef EQ_ +# undef GT_ +# undef tagCmp_ +#endif + +module Util ( + -- Haskell-version support +#ifndef __GLASGOW_HASKELL__ + tagCmp_, + TAG_(..), +#endif + -- general list processing + IF_NOT_GHC(forall COMMA exists COMMA) + zipEqual, nOfThem, lengthExceeds, isSingleton, +#if defined(COMPILING_GHC) + isIn, isn'tIn, +#endif + + -- association lists + assoc, +#ifdef USE_SEMANTIQUE_STRANAL + clookup, clookrepl, elemIndex, (\\\), +#endif + + -- duplicate handling + hasNoDups, equivClasses, runs, removeDups, + + -- sorting + IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) + sortLt, + IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten + IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA) + + -- transitive closures + transitiveClosure, + + -- accumulating + mapAccumL, mapAccumR, mapAccumB, + + -- comparisons + IF_NOT_GHC(cmpString COMMA) +#ifdef USE_FAST_STRINGS + cmpPString, +#else + substr, +#endif + -- pairs + IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) + IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) + unzipWith + + -- error handling +#if defined(COMPILING_GHC) + , panic, pprPanic, pprTrace +# ifdef DEBUG + , assertPanic +# endif +#endif {- COMPILING_GHC -} + + -- and to make the interface self-sufficient... +#if __HASKELL1__ < 3 +# if defined(COMPILING_GHC) + , Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..) +# else + , Maybe +# endif +#endif + +#ifdef USE_ATTACK_PRAGMAS + -- as more-or-less of a *HACK*, Util exports + -- many types abstractly, so that pragmas will be + -- able to see them (given that most modules + -- import Util). + , + AbstractC, + ArgUsage, + ArgUsageInfo, + ArithSeqInfo, + ArityInfo, + Bag, + BasicLit, + Bind, + BinderInfo, + Binds, + CAddrMode, + CExprMacro, + CLabel, + CSeq, + CStmtMacro, + CcKind, + Class, + ClassDecl, + ClassOp, + ClassOpPragmas, + ClassPragmas, + ClosureInfo, + ConDecl, + CoreArg, + CoreAtom, + CoreBinding, + CoreCaseAlternatives, + CoreCaseDefault, + CoreExpr, + CostCentre, + DataPragmas, + DataTypeSig, + DefaultDecl, + DeforestInfo, + Delay, + Demand, + DemandInfo, + DuplicationDanger, + EnclosingCcDetails, + EndOfBlockInfo, + ExportFlag, + Expr, + FBConsum, + FBProd, + FBType, + FBTypeInfo, + FiniteMap, + FixityDecl, + FormSummary, + FullName, + FunOrArg, + GRHS, + GRHSsAndBinds, + GenPragmas, + GlobalSwitch, + HeapOffset, + IE, + Id, + IdDetails, + IdEnv(..), -- UGH + IdInfo, + IdVal, + IfaceImportDecl, + ImpStrictness, + ImpUnfolding, + ImportedInterface, + InPat, + InsideSCC, + Inst, + InstDecl, + InstOrigin, + InstTemplate, + InstTy, + InstancePragmas, + Interface, + IsDupdCC, IsCafCC, + LambdaFormInfo, + Literal, + MagicId, + MagicUnfoldingFun, + Match, + Module, + MonoBinds, + MonoType, + Name, + NamedThing(..), -- SIGH + OptIdInfo(..), -- SIGH + OrdList, + Outputable(..), -- SIGH + OverloadedLit, + PolyType, + PprStyle, + PrimKind, + PrimOp, + ProtoName, + Provenance, + Qual, + RegRelative, + Renaming, + ReturnInfo, + SMRep, + SMSpecRepKind, + SMUpdateKind, + Sequel, + ShortName, + Sig, + SimplCount, + SimplEnv, + SimplifierSwitch, + SpecEnv, + SpecInfo, + SpecialisedInstanceSig, + SplitUniqSupply, + SrcLoc, + StableLoc, + StandardFormInfo, + StgAtom, + StgBinderInfo, + StgBinding, + StgCaseAlternatives, + StgCaseDefault, + StgExpr, + StgRhs, + StrictnessInfo, + StubFlag, + SwitchResult, + TickType, + TyCon, + TyDecl, + TyVar, + TyVarEnv(..), + TyVarTemplate, + TypePragmas, + TypecheckedPat, + UfCostCentre, + UfId, + UnfoldEnv, + UnfoldItem, + UnfoldConApp, + UnfoldingCoreAlts, + UnfoldingCoreAtom, + UnfoldingCoreBinding, + UnfoldingCoreDefault, + UnfoldingCoreExpr, + UnfoldingDetails, + UnfoldingGuidance, + UnfoldingPrimOp, + UniType, + UniqFM, + Unique, + UniqueSupply, + UpdateFlag, + UpdateInfo, + VolatileLoc, + +#if ! OMIT_NATIVE_CODEGEN + Reg, + CodeSegment, + RegLoc, + StixReg, + StixTree, +#endif + + getIdUniType, typeOfBasicLit, typeOfPat, + getIdKind, kindOfBasicLit, + kindFromType, + + eqId, cmpId, + eqName, cmpName, + cmpProtoName, eqProtoName, + cmpByLocalName, eqByLocalName, + eqUnique, cmpUnique, + showUnique, + + switchIsOn, + + ppNil, ppStr, ppInt, ppInteger, ppDouble, +#if __GLASGOW_HASKELL__ >= 23 + ppRational, --- ??? +#endif + cNil, cStr, cAppend, cCh, cShow, +#if __GLASGOW_HASKELL__ >= 23 + cPStr, +#endif + +-- mkBlackHoleCLabel, + + emptyBag, snocBag, + emptyFM, +--OLD: emptySet, + nullSpecEnv, + + mkUnknownSrcLoc, + + pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType, + + tagOf_PrimOp, + pprPrimOp + +#endif {-USE_ATTACK_PRAGMAS-} + ) where + +#if defined(COMPILING_GHC) +IMPORT_Trace +import Pretty +#endif +#if __HASKELL1__ < 3 +import Maybes ( Maybe(..) ) +#endif + +#if defined(COMPILING_GHC) +import Id +import IdInfo +import Outputable + +# ifdef USE_ATTACK_PRAGMAS + +import AbsCSyn +import AbsSyn +import AbsUniType +import Bag +import BasicLit +import BinderInfo +import CLabelInfo +import CgBindery +import CgMonad +import CharSeq +import ClosureInfo +import CmdLineOpts +import CoreSyn +import FiniteMap +import HsCore +import HsPragmas +import Inst +import InstEnv +import Name +import NameTypes +import OrdList +import PlainCore +import PrimOps +import ProtoName +import CostCentre +import SMRep +import SimplEnv +import SimplMonad +import SplitUniq +import SrcLoc +import StgSyn +import TyVarEnv +import UniqFM +import Unique + +# if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +import MachDesc +import Stix +# endif + +# endif {-USE_ATTACK_PRAGMAS-} + +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell} +%* * +%************************************************************************ + +This is our own idea: +\begin{code} +#ifndef __GLASGOW_HASKELL__ +data TAG_ = LT_ | EQ_ | GT_ + +tagCmp_ :: Ord a => a -> a -> TAG_ +tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_ +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-lists]{General list processing} +%* * +%************************************************************************ + +Quantifiers are not standard in Haskell. The following fill in the gap. + +\begin{code} +forall :: (a -> Bool) -> [a] -> Bool +forall pred [] = True +forall pred (x:xs) = pred x && forall pred xs + +exists :: (a -> Bool) -> [a] -> Bool +exists pred [] = False +exists pred (x:xs) = pred x || exists pred xs +\end{code} + +A paranoid @zip@ that checks the lists are of equal length. +Alastair Reid thinks this should only happen if DEBUGging on; +hey, why not? + +\begin{code} +zipEqual :: [a] -> [b] -> [(a,b)] + +#ifndef DEBUG +zipEqual a b = zip a b +#else +zipEqual [] [] = [] +zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs +zipEqual as bs = panic "zipEqual: unequal lists" +#endif +\end{code} + +\begin{code} +nOfThem :: Int -> a -> [a] +nOfThem n thing = take n (repeat thing) + +lengthExceeds :: [a] -> Int -> Bool + +[] `lengthExceeds` n = 0 > n +(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1)) + +isSingleton :: [a] -> Bool + +isSingleton [x] = True +isSingleton _ = False +\end{code} + +Debugging/specialising versions of \tr{elem} and \tr{notElem} +\begin{code} +#if defined(COMPILING_GHC) +isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool + +# ifndef DEBUG +isIn msg x ys = elem__ x ys +isn'tIn msg x ys = notElem__ x ys + +--these are here to be SPECIALIZEd (automagically) +elem__ _ [] = False +elem__ x (y:ys) = x==y || elem__ x ys + +notElem__ x [] = True +notElem__ x (y:ys) = x /= y && notElem__ x ys + +# else {- DEBUG -} +isIn msg x ys + = elem ILIT(0) x ys + where + elem i _ [] = False + elem i x (y:ys) + | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg) + | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys + +isn'tIn msg x ys + = notElem ILIT(0) x ys + where + notElem i x [] = True + notElem i x (y:ys) + | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg) + | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys + +# endif {- DEBUG -} + +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-} +{-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-} +{-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-} +# endif + +#endif {- COMPILING_GHC -} +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-assoc]{Association lists} +%* * +%************************************************************************ + +See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@. + +\begin{code} +assoc :: (Eq a) => String -> [(a, b)] -> a -> b + +assoc crash_msg lst key + = if (null res) + then panic ("Failed in assoc: " ++ crash_msg) + else head res + where res = [ val | (key', val) <- lst, key == key'] + +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE assoc :: String -> [(Id, a)] -> Id -> a #-} +{-# SPECIALIZE assoc :: String -> [(Class, a)] -> Class -> a #-} +{-# SPECIALIZE assoc :: String -> [(Name, a)] -> Name -> a #-} +{-# SPECIALIZE assoc :: String -> [(PrimKind, a)] -> PrimKind -> a #-} +{-# SPECIALIZE assoc :: String -> [(String, a)] -> String -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyCon, a)] -> TyCon -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyVar, a)] -> TyVar -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-} +{-# SPECIALIZE assoc :: String -> [(UniType, a)] -> UniType -> a #-} +{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-} +# endif +#endif +\end{code} + +Given a list of associations one wants to look for the most recent +association for a given key. A couple of functions follow that cover +the simple lookup, the lookup with a default value when the key not +found, and two corresponding functions operating on unzipped lists +of associations. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL + +clookup :: (Eq a) => [a] -> [b] -> a -> b +clookup = clookupElse (panic "clookup") + where + -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b + clookupElse d [] [] a = d + clookupElse d (x:xs) (y:ys) a + | a==x = y + | True = clookupElse d xs ys a +#endif +\end{code} + +The following routine given a curried environment replaces the entry +labelled with a given name with a new value given. The new value is +given in the form of a function that allows to transform the old entry. + +Assumption is that the list of labels contains the given one and that +the two lists of the curried environment are of equal lengths. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b] +clookrepl (a:as) (b:bs) x f + = if x == a then (f b:bs) else (b:clookrepl as bs x f) +#endif +\end{code} + +The following returns the index of an element in a list. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL + +elemIndex :: Eq a => [a] -> a -> Int +elemIndex as x = indx as x 0 + where + indx :: Eq a => [a] -> a -> Int -> Int + indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int) +# if defined(COMPILING_GHC) + indx [] x n = pprPanic "element not in list in elemIndex" ppNil +# else + indx [] x n = error "element not in list in elemIndex" +# endif +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-dups]{Duplicate-handling} +%* * +%************************************************************************ + +List difference (non-associative). In the result of @xs \\\ ys@, the +first occurrence of each element of ys in turn (if any) has been +removed from xs. Thus, @(xs ++ ys) \\\ xs == ys@. This function is +a copy of @\\@ from report 1.1 and is added to overshade the buggy +version from the 1.0 version of Haskell. + +This routine can be removed after the compiler bootstraps itself and +a proper @\\@ is can be applied. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) = foldl del + where + [] `del` _ = [] + (x:xs) `del` y + | x == y = xs + | otherwise = x : xs `del` y +#endif +\end{code} + +\begin{code} +hasNoDups :: (Eq a) => [a] -> Bool +hasNoDups xs = f [] xs + where + f seen_so_far [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far then + False + else + f (x:seen_so_far) xs + +#if defined(COMPILING_GHC) + is_elem = isIn "hasNoDups" +#else + is_elem = elem +#endif +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-} +# endif +#endif +\end{code} + +\begin{code} +equivClasses :: (a -> a -> TAG_) -- Comparison + -> [a] + -> [[a]] + +equivClasses cmp stuff@[] = [] +equivClasses cmp stuff@[item] = [stuff] +equivClasses cmp items + = runs eq (sortLt lt items) + where + eq a b = case cmp a b of { EQ_ -> True; _ -> False } + lt a b = case cmp a b of { LT_ -> True; _ -> False } +\end{code} + +The first cases in @equivClasses@ above are just to cut to the point +more quickly... + +@runs@ groups a list into a list of lists, each sublist being a run of +identical elements of the input list. It is passed a predicate @p@ which +tells when two elements are equal. + +\begin{code} +runs :: (a -> a -> Bool) -- Equality + -> [a] + -> [[a]] + +runs p [] = [] +runs p (x:xs) = case (span (p x) xs) of + (first, rest) -> (x:first) : (runs p rest) +\end{code} + +\begin{code} +removeDups :: (a -> a -> TAG_) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [[a]]) -- List of duplicate groups. One representative from + -- each group appears in the first result + +removeDups cmp [] = ([], []) +removeDups cmp [x] = ([x],[]) +removeDups cmp xs + = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> + (xs', dups) } + where + collect_dups dups_so_far [x] = (dups_so_far, x) + collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-sorting]{Sorting} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection[Utils-quicksorting]{Quicksorts} +%* * +%************************************************************************ + +\begin{code} +-- tail-recursive, etc., "quicker sort" [as per Meira thesis] +quicksort :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- Input list + -> [a] -- Result list in increasing order + +quicksort lt [] = [] +quicksort lt [x] = [x] +quicksort lt (x:xs) = split x [] [] xs + where + split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi) + split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys + | True = split x lo (y:hi) ys +\end{code} + +Quicksort variant from Lennart's Haskell-library contribution. This +is a {\em stable} sort. + +\begin{code} +stableSortLt = sortLt -- synonym; when we want to highlight stable-ness + +sortLt :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- Input list + -> [a] -- Result list + +sortLt lt l = qsort lt l [] + +-- qsort is stable and does not concatenate. +qsort :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- xs, Input list + -> [a] -- r, Concatenate this list to the sorted input list + -> [a] -- Result = sort xs ++ r + +qsort lt [] r = r +qsort lt [x] r = x:r +qsort lt (x:xs) r = qpart lt x xs [] [] r + +-- qpart partitions and sorts the sublists +-- rlt contains things less than x, +-- rge contains the ones greater than or equal to x. +-- Both have equal elements reversed with respect to the original list. + +qpart lt x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort lt rlt (x : rqsort lt rge r) + +qpart lt x (y:ys) rlt rge r = + if lt y x then + -- y < x + qpart lt x ys (y:rlt) rge r + else + -- y >= x + qpart lt x ys rlt (y:rge) r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort lt [] r = r +rqsort lt [x] r = x:r +rqsort lt (x:xs) r = rqpart lt x xs [] [] r + +rqpart lt x [] rle rgt r = + qsort lt rle (x : qsort lt rgt r) + +rqpart lt x (y:ys) rle rgt r = + if lt x y then + -- y > x + rqpart lt x ys rle (y:rgt) r + else + -- y <= x + rqpart lt x ys (y:rle) rgt r +\end{code} + +%************************************************************************ +%* * +\subsubsection[Utils-dull-mergesort]{A rather dull mergesort} +%* * +%************************************************************************ + +\begin{code} +mergesort :: (a -> a -> TAG_) -> [a] -> [a] + +mergesort cmp xs = merge_lists (split_into_runs [] xs) + where + a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + + split_into_runs [] [] = [] + split_into_runs run [] = [run] + split_into_runs [] (x:xs) = split_into_runs [x] xs + split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs + split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs + | True = rl : (split_into_runs [x] xs) + + merge_lists [] = [] + merge_lists (x:xs) = merge x (merge_lists xs) + + merge [] ys = ys + merge xs [] = xs + merge xl@(x:xs) yl@(y:ys) + = case cmp x y of + EQ_ -> x : y : (merge xs ys) + LT_ -> x : (merge xs yl) + GT__ -> y : (merge xl ys) +\end{code} + +%************************************************************************ +%* * +\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} +%* * +%************************************************************************ + +\begin{display} +Date: Mon, 3 May 93 20:45:23 +0200 +From: Carsten Kehler Holst +To: partain@dcs.gla.ac.uk +Subject: natural merge sort beats quick sort [ and it is prettier ] + + Here a piece of Haskell code that I'm rather fond of. See it as an +attempt to get rid of the ridiculous quick-sort rutine. group is quite +useful by itself I think it was John's idea originally though I +believe the lazy version is due to me [surprisingly complicated]. +gamma [used to be called] called gamma because I got inspired by the Gamma calculus. It +is not very close to the calculus but does behave less sequential that +both foldr and foldl. One could imagine a version of gamma that took a +unit element as well thereby avoiding the problem with empty lists. + +I've tried this code against + + 1) insertion sort - as provided by haskell + 2) the normal implementation of quick sort + 3) a deforested version of quick sort due to Jan Sparud + 4) a super-optimized-quick-sort of Lennarts + +If the list is partially sorted both merge sort and in particular +natural merge sort wins. If the list is random [ average length of +rising subsequences = approx 2 ] mergesort still wins and natural +merge sort is marginally beeten by lennart's soqs. The space +consumption of merge sort is a bit worse than Lennarts quick sort +approx a factor of 2. And a lot worse if Sparud's bug-fix [see his +fpca article ] isn't used because of group. + +have fun +Carsten +\end{display} + +\begin{code} +group :: (a -> a -> Bool) -> [a] -> [[a]] +group p [] = [[]] +group p (x:xs) = + let ((h1:t1):tt1) = group p xs + (t,tt) = if null xs then ([],[]) else + if x `p` h1 then (h1:t1,tt1) else + ([], (h1:t1):tt1) + in ((x:t):tt) + +generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] +generalMerge p xs [] = xs +generalMerge p [] ys = ys +generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) + | y `p` x = y : generalMerge p (x:xs) ys + +-- gamma is now called balancedFold + +balancedFold :: (a -> a -> a) -> [a] -> a +balancedFold f [] = error "can't reduce an empty list using balancedFold" +balancedFold f [x] = x +balancedFold f l = balancedFold f (balancedFold' f l) + +balancedFold' :: (a -> a -> a) -> [a] -> [a] +balancedFold' f (x:y:xs) = f x y : balancedFold' f xs +balancedFold' f xs = xs + +generalMergeSort p = balancedFold (generalMerge p) . map (:[]) +generalNaturalMergeSort p = balancedFold (generalMerge p) . group p + +mergeSort, naturalMergeSort :: Ord a => [a] -> [a] + +mergeSort = generalMergeSort (<=) +naturalMergeSort = generalNaturalMergeSort (<=) + +mergeSortLe le = generalMergeSort le +naturalMergeSortLe le = generalNaturalMergeSort le +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-transitive-closure]{Transitive closure} +%* * +%************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. + +\begin{code} +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = do [] xs + where + do done [] = done + do done (x:xs) | x `is_in` done = do done xs + | otherwise = do (x:done) (succ x ++ xs) + + x `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-accum]{Accumulating} +%* * +%************************************************************************ + +@mapAccumL@ behaves like a combination +of @map@ and @foldl@; +it applies a function to each element of a list, passing an accumulating +parameter from left to right, and returning a final value of this +accumulator together with the new list. + +\begin{code} +mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list + +mapAccumL f b [] = (b, []) +mapAccumL f b (x:xs) = (b'', x':xs') where + (b', x') = f b x + (b'', xs') = mapAccumL f b' xs +\end{code} + +@mapAccumR@ does the same, but working from right to left instead. Its type is +the same as @mapAccumL@, though. + +\begin{code} +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list + +mapAccumR f b [] = (b, []) +mapAccumR f b (x:xs) = (b'', x':xs') where + (b'', x') = f b' x + (b', xs') = mapAccumR f b xs +\end{code} + +Here is the bi-directional version, that works from both left and right. + +\begin{code} +mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) + -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> accl -- Initial accumulator from left + -> accr -- Initial accumulator from right + -> [x] -- Input list + -> (accl, accr, [y]) -- Final accumulators and result list + +mapAccumB f a b [] = (a,b,[]) +mapAccumB f a b (x:xs) = (a'',b'',y:ys) + where + (a',b'',y) = f a b' x + (a'',b',ys) = mapAccumB f a' b xs +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-comparison]{Comparisons} +%* * +%************************************************************************ + +See also @tagCmp_@ near the versions-compatibility section. + +\begin{code} +cmpString :: String -> String -> TAG_ + +cmpString [] [] = EQ_ +cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys + else if x < y then LT_ + else GT_ +cmpString [] ys = LT_ +cmpString xs [] = GT_ + +cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here + cmpString s "" -- will never get here + } +\end{code} + +\begin{code} +#ifdef USE_FAST_STRINGS +cmpPString :: FAST_STRING -> FAST_STRING -> TAG_ + +cmpPString x y + = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } +#endif +\end{code} + +\begin{code} +#ifndef USE_FAST_STRINGS +substr :: FAST_STRING -> Int -> Int -> FAST_STRING + +substr str beg end + = ASSERT (beg >= 0 && beg <= end) + take (end - beg + 1) (drop beg str) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-pairs]{Pairs} +%* * +%************************************************************************ + +The following are curried versions of @fst@ and @snd@. + +\begin{code} +cfst :: a -> b -> a -- stranal-sem only (Note) +cfst x y = x +\end{code} + +The following provide us higher order functions that, when applied +to a function, operate on pairs. + +\begin{code} +applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d) +applyToPair (f,g) (x,y) = (f x, g y) + +applyToFst :: (a -> c) -> (a,b)-> (c,b) +applyToFst f (x,y) = (f x,y) + +applyToSnd :: (b -> d) -> (a,b) -> (a,d) +applyToSnd f (x,y) = (x,f y) + +foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) +foldPair fg ab [] = ab +foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) + where (u,v) = foldPair fg ab abs +\end{code} + +\begin{code} +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-errors]{Error handling} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) +panic x = error ("panic! (the `impossible' happened):\n\t" + ++ x ++ "\n\n" + ++ "Please report it as a compiler bug " + ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" ) + +pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg)) + +pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg)) + +# ifdef DEBUG +assertPanic :: String -> Int -> a +assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line) +# endif +#endif {- COMPILING_GHC -} +\end{code} diff --git a/ghc/compiler/yaccParser/Jmakefile b/ghc/compiler/yaccParser/Jmakefile new file mode 100644 index 0000000..15b12ea --- /dev/null +++ b/ghc/compiler/yaccParser/Jmakefile @@ -0,0 +1,112 @@ +#if IncludeTestDirsInBuild == YES +#define IHaveSubdirs +#define __ghc_parser_tests_dir tests +#else +#define __ghc_parser_tests_dir /* nothing */ +#endif + +SUBDIRS = __ghc_parser_tests_dir + +/* only subdir is the test suite */ +#define NoAllTargetForSubdirs +#define NoDocsTargetForSubdirs +#define NoInstallTargetForSubdirs +#define NoInstallDocsTargetForSubdirs +#define NoDependTargetForSubdirs +#define NoTagTargetForSubdirs + +YACC_OPTS = -d +/* add to this on the command line with, e.g., EXTRA_YACC_OPTS=-v */ + +#if BuildDataParallelHaskell == YES +D_DPH = -DDPH +#endif + +XCOMM D_DEBUG = -DDEBUG + +CPP_DEFINES = $(D_DEBUG) $(D_DPH) + +HSP_SRCS_C = /*main.c*/ hsparser.tab.c hslexer.c id.c atype.c ttype.c \ + tree.c literal.c coresyn.c list.c binding.c pbinding.c hpragma.c impidt.c \ + finfot.c util.c entidt.c syntax.c type2context.c import_dirlist.c infix.c printtree.c + +HSP_OBJS_O = /*main.o*/ hsparser.tab.o hslexer.o id.o atype.o ttype.o \ + tree.o literal.o coresyn.o list.o binding.o pbinding.o hpragma.o impidt.o \ + finfot.o util.o entidt.o syntax.o type2context.o import_dirlist.o infix.o printtree.o + +/* DPH uses some tweaked files; here are the lists again... */ + +#if BuildDataParallelHaskell == YES +DPH_HSP_SRCS_C = main.c hsparser-DPH.tab.c hslexer-DPH.c id.c atype.c ttype-DPH.c \ + tree-DPH.c literal.c coresyn.c list.c binding.c pbinding.c hpragma.c impidt.c \ + finfot.c util.c entidt.c syntax.c type2context.c import_dirlist.c infix.c printtree.c + +DPH_HSP_OBJS_O = main.o hsparser-DPH.tab.o hslexer-DPH.o id.o atype.o ttype-DPH.o \ + tree-DPH.o literal.o coresyn.o list.o binding.o pbinding.o hpragma.o impidt.o \ + finfot.o util.o entidt.o syntax.o type2context.o import_dirlist.o infix.o printtree.o +#endif + +/* this is for etags */ +REAL_HSP_SRCS_C = main.c id.c \ + util.c syntax.c type2context.c import_dirlist.c infix.c printtree.c + +UgenNeededHere(all depend) + +BuildPgmFromCFiles(hsp,main.o,$(FLEX_LIB),libhsp.a) +#if BuildDataParallelHaskell == YES +BuildPgmFromCFiles(dphsp,$(DPH_HSP_OBJS_O),$(LEX_LIB),) +#endif + +/* Most hsp files are in libhsp.a, so we can either make + a standalone parser, or incorporate the files into + the hsc compiler directly (WDP 94/10) +*/ +NormalLibraryTarget(hsp,$(HSP_OBJS_O)) + +#if DoInstallGHCSystem == YES +MakeDirectories(install, $(INSTLIBDIR_GHC)) +InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC)) +#if BuildDataParallelHaskell == YES +InstallBinaryTarget(dphsp,$(INSTLIBDIR_GHC)) +#endif +#endif /* DoInstall... */ + +YaccRunWithExpectMsg(hsparser,13,2) + +UgenTarget(atype) +UgenTarget(binding) +UgenTarget(coresyn) +UgenTarget(entidt) +UgenTarget(finfot) +UgenTarget(impidt) +UgenTarget(literal) +UgenTarget(list) +UgenTarget(pbinding) +UgenTarget(hpragma) +UgenTarget(tree) +UgenTarget(ttype) + +#if BuildDataParallelHaskell == YES +YaccRunWithExpectMsg(hsparser-DPH,12,4) +UgenTarget(tree-DPH) +UgenTarget(ttype-DPH) +#endif + +CDependTarget( $(HSP_SRCS_C) ) + +ExtraStuffToClean( y.output ) +ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) hsparser.tab.* hsparser-DPH.tab.* hslexer.c hslexer-DPH.c ) + +EtagsNeededHere(tags) /* need this to do "make tags" */ +ClearTagsFile() +CTagsTarget( *.y *.lex *.ugn $(REAL_HSP_SRCS_C) ) + + + + + + + + + + diff --git a/ghc/compiler/yaccParser/MAIL.byacc b/ghc/compiler/yaccParser/MAIL.byacc new file mode 100644 index 0000000..7c25fab --- /dev/null +++ b/ghc/compiler/yaccParser/MAIL.byacc @@ -0,0 +1,146 @@ +Return-Path: mattson@dcs.gla.ac.uk +Return-Path: +Received: from starbuck.dcs.gla.ac.uk by goggins.dcs.gla.ac.uk + with LOCAL SMTP (PP) id <02535-0@goggins.dcs.gla.ac.uk>; + Thu, 18 Nov 1993 09:59:57 +0000 +To: Robert.Corbett@Eng.Sun.COM +cc: partain@dcs.gla.ac.uk +Subject: Re: [Robert.Corbett@Eng.Sun.COM: Re: possible bug, byacc 1.9] +In-reply-to: Your message from 9:46 AM GMT +Date: Thu, 18 Nov 93 09:59:53 +0000 +From: Jim Mattson + +It's clear that this feature improves error detection, but it's not +clear to me how it improves the scope of possible error recoveries. + +If I understand your explanation, it sounds like the only alternative +(short of changing the byacc source) is to add tens or hundreds of +error productions sprinkled throughout the code anywhere that an +unexpected symbol may appear, since no intervening reductions are +allowed. + +Although the addition of all of these error productions increases the +scope of possible error recoveries, the same functionality (with, in fact, +the same approach) is provided by other versions of yacc. The apparent +advantage of other versions of yacc is that they provide a facility by +which a single _default_ error production can handle a number of +possibilities (after some possibly illegal reductions have been performed). + +Am I missing something? + +--jim +-------- +In reply to the following message: +-------- + +------- Forwarded Message + +Date: Wed, 17 Nov 93 22:33:44 PST +From: Robert.Corbett@Eng.Sun.COM (Robert Corbett) +Message-Id: <9311180633.AA07545@lupa.Eng.Sun.COM> +To: partain@dcs.gla.ac.uk +Subject: Re: possible bug, byacc 1.9 + +It is a feature. One difference between Berkeley Yacc and its +predecessors is that the parsers Berkeley Yacc produces detect +errors as soon as possible. That will lead to different behavior. + +In this particular case, the token "IN" is not a permitted +lookahead symbol in state 390. AT&T Yacc parsers will not detect +the error until after doing more reductions than Berkeley Yacc +parsers. Doing reductions in illegal contexts limits the scope of +recoveries that are possible (unless backtracking is possible). + +I am sorry that my attempt to provide better error detection is +causing you trouble. You can get the AT&T Yacc behavior by +replacing the routine sole_reduction in mkpar.c with a routine +that returns the most frequently occurring reduction. + + Yours truly, + Bob Corbett + +- ----- Begin Included Message ----- + +>From partain@dcs.gla.ac.uk Wed Nov 17 05:03:44 1993 +To: robert.corbett@Eng +Subject: possible bug, byacc 1.9 +Date: Wed, 17 Nov 93 12:33:42 +0000 +From: Will Partain + +Sadly, it's in a *HUGE* grammar, which I will send you if you have the +stomach for it. + +The problem occurs where {Sun's /usr/lang/yacc, bison} say: + + state 390 + + aexp -> var . (rule 356) + aexp -> var . AT aexp (rule 366) + + AT shift, and go to state 508 + $default reduce using rule 356 (aexp) + +but byacc says + + state 396 + aexp : var . (356) + aexp : var . AT aexp (366) + + AT shift 511 + error reduce 356 + VARID reduce 356 + CONID reduce 356 + VARSYM reduce 356 + CONSYM reduce 356 + MINUS reduce 356 + INTEGER reduce 356 + FLOAT reduce 356 + CHAR reduce 356 + STRING reduce 356 + CHARPRIM reduce 356 + INTPRIM reduce 356 + FLOATPRIM reduce 356 + DOUBLEPRIM reduce 356 + CLITLIT reduce 356 + VOIDPRIM reduce 356 + CCURLY reduce 356 + VCCURLY reduce 356 + SEMI reduce 356 + OBRACK reduce 356 + CBRACK reduce 356 + OPAREN reduce 356 + CPAREN reduce 356 + COMMA reduce 356 + BQUOTE reduce 356 + RARROW reduce 356 + VBAR reduce 356 + EQUAL reduce 356 + DOTDOT reduce 356 + DCOLON reduce 356 + LARROW reduce 356 + WILDCARD reduce 356 + LAZY reduce 356 + WHERE reduce 356 + OF reduce 356 + THEN reduce 356 + ELSE reduce 356 + PLUS reduce 356 + +The token that comes in is "IN"; bison/sun-yacc-generated parser +tickles the default, reduces to "aexp", but byacc-generated tickles +"error" and the rest is history. + +Maybe this is enough for you to exclaim, "Oh yes, that's a feature." + +As I say, more info if you want it. + +Will Partain + + +- ----- End Included Message ----- + + + +------- End of Forwarded Message + +-------- diff --git a/ghc/compiler/yaccParser/README-DPH b/ghc/compiler/yaccParser/README-DPH new file mode 100644 index 0000000..8b9647f --- /dev/null +++ b/ghc/compiler/yaccParser/README-DPH @@ -0,0 +1,241 @@ +The *-DPH.* files are for parsing Jon Hill's "Data Parallel Haskell" +variant. These notes indicate the differences from the regular +parser. If they are much changed from what's below, someone probably +needs to do some work. + +Note: you should also "grep" for "#ifdef DPH" in the C source files... + +Will Partain + +foreach i ( ttype.ugn tree.ugn hslexer.lex hsparser.y ) + set base=$i:r + set suff=$i:e + diff -c2 $i $base-DPH.$suff +end + +*** ttype.ugn Thu Nov 21 18:54:47 1991 +--- ttype-DPH.ugn Thu Jul 9 10:38:59 1992 +*************** +*** 12,15 **** +--- 12,18 ---- + context : < gtcontextl : list; + gtcontextt : ttype; >; ++ tproc : < gtpid : list; ++ gtdata : ttype; >; ++ tpod : < gtpod : ttype; >; + end; + +*** tree.ugn Thu May 14 17:13:43 1992 +--- tree-DPH.ugn Thu Jul 9 10:39:04 1992 +*************** +*** 62,64 **** +--- 62,75 ---- + gsccexp : tree; >; + negate : < gnexp : tree; >; ++ parzf : < gpzfexp : tree; ++ gpzfqual : list; >; ++ pardgen : < gdproc : tree; ++ gdexp : tree; >; ++ parigen : < giproc : tree; ++ giexp : tree; >; ++ parfilt : < gpfilt : tree; >; ++ pod : < gpod : list; >; ++ proc : < gpid : list; ++ gpdata : tree; >; ++ + end; +*** hslexer.lex Wed Jun 3 20:56:01 1992 +--- hslexer-DPH.lex Thu Jul 9 10:45:03 1992 +*************** +*** 17,20 **** +--- 17,21 ---- + * 04/12/91 kh Added Int#. * + * 31/01/92 kh Haskell 1.2 version. * ++ * 19/03/92 Jon Hill Added Data Parallel Notation * + * 24/04/92 ps Added 'scc'. * + * 03/06/92 kh Changed Infix/Prelude Handling. * +*************** +*** 560,563 **** +--- 561,570 ---- + "_" { RETURN(WILDCARD); } + "`" { RETURN(BQUOTE); } ++ "<<" { RETURN(OPOD); } ++ ">>" { RETURN(CPOD); } ++ "(|" { RETURN(OPROC); } ++ "|)" { RETURN(CPROC); } ++ "<<-" { RETURN(DRAWNFROM); } ++ "<<=" { RETURN(INDEXFROM); } + + ("-")?{N}"#" { +*** hsparser.y Thu Jul 9 10:58:27 1992 +--- hsparser-DPH.y Thu Jul 9 10:49:12 1992 +*************** +*** 5,9 **** + * Modified by: Kevin Hammond * + * Last date revised: December 13 1991. KH. * +! * Modification: Haskell 1.1 Syntax. * + * * + * * +--- 5,10 ---- + * Modified by: Kevin Hammond * + * Last date revised: December 13 1991. KH. * +! * Modification: o Haskell 1.1 Syntax. * +! * o Data Parallel Syntax. * + * * + * * +*************** +*** 15,19 **** + * * + * * +! * LALR(1) Syntax for Haskell 1.2 * + * * + **************************************************************************/ +--- 16,20 ---- + * * + * * +! * LALR(1) Syntax for Haskell 1.2 + Data Parallelism * + * * + **************************************************************************/ +*************** +*** 146,149 **** +--- 147,151 ---- + %token OBRACK CBRACK OPAREN CPAREN + %token COMMA BQUOTE ++ %token OPOD CPOD OPROC CPROC + + +*************** +*** 160,163 **** +--- 162,166 ---- + %token DCOLON LARROW + %token WILDCARD AT LAZY LAMBDA ++ %token DRAWNFROM INDEXFROM + + +*************** +*** 210,213 **** +--- 213,218 ---- + %left OCURLY OBRACK OPAREN + ++ %left OPOD OPROC ++ + %left EQUAL + +*************** +*** 238,241 **** +--- 243,248 ---- + upto + cexp ++ tyvar_pids ++ parquals + + +*************** +*** 246,249 **** +--- 253,257 ---- + dpatk fpatk opatk aapatk + texps ++ processor parqual + + %type MINUS VARID CONID VARSYM CONSYM +*************** +*** 605,610 **** +--- 613,629 ---- + | OBRACK tyvar CBRACK { $$ = mktllist($2); } + | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); } ++ | OPOD tyvar CPOD { $$ = mktpod($2); } ++ | OPROC tyvar_pids SEMI tyvar CPROC { $$ = mktproc($2,$4); } ++ | OPOD tyvar_pids SEMI tyvar CPOD { $$ = mktpod(mktproc($2,$4));} ++ | OPOD OPROC tyvar_pids SEMI tyvar CPROC CPOD ++ { $$ = mktpod(mktproc($3,$5)); } + ; + ++ /* Note (hilly) : Similar to tyvar_list except k>=1 not k>=2 */ ++ ++ tyvar_pids : tyvar COMMA tyvar_pids { $$ = mklcons($1,$3); } ++ | tyvar { $$ = lsing($1); } ++ ; ++ + defaultd: defaultkey dtypes + { +*************** +*** 740,743 **** +--- 759,765 ---- + | OPAREN type CPAREN { $$ = $2; } + | OBRACK type CBRACK { $$ = mktllist($2); } ++ | OPOD type CPOD { $$ = mktpod($2); } ++ | OPROC types SEMI type CPROC { $$ = mktproc($2,$4); } ++ | OPOD types SEMI type CPOD { $$ = mktpod(mktproc($2,$4));} + ; + +*************** +*** 1027,1030 **** +--- 1049,1055 ---- + | sequence { $$ = mkpar($1); } + | comprehension { $$ = mkpar($1); } ++ | OPOD exp VBAR parquals CPOD { $$ = mkparzf($2,$4); } ++ | OPOD exps CPOD { $$ = mkpod($2); } ++ | processor { $$ = mkpar($1); } + + /* These only occur in patterns */ +*************** +*** 1035,1038 **** +--- 1060,1076 ---- + + ++ processor : OPROC exps SEMI exp CPROC { $$ = mkproc($2,$4); } ++ ; ++ ++ parquals : parquals COMMA parqual { $$ = lapp($1,$3); } ++ | parqual { $$ = lsing($1); } ++ ; ++ ++ parqual : exp { $$ = mkparfilt($1); } ++ | processor DRAWNFROM exp { $$ = mkpardgen($1,$3); } ++ | processor INDEXFROM exp { $$ = mkparigen($1,$3); } ++ ; ++ ++ + /* + LHS patterns are parsed in a similar way to +*************** +*** 1131,1134 **** +--- 1169,1173 ---- + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } ++ | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); } + ; + +*************** +*** 1146,1149 **** +--- 1185,1189 ---- + | obrackkey CBRACK { $$ = mkllist(Lnil); } + | lazykey apat { $$ = mklazyp($2); } ++ | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); } + ; + +*************** +*** 1283,1286 **** +--- 1323,1327 ---- + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } ++ | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); } + ; + +*************** +*** 1312,1315 **** +--- 1353,1357 ---- + | obrackkey CBRACK { $$ = mkllist(Lnil); } + | lazykey apat { $$ = mklazyp($2); } ++ | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); } + ; + */ +*************** +*** 1372,1375 **** +--- 1414,1419 ---- + ; + ++ oprockey: OPROC { setstartlineno(); } ++ ; + + diff --git a/ghc/compiler/yaccParser/README.debug b/ghc/compiler/yaccParser/README.debug new file mode 100644 index 0000000..17503dd --- /dev/null +++ b/ghc/compiler/yaccParser/README.debug @@ -0,0 +1,12 @@ +If you want to debug... + +* the lexer: + + run "flex" with the -d flag; compile as normal thereafter + +* the parser: + + compile hsparser.tab.c and main.c with EXTRA_CC_OPTS=-DHSP_DEBUG + + run hsp with -D; it's dumping the output into *stdout*, + so you have to do something weird to look at it. diff --git a/ghc/compiler/yaccParser/U_atype.hi b/ghc/compiler/yaccParser/U_atype.hi new file mode 100644 index 0000000..4652a7c --- /dev/null +++ b/ghc/compiler/yaccParser/U_atype.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_atype where +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_list(U_list) +data U_atype = U_atc ProtoName U_list Int +rdU_atype :: _Addr -> _PackedString -> _State _RealWorld -> (U_atype, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_atype.hs b/ghc/compiler/yaccParser/U_atype.hs new file mode 100644 index 0000000..79ac302 --- /dev/null +++ b/ghc/compiler/yaccParser/U_atype.hs @@ -0,0 +1,22 @@ + + +module U_atype where +import UgenUtil +import Util + +import U_list +data U_atype = U_atc U_unkId U_list U_long + +rdU_atype :: _Addr -> UgnM U_atype +rdU_atype t + = ioToUgnM (_ccall_ tatype t) `thenUgn` \ tag@(I# _) -> + if tag == ``atc'' then + ioToUgnM (_ccall_ gatcid t) `thenUgn` \ x_gatcid -> + rdU_unkId x_gatcid `thenUgn` \ y_gatcid -> + ioToUgnM (_ccall_ gatctypel t) `thenUgn` \ x_gatctypel -> + rdU_list x_gatctypel `thenUgn` \ y_gatctypel -> + ioToUgnM (_ccall_ gatcline t) `thenUgn` \ x_gatcline -> + rdU_long x_gatcline `thenUgn` \ y_gatcline -> + returnUgn (U_atc y_gatcid y_gatctypel y_gatcline) + else + error ("rdU_atype: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_binding.hi b/ghc/compiler/yaccParser/U_binding.hi new file mode 100644 index 0000000..890ee5a --- /dev/null +++ b/ghc/compiler/yaccParser/U_binding.hi @@ -0,0 +1,11 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_binding where +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_hpragma(U_hpragma) +import U_list(U_list) +import U_ttype(U_ttype) +data U_binding = U_tbind U_list U_ttype U_list U_list Int U_hpragma | U_nbind U_ttype U_ttype Int U_hpragma | U_pbind U_list Int | U_fbind U_list Int | U_abind U_binding U_binding | U_lbind U_binding U_binding | U_ebind U_list U_binding Int | U_hbind U_list U_binding Int | U_ibind U_list ProtoName U_ttype U_binding Int U_hpragma | U_dbind U_list Int | U_cbind U_list U_ttype U_binding Int U_hpragma | U_sbind U_list U_ttype Int U_hpragma | U_mbind _PackedString U_list U_list Int | U_nullbind | U_import _PackedString U_list U_list U_binding _PackedString Int | U_hiding _PackedString U_list U_list U_binding _PackedString Int | U_vspec_uprag ProtoName U_list Int | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag ProtoName U_ttype Int | U_inline_uprag ProtoName U_list Int | U_deforest_uprag ProtoName Int | U_magicuf_uprag ProtoName _PackedString Int | U_abstract_uprag ProtoName Int | U_dspec_uprag ProtoName U_list Int +rdU_binding :: _Addr -> _PackedString -> _State _RealWorld -> (U_binding, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_binding.hs b/ghc/compiler/yaccParser/U_binding.hs new file mode 100644 index 0000000..aafdda1 --- /dev/null +++ b/ghc/compiler/yaccParser/U_binding.hs @@ -0,0 +1,222 @@ + + +module U_binding where +import UgenUtil +import Util + +import U_coresyn ( U_coresyn ) -- for interfaces only +import U_hpragma +import U_list +import U_literal ( U_literal ) -- for interfaces only +import U_ttype +data U_binding = U_tbind U_list U_ttype U_list U_list U_long U_hpragma | U_nbind U_ttype U_ttype U_long U_hpragma | U_pbind U_list U_long | U_fbind U_list U_long | U_abind U_binding U_binding | U_lbind U_binding U_binding | U_ebind U_list U_binding U_long | U_hbind U_list U_binding U_long | U_ibind U_list U_unkId U_ttype U_binding U_long U_hpragma | U_dbind U_list U_long | U_cbind U_list U_ttype U_binding U_long U_hpragma | U_sbind U_list U_ttype U_long U_hpragma | U_mbind U_stringId U_list U_list U_long | U_nullbind | U_import U_stringId U_list U_list U_binding U_stringId U_long | U_hiding U_stringId U_list U_list U_binding U_stringId U_long | U_vspec_uprag U_unkId U_list U_long | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag U_unkId U_ttype U_long | U_inline_uprag U_unkId U_list U_long | U_deforest_uprag U_unkId U_long | U_magicuf_uprag U_unkId U_stringId U_long | U_abstract_uprag U_unkId U_long | U_dspec_uprag U_unkId U_list U_long + +rdU_binding :: _Addr -> UgnM U_binding +rdU_binding t + = ioToUgnM (_ccall_ tbinding t) `thenUgn` \ tag@(I# _) -> + if tag == ``tbind'' then + ioToUgnM (_ccall_ gtbindc t) `thenUgn` \ x_gtbindc -> + rdU_list x_gtbindc `thenUgn` \ y_gtbindc -> + ioToUgnM (_ccall_ gtbindid t) `thenUgn` \ x_gtbindid -> + rdU_ttype x_gtbindid `thenUgn` \ y_gtbindid -> + ioToUgnM (_ccall_ gtbindl t) `thenUgn` \ x_gtbindl -> + rdU_list x_gtbindl `thenUgn` \ y_gtbindl -> + ioToUgnM (_ccall_ gtbindd t) `thenUgn` \ x_gtbindd -> + rdU_list x_gtbindd `thenUgn` \ y_gtbindd -> + ioToUgnM (_ccall_ gtline t) `thenUgn` \ x_gtline -> + rdU_long x_gtline `thenUgn` \ y_gtline -> + ioToUgnM (_ccall_ gtpragma t) `thenUgn` \ x_gtpragma -> + rdU_hpragma x_gtpragma `thenUgn` \ y_gtpragma -> + returnUgn (U_tbind y_gtbindc y_gtbindid y_gtbindl y_gtbindd y_gtline y_gtpragma) + else if tag == ``nbind'' then + ioToUgnM (_ccall_ gnbindid t) `thenUgn` \ x_gnbindid -> + rdU_ttype x_gnbindid `thenUgn` \ y_gnbindid -> + ioToUgnM (_ccall_ gnbindas t) `thenUgn` \ x_gnbindas -> + rdU_ttype x_gnbindas `thenUgn` \ y_gnbindas -> + ioToUgnM (_ccall_ gnline t) `thenUgn` \ x_gnline -> + rdU_long x_gnline `thenUgn` \ y_gnline -> + ioToUgnM (_ccall_ gnpragma t) `thenUgn` \ x_gnpragma -> + rdU_hpragma x_gnpragma `thenUgn` \ y_gnpragma -> + returnUgn (U_nbind y_gnbindid y_gnbindas y_gnline y_gnpragma) + else if tag == ``pbind'' then + ioToUgnM (_ccall_ gpbindl t) `thenUgn` \ x_gpbindl -> + rdU_list x_gpbindl `thenUgn` \ y_gpbindl -> + ioToUgnM (_ccall_ gpline t) `thenUgn` \ x_gpline -> + rdU_long x_gpline `thenUgn` \ y_gpline -> + returnUgn (U_pbind y_gpbindl y_gpline) + else if tag == ``fbind'' then + ioToUgnM (_ccall_ gfbindl t) `thenUgn` \ x_gfbindl -> + rdU_list x_gfbindl `thenUgn` \ y_gfbindl -> + ioToUgnM (_ccall_ gfline t) `thenUgn` \ x_gfline -> + rdU_long x_gfline `thenUgn` \ y_gfline -> + returnUgn (U_fbind y_gfbindl y_gfline) + else if tag == ``abind'' then + ioToUgnM (_ccall_ gabindfst t) `thenUgn` \ x_gabindfst -> + rdU_binding x_gabindfst `thenUgn` \ y_gabindfst -> + ioToUgnM (_ccall_ gabindsnd t) `thenUgn` \ x_gabindsnd -> + rdU_binding x_gabindsnd `thenUgn` \ y_gabindsnd -> + returnUgn (U_abind y_gabindfst y_gabindsnd) + else if tag == ``lbind'' then + ioToUgnM (_ccall_ glbindfst t) `thenUgn` \ x_glbindfst -> + rdU_binding x_glbindfst `thenUgn` \ y_glbindfst -> + ioToUgnM (_ccall_ glbindsnd t) `thenUgn` \ x_glbindsnd -> + rdU_binding x_glbindsnd `thenUgn` \ y_glbindsnd -> + returnUgn (U_lbind y_glbindfst y_glbindsnd) + else if tag == ``ebind'' then + ioToUgnM (_ccall_ gebindl t) `thenUgn` \ x_gebindl -> + rdU_list x_gebindl `thenUgn` \ y_gebindl -> + ioToUgnM (_ccall_ gebind t) `thenUgn` \ x_gebind -> + rdU_binding x_gebind `thenUgn` \ y_gebind -> + ioToUgnM (_ccall_ geline t) `thenUgn` \ x_geline -> + rdU_long x_geline `thenUgn` \ y_geline -> + returnUgn (U_ebind y_gebindl y_gebind y_geline) + else if tag == ``hbind'' then + ioToUgnM (_ccall_ ghbindl t) `thenUgn` \ x_ghbindl -> + rdU_list x_ghbindl `thenUgn` \ y_ghbindl -> + ioToUgnM (_ccall_ ghbind t) `thenUgn` \ x_ghbind -> + rdU_binding x_ghbind `thenUgn` \ y_ghbind -> + ioToUgnM (_ccall_ ghline t) `thenUgn` \ x_ghline -> + rdU_long x_ghline `thenUgn` \ y_ghline -> + returnUgn (U_hbind y_ghbindl y_ghbind y_ghline) + else if tag == ``ibind'' then + ioToUgnM (_ccall_ gibindc t) `thenUgn` \ x_gibindc -> + rdU_list x_gibindc `thenUgn` \ y_gibindc -> + ioToUgnM (_ccall_ gibindid t) `thenUgn` \ x_gibindid -> + rdU_unkId x_gibindid `thenUgn` \ y_gibindid -> + ioToUgnM (_ccall_ gibindi t) `thenUgn` \ x_gibindi -> + rdU_ttype x_gibindi `thenUgn` \ y_gibindi -> + ioToUgnM (_ccall_ gibindw t) `thenUgn` \ x_gibindw -> + rdU_binding x_gibindw `thenUgn` \ y_gibindw -> + ioToUgnM (_ccall_ giline t) `thenUgn` \ x_giline -> + rdU_long x_giline `thenUgn` \ y_giline -> + ioToUgnM (_ccall_ gipragma t) `thenUgn` \ x_gipragma -> + rdU_hpragma x_gipragma `thenUgn` \ y_gipragma -> + returnUgn (U_ibind y_gibindc y_gibindid y_gibindi y_gibindw y_giline y_gipragma) + else if tag == ``dbind'' then + ioToUgnM (_ccall_ gdbindts t) `thenUgn` \ x_gdbindts -> + rdU_list x_gdbindts `thenUgn` \ y_gdbindts -> + ioToUgnM (_ccall_ gdline t) `thenUgn` \ x_gdline -> + rdU_long x_gdline `thenUgn` \ y_gdline -> + returnUgn (U_dbind y_gdbindts y_gdline) + else if tag == ``cbind'' then + ioToUgnM (_ccall_ gcbindc t) `thenUgn` \ x_gcbindc -> + rdU_list x_gcbindc `thenUgn` \ y_gcbindc -> + ioToUgnM (_ccall_ gcbindid t) `thenUgn` \ x_gcbindid -> + rdU_ttype x_gcbindid `thenUgn` \ y_gcbindid -> + ioToUgnM (_ccall_ gcbindw t) `thenUgn` \ x_gcbindw -> + rdU_binding x_gcbindw `thenUgn` \ y_gcbindw -> + ioToUgnM (_ccall_ gcline t) `thenUgn` \ x_gcline -> + rdU_long x_gcline `thenUgn` \ y_gcline -> + ioToUgnM (_ccall_ gcpragma t) `thenUgn` \ x_gcpragma -> + rdU_hpragma x_gcpragma `thenUgn` \ y_gcpragma -> + returnUgn (U_cbind y_gcbindc y_gcbindid y_gcbindw y_gcline y_gcpragma) + else if tag == ``sbind'' then + ioToUgnM (_ccall_ gsbindids t) `thenUgn` \ x_gsbindids -> + rdU_list x_gsbindids `thenUgn` \ y_gsbindids -> + ioToUgnM (_ccall_ gsbindid t) `thenUgn` \ x_gsbindid -> + rdU_ttype x_gsbindid `thenUgn` \ y_gsbindid -> + ioToUgnM (_ccall_ gsline t) `thenUgn` \ x_gsline -> + rdU_long x_gsline `thenUgn` \ y_gsline -> + ioToUgnM (_ccall_ gspragma t) `thenUgn` \ x_gspragma -> + rdU_hpragma x_gspragma `thenUgn` \ y_gspragma -> + returnUgn (U_sbind y_gsbindids y_gsbindid y_gsline y_gspragma) + else if tag == ``mbind'' then + ioToUgnM (_ccall_ gmbindmodn t) `thenUgn` \ x_gmbindmodn -> + rdU_stringId x_gmbindmodn `thenUgn` \ y_gmbindmodn -> + ioToUgnM (_ccall_ gmbindimp t) `thenUgn` \ x_gmbindimp -> + rdU_list x_gmbindimp `thenUgn` \ y_gmbindimp -> + ioToUgnM (_ccall_ gmbindren t) `thenUgn` \ x_gmbindren -> + rdU_list x_gmbindren `thenUgn` \ y_gmbindren -> + ioToUgnM (_ccall_ gmline t) `thenUgn` \ x_gmline -> + rdU_long x_gmline `thenUgn` \ y_gmline -> + returnUgn (U_mbind y_gmbindmodn y_gmbindimp y_gmbindren y_gmline) + else if tag == ``nullbind'' then + returnUgn (U_nullbind ) + else if tag == ``import'' then + ioToUgnM (_ccall_ giebindmod t) `thenUgn` \ x_giebindmod -> + rdU_stringId x_giebindmod `thenUgn` \ y_giebindmod -> + ioToUgnM (_ccall_ giebindexp t) `thenUgn` \ x_giebindexp -> + rdU_list x_giebindexp `thenUgn` \ y_giebindexp -> + ioToUgnM (_ccall_ giebindren t) `thenUgn` \ x_giebindren -> + rdU_list x_giebindren `thenUgn` \ y_giebindren -> + ioToUgnM (_ccall_ giebinddef t) `thenUgn` \ x_giebinddef -> + rdU_binding x_giebinddef `thenUgn` \ y_giebinddef -> + ioToUgnM (_ccall_ giebindfile t) `thenUgn` \ x_giebindfile -> + rdU_stringId x_giebindfile `thenUgn` \ y_giebindfile -> + ioToUgnM (_ccall_ giebindline t) `thenUgn` \ x_giebindline -> + rdU_long x_giebindline `thenUgn` \ y_giebindline -> + returnUgn (U_import y_giebindmod y_giebindexp y_giebindren y_giebinddef y_giebindfile y_giebindline) + else if tag == ``hiding'' then + ioToUgnM (_ccall_ gihbindmod t) `thenUgn` \ x_gihbindmod -> + rdU_stringId x_gihbindmod `thenUgn` \ y_gihbindmod -> + ioToUgnM (_ccall_ gihbindexp t) `thenUgn` \ x_gihbindexp -> + rdU_list x_gihbindexp `thenUgn` \ y_gihbindexp -> + ioToUgnM (_ccall_ gihbindren t) `thenUgn` \ x_gihbindren -> + rdU_list x_gihbindren `thenUgn` \ y_gihbindren -> + ioToUgnM (_ccall_ gihbinddef t) `thenUgn` \ x_gihbinddef -> + rdU_binding x_gihbinddef `thenUgn` \ y_gihbinddef -> + ioToUgnM (_ccall_ gihbindfile t) `thenUgn` \ x_gihbindfile -> + rdU_stringId x_gihbindfile `thenUgn` \ y_gihbindfile -> + ioToUgnM (_ccall_ gihbindline t) `thenUgn` \ x_gihbindline -> + rdU_long x_gihbindline `thenUgn` \ y_gihbindline -> + returnUgn (U_hiding y_gihbindmod y_gihbindexp y_gihbindren y_gihbinddef y_gihbindfile y_gihbindline) + else if tag == ``vspec_uprag'' then + ioToUgnM (_ccall_ gvspec_id t) `thenUgn` \ x_gvspec_id -> + rdU_unkId x_gvspec_id `thenUgn` \ y_gvspec_id -> + ioToUgnM (_ccall_ gvspec_tys t) `thenUgn` \ x_gvspec_tys -> + rdU_list x_gvspec_tys `thenUgn` \ y_gvspec_tys -> + ioToUgnM (_ccall_ gvspec_line t) `thenUgn` \ x_gvspec_line -> + rdU_long x_gvspec_line `thenUgn` \ y_gvspec_line -> + returnUgn (U_vspec_uprag y_gvspec_id y_gvspec_tys y_gvspec_line) + else if tag == ``vspec_ty_and_id'' then + ioToUgnM (_ccall_ gvspec_ty t) `thenUgn` \ x_gvspec_ty -> + rdU_ttype x_gvspec_ty `thenUgn` \ y_gvspec_ty -> + ioToUgnM (_ccall_ gvspec_tyid t) `thenUgn` \ x_gvspec_tyid -> + rdU_list x_gvspec_tyid `thenUgn` \ y_gvspec_tyid -> + returnUgn (U_vspec_ty_and_id y_gvspec_ty y_gvspec_tyid) + else if tag == ``ispec_uprag'' then + ioToUgnM (_ccall_ gispec_clas t) `thenUgn` \ x_gispec_clas -> + rdU_unkId x_gispec_clas `thenUgn` \ y_gispec_clas -> + ioToUgnM (_ccall_ gispec_ty t) `thenUgn` \ x_gispec_ty -> + rdU_ttype x_gispec_ty `thenUgn` \ y_gispec_ty -> + ioToUgnM (_ccall_ gispec_line t) `thenUgn` \ x_gispec_line -> + rdU_long x_gispec_line `thenUgn` \ y_gispec_line -> + returnUgn (U_ispec_uprag y_gispec_clas y_gispec_ty y_gispec_line) + else if tag == ``inline_uprag'' then + ioToUgnM (_ccall_ ginline_id t) `thenUgn` \ x_ginline_id -> + rdU_unkId x_ginline_id `thenUgn` \ y_ginline_id -> + ioToUgnM (_ccall_ ginline_howto t) `thenUgn` \ x_ginline_howto -> + rdU_list x_ginline_howto `thenUgn` \ y_ginline_howto -> + ioToUgnM (_ccall_ ginline_line t) `thenUgn` \ x_ginline_line -> + rdU_long x_ginline_line `thenUgn` \ y_ginline_line -> + returnUgn (U_inline_uprag y_ginline_id y_ginline_howto y_ginline_line) + else if tag == ``deforest_uprag'' then + ioToUgnM (_ccall_ gdeforest_id t) `thenUgn` \ x_gdeforest_id -> + rdU_unkId x_gdeforest_id `thenUgn` \ y_gdeforest_id -> + ioToUgnM (_ccall_ gdeforest_line t) `thenUgn` \ x_gdeforest_line -> + rdU_long x_gdeforest_line `thenUgn` \ y_gdeforest_line -> + returnUgn (U_deforest_uprag y_gdeforest_id y_gdeforest_line) + else if tag == ``magicuf_uprag'' then + ioToUgnM (_ccall_ gmagicuf_id t) `thenUgn` \ x_gmagicuf_id -> + rdU_unkId x_gmagicuf_id `thenUgn` \ y_gmagicuf_id -> + ioToUgnM (_ccall_ gmagicuf_str t) `thenUgn` \ x_gmagicuf_str -> + rdU_stringId x_gmagicuf_str `thenUgn` \ y_gmagicuf_str -> + ioToUgnM (_ccall_ gmagicuf_line t) `thenUgn` \ x_gmagicuf_line -> + rdU_long x_gmagicuf_line `thenUgn` \ y_gmagicuf_line -> + returnUgn (U_magicuf_uprag y_gmagicuf_id y_gmagicuf_str y_gmagicuf_line) + else if tag == ``abstract_uprag'' then + ioToUgnM (_ccall_ gabstract_id t) `thenUgn` \ x_gabstract_id -> + rdU_unkId x_gabstract_id `thenUgn` \ y_gabstract_id -> + ioToUgnM (_ccall_ gabstract_line t) `thenUgn` \ x_gabstract_line -> + rdU_long x_gabstract_line `thenUgn` \ y_gabstract_line -> + returnUgn (U_abstract_uprag y_gabstract_id y_gabstract_line) + else if tag == ``dspec_uprag'' then + ioToUgnM (_ccall_ gdspec_id t) `thenUgn` \ x_gdspec_id -> + rdU_unkId x_gdspec_id `thenUgn` \ y_gdspec_id -> + ioToUgnM (_ccall_ gdspec_tys t) `thenUgn` \ x_gdspec_tys -> + rdU_list x_gdspec_tys `thenUgn` \ y_gdspec_tys -> + ioToUgnM (_ccall_ gdspec_line t) `thenUgn` \ x_gdspec_line -> + rdU_long x_gdspec_line `thenUgn` \ y_gdspec_line -> + returnUgn (U_dspec_uprag y_gdspec_id y_gdspec_tys y_gdspec_line) + else + error ("rdU_binding: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_coresyn.hi b/ghc/compiler/yaccParser/U_coresyn.hi new file mode 100644 index 0000000..f8cb66f --- /dev/null +++ b/ghc/compiler/yaccParser/U_coresyn.hi @@ -0,0 +1,12 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_coresyn where +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_list(U_list) +import U_literal(U_literal) +import U_ttype(U_ttype) +data U_coresyn + = U_cobinder ProtoName U_ttype | U_colit U_literal | U_colocal U_coresyn | U_cononrec U_coresyn U_coresyn | U_corec U_list | U_corec_pair U_coresyn U_coresyn | U_covar U_coresyn | U_coliteral U_literal | U_cocon U_coresyn U_list U_list | U_coprim U_coresyn U_list U_list | U_colam U_list U_coresyn | U_cotylam U_list U_coresyn | U_coapp U_coresyn U_list | U_cotyapp U_coresyn U_ttype | U_cocase U_coresyn U_coresyn | U_colet U_coresyn U_coresyn | U_coscc U_coresyn U_coresyn | U_coalg_alts U_list U_coresyn | U_coalg_alt U_coresyn U_list U_coresyn | U_coprim_alts U_list U_coresyn | U_coprim_alt U_literal U_coresyn | U_conodeflt | U_cobinddeflt U_coresyn U_coresyn | U_co_primop _PackedString | U_co_ccall _PackedString Int U_list U_ttype | U_co_casm U_literal Int U_list U_ttype | U_co_preludedictscc U_coresyn | U_co_alldictscc _PackedString _PackedString U_coresyn | U_co_usercc _PackedString _PackedString _PackedString U_coresyn U_coresyn | U_co_autocc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_dictcc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_scc_noncaf | U_co_scc_caf | U_co_scc_nondupd | U_co_scc_dupd | U_co_id _PackedString | U_co_orig_id _PackedString _PackedString | U_co_sdselid ProtoName ProtoName | U_co_classopid ProtoName ProtoName | U_co_defmid ProtoName ProtoName | U_co_dfunid ProtoName U_ttype | U_co_constmid ProtoName ProtoName U_ttype | U_co_specid U_coresyn U_list | U_co_wrkrid U_coresyn +rdU_coresyn :: _Addr -> _PackedString -> _State _RealWorld -> (U_coresyn, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_coresyn.hs b/ghc/compiler/yaccParser/U_coresyn.hs new file mode 100644 index 0000000..d3570df --- /dev/null +++ b/ghc/compiler/yaccParser/U_coresyn.hs @@ -0,0 +1,278 @@ + + +module U_coresyn where +import UgenUtil +import Util + +import U_list +import U_literal +import U_ttype +data U_coresyn = U_cobinder U_unkId U_ttype | U_colit U_literal | U_colocal U_coresyn | U_cononrec U_coresyn U_coresyn | U_corec U_list | U_corec_pair U_coresyn U_coresyn | U_covar U_coresyn | U_coliteral U_literal | U_cocon U_coresyn U_list U_list | U_coprim U_coresyn U_list U_list | U_colam U_list U_coresyn | U_cotylam U_list U_coresyn | U_coapp U_coresyn U_list | U_cotyapp U_coresyn U_ttype | U_cocase U_coresyn U_coresyn | U_colet U_coresyn U_coresyn | U_coscc U_coresyn U_coresyn | U_coalg_alts U_list U_coresyn | U_coalg_alt U_coresyn U_list U_coresyn | U_coprim_alts U_list U_coresyn | U_coprim_alt U_literal U_coresyn | U_conodeflt | U_cobinddeflt U_coresyn U_coresyn | U_co_primop U_stringId | U_co_ccall U_stringId U_long U_list U_ttype | U_co_casm U_literal U_long U_list U_ttype | U_co_preludedictscc U_coresyn | U_co_alldictscc U_hstring U_hstring U_coresyn | U_co_usercc U_hstring U_hstring U_hstring U_coresyn U_coresyn | U_co_autocc U_coresyn U_hstring U_hstring U_coresyn U_coresyn | U_co_dictcc U_coresyn U_hstring U_hstring U_coresyn U_coresyn | U_co_scc_noncaf | U_co_scc_caf | U_co_scc_nondupd | U_co_scc_dupd | U_co_id U_stringId | U_co_orig_id U_stringId U_stringId | U_co_sdselid U_unkId U_unkId | U_co_classopid U_unkId U_unkId | U_co_defmid U_unkId U_unkId | U_co_dfunid U_unkId U_ttype | U_co_constmid U_unkId U_unkId U_ttype | U_co_specid U_coresyn U_list | U_co_wrkrid U_coresyn + +rdU_coresyn :: _Addr -> UgnM U_coresyn +rdU_coresyn t + = ioToUgnM (_ccall_ tcoresyn t) `thenUgn` \ tag@(I# _) -> + if tag == ``cobinder'' then + ioToUgnM (_ccall_ gcobinder_v t) `thenUgn` \ x_gcobinder_v -> + rdU_unkId x_gcobinder_v `thenUgn` \ y_gcobinder_v -> + ioToUgnM (_ccall_ gcobinder_ty t) `thenUgn` \ x_gcobinder_ty -> + rdU_ttype x_gcobinder_ty `thenUgn` \ y_gcobinder_ty -> + returnUgn (U_cobinder y_gcobinder_v y_gcobinder_ty) + else if tag == ``colit'' then + ioToUgnM (_ccall_ gcolit t) `thenUgn` \ x_gcolit -> + rdU_literal x_gcolit `thenUgn` \ y_gcolit -> + returnUgn (U_colit y_gcolit) + else if tag == ``colocal'' then + ioToUgnM (_ccall_ gcolocal_v t) `thenUgn` \ x_gcolocal_v -> + rdU_coresyn x_gcolocal_v `thenUgn` \ y_gcolocal_v -> + returnUgn (U_colocal y_gcolocal_v) + else if tag == ``cononrec'' then + ioToUgnM (_ccall_ gcononrec_b t) `thenUgn` \ x_gcononrec_b -> + rdU_coresyn x_gcononrec_b `thenUgn` \ y_gcononrec_b -> + ioToUgnM (_ccall_ gcononrec_rhs t) `thenUgn` \ x_gcononrec_rhs -> + rdU_coresyn x_gcononrec_rhs `thenUgn` \ y_gcononrec_rhs -> + returnUgn (U_cononrec y_gcononrec_b y_gcononrec_rhs) + else if tag == ``corec'' then + ioToUgnM (_ccall_ gcorec t) `thenUgn` \ x_gcorec -> + rdU_list x_gcorec `thenUgn` \ y_gcorec -> + returnUgn (U_corec y_gcorec) + else if tag == ``corec_pair'' then + ioToUgnM (_ccall_ gcorec_b t) `thenUgn` \ x_gcorec_b -> + rdU_coresyn x_gcorec_b `thenUgn` \ y_gcorec_b -> + ioToUgnM (_ccall_ gcorec_rhs t) `thenUgn` \ x_gcorec_rhs -> + rdU_coresyn x_gcorec_rhs `thenUgn` \ y_gcorec_rhs -> + returnUgn (U_corec_pair y_gcorec_b y_gcorec_rhs) + else if tag == ``covar'' then + ioToUgnM (_ccall_ gcovar t) `thenUgn` \ x_gcovar -> + rdU_coresyn x_gcovar `thenUgn` \ y_gcovar -> + returnUgn (U_covar y_gcovar) + else if tag == ``coliteral'' then + ioToUgnM (_ccall_ gcoliteral t) `thenUgn` \ x_gcoliteral -> + rdU_literal x_gcoliteral `thenUgn` \ y_gcoliteral -> + returnUgn (U_coliteral y_gcoliteral) + else if tag == ``cocon'' then + ioToUgnM (_ccall_ gcocon_con t) `thenUgn` \ x_gcocon_con -> + rdU_coresyn x_gcocon_con `thenUgn` \ y_gcocon_con -> + ioToUgnM (_ccall_ gcocon_tys t) `thenUgn` \ x_gcocon_tys -> + rdU_list x_gcocon_tys `thenUgn` \ y_gcocon_tys -> + ioToUgnM (_ccall_ gcocon_args t) `thenUgn` \ x_gcocon_args -> + rdU_list x_gcocon_args `thenUgn` \ y_gcocon_args -> + returnUgn (U_cocon y_gcocon_con y_gcocon_tys y_gcocon_args) + else if tag == ``coprim'' then + ioToUgnM (_ccall_ gcoprim_op t) `thenUgn` \ x_gcoprim_op -> + rdU_coresyn x_gcoprim_op `thenUgn` \ y_gcoprim_op -> + ioToUgnM (_ccall_ gcoprim_tys t) `thenUgn` \ x_gcoprim_tys -> + rdU_list x_gcoprim_tys `thenUgn` \ y_gcoprim_tys -> + ioToUgnM (_ccall_ gcoprim_args t) `thenUgn` \ x_gcoprim_args -> + rdU_list x_gcoprim_args `thenUgn` \ y_gcoprim_args -> + returnUgn (U_coprim y_gcoprim_op y_gcoprim_tys y_gcoprim_args) + else if tag == ``colam'' then + ioToUgnM (_ccall_ gcolam_vars t) `thenUgn` \ x_gcolam_vars -> + rdU_list x_gcolam_vars `thenUgn` \ y_gcolam_vars -> + ioToUgnM (_ccall_ gcolam_body t) `thenUgn` \ x_gcolam_body -> + rdU_coresyn x_gcolam_body `thenUgn` \ y_gcolam_body -> + returnUgn (U_colam y_gcolam_vars y_gcolam_body) + else if tag == ``cotylam'' then + ioToUgnM (_ccall_ gcotylam_tvs t) `thenUgn` \ x_gcotylam_tvs -> + rdU_list x_gcotylam_tvs `thenUgn` \ y_gcotylam_tvs -> + ioToUgnM (_ccall_ gcotylam_body t) `thenUgn` \ x_gcotylam_body -> + rdU_coresyn x_gcotylam_body `thenUgn` \ y_gcotylam_body -> + returnUgn (U_cotylam y_gcotylam_tvs y_gcotylam_body) + else if tag == ``coapp'' then + ioToUgnM (_ccall_ gcoapp_fun t) `thenUgn` \ x_gcoapp_fun -> + rdU_coresyn x_gcoapp_fun `thenUgn` \ y_gcoapp_fun -> + ioToUgnM (_ccall_ gcoapp_args t) `thenUgn` \ x_gcoapp_args -> + rdU_list x_gcoapp_args `thenUgn` \ y_gcoapp_args -> + returnUgn (U_coapp y_gcoapp_fun y_gcoapp_args) + else if tag == ``cotyapp'' then + ioToUgnM (_ccall_ gcotyapp_e t) `thenUgn` \ x_gcotyapp_e -> + rdU_coresyn x_gcotyapp_e `thenUgn` \ y_gcotyapp_e -> + ioToUgnM (_ccall_ gcotyapp_t t) `thenUgn` \ x_gcotyapp_t -> + rdU_ttype x_gcotyapp_t `thenUgn` \ y_gcotyapp_t -> + returnUgn (U_cotyapp y_gcotyapp_e y_gcotyapp_t) + else if tag == ``cocase'' then + ioToUgnM (_ccall_ gcocase_s t) `thenUgn` \ x_gcocase_s -> + rdU_coresyn x_gcocase_s `thenUgn` \ y_gcocase_s -> + ioToUgnM (_ccall_ gcocase_alts t) `thenUgn` \ x_gcocase_alts -> + rdU_coresyn x_gcocase_alts `thenUgn` \ y_gcocase_alts -> + returnUgn (U_cocase y_gcocase_s y_gcocase_alts) + else if tag == ``colet'' then + ioToUgnM (_ccall_ gcolet_bind t) `thenUgn` \ x_gcolet_bind -> + rdU_coresyn x_gcolet_bind `thenUgn` \ y_gcolet_bind -> + ioToUgnM (_ccall_ gcolet_body t) `thenUgn` \ x_gcolet_body -> + rdU_coresyn x_gcolet_body `thenUgn` \ y_gcolet_body -> + returnUgn (U_colet y_gcolet_bind y_gcolet_body) + else if tag == ``coscc'' then + ioToUgnM (_ccall_ gcoscc_scc t) `thenUgn` \ x_gcoscc_scc -> + rdU_coresyn x_gcoscc_scc `thenUgn` \ y_gcoscc_scc -> + ioToUgnM (_ccall_ gcoscc_body t) `thenUgn` \ x_gcoscc_body -> + rdU_coresyn x_gcoscc_body `thenUgn` \ y_gcoscc_body -> + returnUgn (U_coscc y_gcoscc_scc y_gcoscc_body) + else if tag == ``coalg_alts'' then + ioToUgnM (_ccall_ gcoalg_alts t) `thenUgn` \ x_gcoalg_alts -> + rdU_list x_gcoalg_alts `thenUgn` \ y_gcoalg_alts -> + ioToUgnM (_ccall_ gcoalg_deflt t) `thenUgn` \ x_gcoalg_deflt -> + rdU_coresyn x_gcoalg_deflt `thenUgn` \ y_gcoalg_deflt -> + returnUgn (U_coalg_alts y_gcoalg_alts y_gcoalg_deflt) + else if tag == ``coalg_alt'' then + ioToUgnM (_ccall_ gcoalg_con t) `thenUgn` \ x_gcoalg_con -> + rdU_coresyn x_gcoalg_con `thenUgn` \ y_gcoalg_con -> + ioToUgnM (_ccall_ gcoalg_bs t) `thenUgn` \ x_gcoalg_bs -> + rdU_list x_gcoalg_bs `thenUgn` \ y_gcoalg_bs -> + ioToUgnM (_ccall_ gcoalg_rhs t) `thenUgn` \ x_gcoalg_rhs -> + rdU_coresyn x_gcoalg_rhs `thenUgn` \ y_gcoalg_rhs -> + returnUgn (U_coalg_alt y_gcoalg_con y_gcoalg_bs y_gcoalg_rhs) + else if tag == ``coprim_alts'' then + ioToUgnM (_ccall_ gcoprim_alts t) `thenUgn` \ x_gcoprim_alts -> + rdU_list x_gcoprim_alts `thenUgn` \ y_gcoprim_alts -> + ioToUgnM (_ccall_ gcoprim_deflt t) `thenUgn` \ x_gcoprim_deflt -> + rdU_coresyn x_gcoprim_deflt `thenUgn` \ y_gcoprim_deflt -> + returnUgn (U_coprim_alts y_gcoprim_alts y_gcoprim_deflt) + else if tag == ``coprim_alt'' then + ioToUgnM (_ccall_ gcoprim_lit t) `thenUgn` \ x_gcoprim_lit -> + rdU_literal x_gcoprim_lit `thenUgn` \ y_gcoprim_lit -> + ioToUgnM (_ccall_ gcoprim_rhs t) `thenUgn` \ x_gcoprim_rhs -> + rdU_coresyn x_gcoprim_rhs `thenUgn` \ y_gcoprim_rhs -> + returnUgn (U_coprim_alt y_gcoprim_lit y_gcoprim_rhs) + else if tag == ``conodeflt'' then + returnUgn (U_conodeflt ) + else if tag == ``cobinddeflt'' then + ioToUgnM (_ccall_ gcobinddeflt_v t) `thenUgn` \ x_gcobinddeflt_v -> + rdU_coresyn x_gcobinddeflt_v `thenUgn` \ y_gcobinddeflt_v -> + ioToUgnM (_ccall_ gcobinddeflt_rhs t) `thenUgn` \ x_gcobinddeflt_rhs -> + rdU_coresyn x_gcobinddeflt_rhs `thenUgn` \ y_gcobinddeflt_rhs -> + returnUgn (U_cobinddeflt y_gcobinddeflt_v y_gcobinddeflt_rhs) + else if tag == ``co_primop'' then + ioToUgnM (_ccall_ gco_primop t) `thenUgn` \ x_gco_primop -> + rdU_stringId x_gco_primop `thenUgn` \ y_gco_primop -> + returnUgn (U_co_primop y_gco_primop) + else if tag == ``co_ccall'' then + ioToUgnM (_ccall_ gco_ccall t) `thenUgn` \ x_gco_ccall -> + rdU_stringId x_gco_ccall `thenUgn` \ y_gco_ccall -> + ioToUgnM (_ccall_ gco_ccall_may_gc t) `thenUgn` \ x_gco_ccall_may_gc -> + rdU_long x_gco_ccall_may_gc `thenUgn` \ y_gco_ccall_may_gc -> + ioToUgnM (_ccall_ gco_ccall_arg_tys t) `thenUgn` \ x_gco_ccall_arg_tys -> + rdU_list x_gco_ccall_arg_tys `thenUgn` \ y_gco_ccall_arg_tys -> + ioToUgnM (_ccall_ gco_ccall_res_ty t) `thenUgn` \ x_gco_ccall_res_ty -> + rdU_ttype x_gco_ccall_res_ty `thenUgn` \ y_gco_ccall_res_ty -> + returnUgn (U_co_ccall y_gco_ccall y_gco_ccall_may_gc y_gco_ccall_arg_tys y_gco_ccall_res_ty) + else if tag == ``co_casm'' then + ioToUgnM (_ccall_ gco_casm t) `thenUgn` \ x_gco_casm -> + rdU_literal x_gco_casm `thenUgn` \ y_gco_casm -> + ioToUgnM (_ccall_ gco_casm_may_gc t) `thenUgn` \ x_gco_casm_may_gc -> + rdU_long x_gco_casm_may_gc `thenUgn` \ y_gco_casm_may_gc -> + ioToUgnM (_ccall_ gco_casm_arg_tys t) `thenUgn` \ x_gco_casm_arg_tys -> + rdU_list x_gco_casm_arg_tys `thenUgn` \ y_gco_casm_arg_tys -> + ioToUgnM (_ccall_ gco_casm_res_ty t) `thenUgn` \ x_gco_casm_res_ty -> + rdU_ttype x_gco_casm_res_ty `thenUgn` \ y_gco_casm_res_ty -> + returnUgn (U_co_casm y_gco_casm y_gco_casm_may_gc y_gco_casm_arg_tys y_gco_casm_res_ty) + else if tag == ``co_preludedictscc'' then + ioToUgnM (_ccall_ gco_preludedictscc_dupd t) `thenUgn` \ x_gco_preludedictscc_dupd -> + rdU_coresyn x_gco_preludedictscc_dupd `thenUgn` \ y_gco_preludedictscc_dupd -> + returnUgn (U_co_preludedictscc y_gco_preludedictscc_dupd) + else if tag == ``co_alldictscc'' then + ioToUgnM (_ccall_ gco_alldictscc_m t) `thenUgn` \ x_gco_alldictscc_m -> + rdU_hstring x_gco_alldictscc_m `thenUgn` \ y_gco_alldictscc_m -> + ioToUgnM (_ccall_ gco_alldictscc_g t) `thenUgn` \ x_gco_alldictscc_g -> + rdU_hstring x_gco_alldictscc_g `thenUgn` \ y_gco_alldictscc_g -> + ioToUgnM (_ccall_ gco_alldictscc_dupd t) `thenUgn` \ x_gco_alldictscc_dupd -> + rdU_coresyn x_gco_alldictscc_dupd `thenUgn` \ y_gco_alldictscc_dupd -> + returnUgn (U_co_alldictscc y_gco_alldictscc_m y_gco_alldictscc_g y_gco_alldictscc_dupd) + else if tag == ``co_usercc'' then + ioToUgnM (_ccall_ gco_usercc_n t) `thenUgn` \ x_gco_usercc_n -> + rdU_hstring x_gco_usercc_n `thenUgn` \ y_gco_usercc_n -> + ioToUgnM (_ccall_ gco_usercc_m t) `thenUgn` \ x_gco_usercc_m -> + rdU_hstring x_gco_usercc_m `thenUgn` \ y_gco_usercc_m -> + ioToUgnM (_ccall_ gco_usercc_g t) `thenUgn` \ x_gco_usercc_g -> + rdU_hstring x_gco_usercc_g `thenUgn` \ y_gco_usercc_g -> + ioToUgnM (_ccall_ gco_usercc_dupd t) `thenUgn` \ x_gco_usercc_dupd -> + rdU_coresyn x_gco_usercc_dupd `thenUgn` \ y_gco_usercc_dupd -> + ioToUgnM (_ccall_ gco_usercc_cafd t) `thenUgn` \ x_gco_usercc_cafd -> + rdU_coresyn x_gco_usercc_cafd `thenUgn` \ y_gco_usercc_cafd -> + returnUgn (U_co_usercc y_gco_usercc_n y_gco_usercc_m y_gco_usercc_g y_gco_usercc_dupd y_gco_usercc_cafd) + else if tag == ``co_autocc'' then + ioToUgnM (_ccall_ gco_autocc_i t) `thenUgn` \ x_gco_autocc_i -> + rdU_coresyn x_gco_autocc_i `thenUgn` \ y_gco_autocc_i -> + ioToUgnM (_ccall_ gco_autocc_m t) `thenUgn` \ x_gco_autocc_m -> + rdU_hstring x_gco_autocc_m `thenUgn` \ y_gco_autocc_m -> + ioToUgnM (_ccall_ gco_autocc_g t) `thenUgn` \ x_gco_autocc_g -> + rdU_hstring x_gco_autocc_g `thenUgn` \ y_gco_autocc_g -> + ioToUgnM (_ccall_ gco_autocc_dupd t) `thenUgn` \ x_gco_autocc_dupd -> + rdU_coresyn x_gco_autocc_dupd `thenUgn` \ y_gco_autocc_dupd -> + ioToUgnM (_ccall_ gco_autocc_cafd t) `thenUgn` \ x_gco_autocc_cafd -> + rdU_coresyn x_gco_autocc_cafd `thenUgn` \ y_gco_autocc_cafd -> + returnUgn (U_co_autocc y_gco_autocc_i y_gco_autocc_m y_gco_autocc_g y_gco_autocc_dupd y_gco_autocc_cafd) + else if tag == ``co_dictcc'' then + ioToUgnM (_ccall_ gco_dictcc_i t) `thenUgn` \ x_gco_dictcc_i -> + rdU_coresyn x_gco_dictcc_i `thenUgn` \ y_gco_dictcc_i -> + ioToUgnM (_ccall_ gco_dictcc_m t) `thenUgn` \ x_gco_dictcc_m -> + rdU_hstring x_gco_dictcc_m `thenUgn` \ y_gco_dictcc_m -> + ioToUgnM (_ccall_ gco_dictcc_g t) `thenUgn` \ x_gco_dictcc_g -> + rdU_hstring x_gco_dictcc_g `thenUgn` \ y_gco_dictcc_g -> + ioToUgnM (_ccall_ gco_dictcc_dupd t) `thenUgn` \ x_gco_dictcc_dupd -> + rdU_coresyn x_gco_dictcc_dupd `thenUgn` \ y_gco_dictcc_dupd -> + ioToUgnM (_ccall_ gco_dictcc_cafd t) `thenUgn` \ x_gco_dictcc_cafd -> + rdU_coresyn x_gco_dictcc_cafd `thenUgn` \ y_gco_dictcc_cafd -> + returnUgn (U_co_dictcc y_gco_dictcc_i y_gco_dictcc_m y_gco_dictcc_g y_gco_dictcc_dupd y_gco_dictcc_cafd) + else if tag == ``co_scc_noncaf'' then + returnUgn (U_co_scc_noncaf ) + else if tag == ``co_scc_caf'' then + returnUgn (U_co_scc_caf ) + else if tag == ``co_scc_nondupd'' then + returnUgn (U_co_scc_nondupd ) + else if tag == ``co_scc_dupd'' then + returnUgn (U_co_scc_dupd ) + else if tag == ``co_id'' then + ioToUgnM (_ccall_ gco_id t) `thenUgn` \ x_gco_id -> + rdU_stringId x_gco_id `thenUgn` \ y_gco_id -> + returnUgn (U_co_id y_gco_id) + else if tag == ``co_orig_id'' then + ioToUgnM (_ccall_ gco_orig_id_m t) `thenUgn` \ x_gco_orig_id_m -> + rdU_stringId x_gco_orig_id_m `thenUgn` \ y_gco_orig_id_m -> + ioToUgnM (_ccall_ gco_orig_id_n t) `thenUgn` \ x_gco_orig_id_n -> + rdU_stringId x_gco_orig_id_n `thenUgn` \ y_gco_orig_id_n -> + returnUgn (U_co_orig_id y_gco_orig_id_m y_gco_orig_id_n) + else if tag == ``co_sdselid'' then + ioToUgnM (_ccall_ gco_sdselid_c t) `thenUgn` \ x_gco_sdselid_c -> + rdU_unkId x_gco_sdselid_c `thenUgn` \ y_gco_sdselid_c -> + ioToUgnM (_ccall_ gco_sdselid_sc t) `thenUgn` \ x_gco_sdselid_sc -> + rdU_unkId x_gco_sdselid_sc `thenUgn` \ y_gco_sdselid_sc -> + returnUgn (U_co_sdselid y_gco_sdselid_c y_gco_sdselid_sc) + else if tag == ``co_classopid'' then + ioToUgnM (_ccall_ gco_classopid_c t) `thenUgn` \ x_gco_classopid_c -> + rdU_unkId x_gco_classopid_c `thenUgn` \ y_gco_classopid_c -> + ioToUgnM (_ccall_ gco_classopid_o t) `thenUgn` \ x_gco_classopid_o -> + rdU_unkId x_gco_classopid_o `thenUgn` \ y_gco_classopid_o -> + returnUgn (U_co_classopid y_gco_classopid_c y_gco_classopid_o) + else if tag == ``co_defmid'' then + ioToUgnM (_ccall_ gco_defmid_c t) `thenUgn` \ x_gco_defmid_c -> + rdU_unkId x_gco_defmid_c `thenUgn` \ y_gco_defmid_c -> + ioToUgnM (_ccall_ gco_defmid_op t) `thenUgn` \ x_gco_defmid_op -> + rdU_unkId x_gco_defmid_op `thenUgn` \ y_gco_defmid_op -> + returnUgn (U_co_defmid y_gco_defmid_c y_gco_defmid_op) + else if tag == ``co_dfunid'' then + ioToUgnM (_ccall_ gco_dfunid_c t) `thenUgn` \ x_gco_dfunid_c -> + rdU_unkId x_gco_dfunid_c `thenUgn` \ y_gco_dfunid_c -> + ioToUgnM (_ccall_ gco_dfunid_ty t) `thenUgn` \ x_gco_dfunid_ty -> + rdU_ttype x_gco_dfunid_ty `thenUgn` \ y_gco_dfunid_ty -> + returnUgn (U_co_dfunid y_gco_dfunid_c y_gco_dfunid_ty) + else if tag == ``co_constmid'' then + ioToUgnM (_ccall_ gco_constmid_c t) `thenUgn` \ x_gco_constmid_c -> + rdU_unkId x_gco_constmid_c `thenUgn` \ y_gco_constmid_c -> + ioToUgnM (_ccall_ gco_constmid_op t) `thenUgn` \ x_gco_constmid_op -> + rdU_unkId x_gco_constmid_op `thenUgn` \ y_gco_constmid_op -> + ioToUgnM (_ccall_ gco_constmid_ty t) `thenUgn` \ x_gco_constmid_ty -> + rdU_ttype x_gco_constmid_ty `thenUgn` \ y_gco_constmid_ty -> + returnUgn (U_co_constmid y_gco_constmid_c y_gco_constmid_op y_gco_constmid_ty) + else if tag == ``co_specid'' then + ioToUgnM (_ccall_ gco_specid_un t) `thenUgn` \ x_gco_specid_un -> + rdU_coresyn x_gco_specid_un `thenUgn` \ y_gco_specid_un -> + ioToUgnM (_ccall_ gco_specid_tys t) `thenUgn` \ x_gco_specid_tys -> + rdU_list x_gco_specid_tys `thenUgn` \ y_gco_specid_tys -> + returnUgn (U_co_specid y_gco_specid_un y_gco_specid_tys) + else if tag == ``co_wrkrid'' then + ioToUgnM (_ccall_ gco_wrkrid_un t) `thenUgn` \ x_gco_wrkrid_un -> + rdU_coresyn x_gco_wrkrid_un `thenUgn` \ y_gco_wrkrid_un -> + returnUgn (U_co_wrkrid y_gco_wrkrid_un) + else + error ("rdU_coresyn: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_entidt.hi b/ghc/compiler/yaccParser/U_entidt.hi new file mode 100644 index 0000000..b0b3f9e --- /dev/null +++ b/ghc/compiler/yaccParser/U_entidt.hi @@ -0,0 +1,8 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_entidt where +import PreludePS(_PackedString) +import U_list(U_list) +data U_entidt = U_entid _PackedString | U_enttype _PackedString | U_enttypeall _PackedString | U_enttypecons _PackedString U_list | U_entclass _PackedString U_list | U_entmod _PackedString +rdU_entidt :: _Addr -> _PackedString -> _State _RealWorld -> (U_entidt, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_entidt.hs b/ghc/compiler/yaccParser/U_entidt.hs new file mode 100644 index 0000000..5face2b --- /dev/null +++ b/ghc/compiler/yaccParser/U_entidt.hs @@ -0,0 +1,42 @@ + + +module U_entidt where +import UgenUtil +import Util + +import U_list +data U_entidt = U_entid U_stringId | U_enttype U_stringId | U_enttypeall U_stringId | U_enttypecons U_stringId U_list | U_entclass U_stringId U_list | U_entmod U_stringId + +rdU_entidt :: _Addr -> UgnM U_entidt +rdU_entidt t + = ioToUgnM (_ccall_ tentidt t) `thenUgn` \ tag@(I# _) -> + if tag == ``entid'' then + ioToUgnM (_ccall_ gentid t) `thenUgn` \ x_gentid -> + rdU_stringId x_gentid `thenUgn` \ y_gentid -> + returnUgn (U_entid y_gentid) + else if tag == ``enttype'' then + ioToUgnM (_ccall_ gitentid t) `thenUgn` \ x_gitentid -> + rdU_stringId x_gitentid `thenUgn` \ y_gitentid -> + returnUgn (U_enttype y_gitentid) + else if tag == ``enttypeall'' then + ioToUgnM (_ccall_ gatentid t) `thenUgn` \ x_gatentid -> + rdU_stringId x_gatentid `thenUgn` \ y_gatentid -> + returnUgn (U_enttypeall y_gatentid) + else if tag == ``enttypecons'' then + ioToUgnM (_ccall_ gctentid t) `thenUgn` \ x_gctentid -> + rdU_stringId x_gctentid `thenUgn` \ y_gctentid -> + ioToUgnM (_ccall_ gctentcons t) `thenUgn` \ x_gctentcons -> + rdU_list x_gctentcons `thenUgn` \ y_gctentcons -> + returnUgn (U_enttypecons y_gctentid y_gctentcons) + else if tag == ``entclass'' then + ioToUgnM (_ccall_ gcentid t) `thenUgn` \ x_gcentid -> + rdU_stringId x_gcentid `thenUgn` \ y_gcentid -> + ioToUgnM (_ccall_ gcentops t) `thenUgn` \ x_gcentops -> + rdU_list x_gcentops `thenUgn` \ y_gcentops -> + returnUgn (U_entclass y_gcentid y_gcentops) + else if tag == ``entmod'' then + ioToUgnM (_ccall_ gmentid t) `thenUgn` \ x_gmentid -> + rdU_stringId x_gmentid `thenUgn` \ y_gmentid -> + returnUgn (U_entmod y_gmentid) + else + error ("rdU_entidt: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_finfot.hi b/ghc/compiler/yaccParser/U_finfot.hi new file mode 100644 index 0000000..3f76893 --- /dev/null +++ b/ghc/compiler/yaccParser/U_finfot.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_finfot where +import PreludePS(_PackedString) +data U_finfot = U_nofinfo | U_finfo _PackedString _PackedString +rdU_finfot :: _Addr -> _PackedString -> _State _RealWorld -> (U_finfot, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_finfot.hs b/ghc/compiler/yaccParser/U_finfot.hs new file mode 100644 index 0000000..c6b7ea0 --- /dev/null +++ b/ghc/compiler/yaccParser/U_finfot.hs @@ -0,0 +1,20 @@ + + +module U_finfot where +import UgenUtil +import Util +data U_finfot = U_nofinfo | U_finfo U_stringId U_stringId + +rdU_finfot :: _Addr -> UgnM U_finfot +rdU_finfot t + = ioToUgnM (_ccall_ tfinfot t) `thenUgn` \ tag@(I# _) -> + if tag == ``nofinfo'' then + returnUgn (U_nofinfo ) + else if tag == ``finfo'' then + ioToUgnM (_ccall_ fi1 t) `thenUgn` \ x_fi1 -> + rdU_stringId x_fi1 `thenUgn` \ y_fi1 -> + ioToUgnM (_ccall_ fi2 t) `thenUgn` \ x_fi2 -> + rdU_stringId x_fi2 `thenUgn` \ y_fi2 -> + returnUgn (U_finfo y_fi1 y_fi2) + else + error ("rdU_finfot: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_hpragma.hi b/ghc/compiler/yaccParser/U_hpragma.hi new file mode 100644 index 0000000..273b68e --- /dev/null +++ b/ghc/compiler/yaccParser/U_hpragma.hi @@ -0,0 +1,10 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_hpragma where +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_coresyn(U_coresyn) +import U_list(U_list) +data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma _PackedString U_hpragma | U_iinst_const_pragma _PackedString U_hpragma U_list | U_iinst_spec_pragma _PackedString U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma Int | U_iupdate_pragma _PackedString | U_ideforest_pragma | U_istrictness_pragma _PackedString U_hpragma | U_imagic_unfolding_pragma _PackedString | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args Int Int _PackedString Int | U_iname_pragma_pr ProtoName U_hpragma | U_itype_pragma_pr U_list Int U_hpragma | U_iinst_pragma_3s U_list Int U_hpragma U_list | U_idata_pragma_4s U_list +rdU_hpragma :: _Addr -> _PackedString -> _State _RealWorld -> (U_hpragma, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_hpragma.hs b/ghc/compiler/yaccParser/U_hpragma.hs new file mode 100644 index 0000000..97c81bb --- /dev/null +++ b/ghc/compiler/yaccParser/U_hpragma.hs @@ -0,0 +1,139 @@ + + +module U_hpragma where +import UgenUtil +import Util + +import U_coresyn +import U_list +import U_literal ( U_literal ) -- ditto +import U_ttype ( U_ttype ) -- interface only +data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma U_stringId U_hpragma | U_iinst_const_pragma U_stringId U_hpragma U_list | U_iinst_spec_pragma U_stringId U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma U_numId | U_iupdate_pragma U_stringId | U_ideforest_pragma | U_istrictness_pragma U_hstring U_hpragma | U_imagic_unfolding_pragma U_stringId | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args U_numId U_numId U_stringId U_numId | U_iname_pragma_pr U_unkId U_hpragma | U_itype_pragma_pr U_list U_numId U_hpragma | U_iinst_pragma_3s U_list U_numId U_hpragma U_list | U_idata_pragma_4s U_list + +rdU_hpragma :: _Addr -> UgnM U_hpragma +rdU_hpragma t + = ioToUgnM (_ccall_ thpragma t) `thenUgn` \ tag@(I# _) -> + if tag == ``no_pragma'' then + returnUgn (U_no_pragma ) + else if tag == ``idata_pragma'' then + ioToUgnM (_ccall_ gprag_data_constrs t) `thenUgn` \ x_gprag_data_constrs -> + rdU_list x_gprag_data_constrs `thenUgn` \ y_gprag_data_constrs -> + ioToUgnM (_ccall_ gprag_data_specs t) `thenUgn` \ x_gprag_data_specs -> + rdU_list x_gprag_data_specs `thenUgn` \ y_gprag_data_specs -> + returnUgn (U_idata_pragma y_gprag_data_constrs y_gprag_data_specs) + else if tag == ``itype_pragma'' then + returnUgn (U_itype_pragma ) + else if tag == ``iclas_pragma'' then + ioToUgnM (_ccall_ gprag_clas t) `thenUgn` \ x_gprag_clas -> + rdU_list x_gprag_clas `thenUgn` \ y_gprag_clas -> + returnUgn (U_iclas_pragma y_gprag_clas) + else if tag == ``iclasop_pragma'' then + ioToUgnM (_ccall_ gprag_dsel t) `thenUgn` \ x_gprag_dsel -> + rdU_hpragma x_gprag_dsel `thenUgn` \ y_gprag_dsel -> + ioToUgnM (_ccall_ gprag_defm t) `thenUgn` \ x_gprag_defm -> + rdU_hpragma x_gprag_defm `thenUgn` \ y_gprag_defm -> + returnUgn (U_iclasop_pragma y_gprag_dsel y_gprag_defm) + else if tag == ``iinst_simpl_pragma'' then + ioToUgnM (_ccall_ gprag_imod_simpl t) `thenUgn` \ x_gprag_imod_simpl -> + rdU_stringId x_gprag_imod_simpl `thenUgn` \ y_gprag_imod_simpl -> + ioToUgnM (_ccall_ gprag_dfun_simpl t) `thenUgn` \ x_gprag_dfun_simpl -> + rdU_hpragma x_gprag_dfun_simpl `thenUgn` \ y_gprag_dfun_simpl -> + returnUgn (U_iinst_simpl_pragma y_gprag_imod_simpl y_gprag_dfun_simpl) + else if tag == ``iinst_const_pragma'' then + ioToUgnM (_ccall_ gprag_imod_const t) `thenUgn` \ x_gprag_imod_const -> + rdU_stringId x_gprag_imod_const `thenUgn` \ y_gprag_imod_const -> + ioToUgnM (_ccall_ gprag_dfun_const t) `thenUgn` \ x_gprag_dfun_const -> + rdU_hpragma x_gprag_dfun_const `thenUgn` \ y_gprag_dfun_const -> + ioToUgnM (_ccall_ gprag_constms t) `thenUgn` \ x_gprag_constms -> + rdU_list x_gprag_constms `thenUgn` \ y_gprag_constms -> + returnUgn (U_iinst_const_pragma y_gprag_imod_const y_gprag_dfun_const y_gprag_constms) + else if tag == ``iinst_spec_pragma'' then + ioToUgnM (_ccall_ gprag_imod_spec t) `thenUgn` \ x_gprag_imod_spec -> + rdU_stringId x_gprag_imod_spec `thenUgn` \ y_gprag_imod_spec -> + ioToUgnM (_ccall_ gprag_dfun_spec t) `thenUgn` \ x_gprag_dfun_spec -> + rdU_hpragma x_gprag_dfun_spec `thenUgn` \ y_gprag_dfun_spec -> + ioToUgnM (_ccall_ gprag_inst_specs t) `thenUgn` \ x_gprag_inst_specs -> + rdU_list x_gprag_inst_specs `thenUgn` \ y_gprag_inst_specs -> + returnUgn (U_iinst_spec_pragma y_gprag_imod_spec y_gprag_dfun_spec y_gprag_inst_specs) + else if tag == ``igen_pragma'' then + ioToUgnM (_ccall_ gprag_arity t) `thenUgn` \ x_gprag_arity -> + rdU_hpragma x_gprag_arity `thenUgn` \ y_gprag_arity -> + ioToUgnM (_ccall_ gprag_update t) `thenUgn` \ x_gprag_update -> + rdU_hpragma x_gprag_update `thenUgn` \ y_gprag_update -> + ioToUgnM (_ccall_ gprag_deforest t) `thenUgn` \ x_gprag_deforest -> + rdU_hpragma x_gprag_deforest `thenUgn` \ y_gprag_deforest -> + ioToUgnM (_ccall_ gprag_strictness t) `thenUgn` \ x_gprag_strictness -> + rdU_hpragma x_gprag_strictness `thenUgn` \ y_gprag_strictness -> + ioToUgnM (_ccall_ gprag_unfolding t) `thenUgn` \ x_gprag_unfolding -> + rdU_hpragma x_gprag_unfolding `thenUgn` \ y_gprag_unfolding -> + ioToUgnM (_ccall_ gprag_specs t) `thenUgn` \ x_gprag_specs -> + rdU_list x_gprag_specs `thenUgn` \ y_gprag_specs -> + returnUgn (U_igen_pragma y_gprag_arity y_gprag_update y_gprag_deforest y_gprag_strictness y_gprag_unfolding y_gprag_specs) + else if tag == ``iarity_pragma'' then + ioToUgnM (_ccall_ gprag_arity_val t) `thenUgn` \ x_gprag_arity_val -> + rdU_numId x_gprag_arity_val `thenUgn` \ y_gprag_arity_val -> + returnUgn (U_iarity_pragma y_gprag_arity_val) + else if tag == ``iupdate_pragma'' then + ioToUgnM (_ccall_ gprag_update_val t) `thenUgn` \ x_gprag_update_val -> + rdU_stringId x_gprag_update_val `thenUgn` \ y_gprag_update_val -> + returnUgn (U_iupdate_pragma y_gprag_update_val) + else if tag == ``ideforest_pragma'' then + returnUgn (U_ideforest_pragma ) + else if tag == ``istrictness_pragma'' then + ioToUgnM (_ccall_ gprag_strict_spec t) `thenUgn` \ x_gprag_strict_spec -> + rdU_hstring x_gprag_strict_spec `thenUgn` \ y_gprag_strict_spec -> + ioToUgnM (_ccall_ gprag_strict_wrkr t) `thenUgn` \ x_gprag_strict_wrkr -> + rdU_hpragma x_gprag_strict_wrkr `thenUgn` \ y_gprag_strict_wrkr -> + returnUgn (U_istrictness_pragma y_gprag_strict_spec y_gprag_strict_wrkr) + else if tag == ``imagic_unfolding_pragma'' then + ioToUgnM (_ccall_ gprag_magic_str t) `thenUgn` \ x_gprag_magic_str -> + rdU_stringId x_gprag_magic_str `thenUgn` \ y_gprag_magic_str -> + returnUgn (U_imagic_unfolding_pragma y_gprag_magic_str) + else if tag == ``iunfolding_pragma'' then + ioToUgnM (_ccall_ gprag_unfold_guide t) `thenUgn` \ x_gprag_unfold_guide -> + rdU_hpragma x_gprag_unfold_guide `thenUgn` \ y_gprag_unfold_guide -> + ioToUgnM (_ccall_ gprag_unfold_core t) `thenUgn` \ x_gprag_unfold_core -> + rdU_coresyn x_gprag_unfold_core `thenUgn` \ y_gprag_unfold_core -> + returnUgn (U_iunfolding_pragma y_gprag_unfold_guide y_gprag_unfold_core) + else if tag == ``iunfold_always'' then + returnUgn (U_iunfold_always ) + else if tag == ``iunfold_if_args'' then + ioToUgnM (_ccall_ gprag_unfold_if_t_args t) `thenUgn` \ x_gprag_unfold_if_t_args -> + rdU_numId x_gprag_unfold_if_t_args `thenUgn` \ y_gprag_unfold_if_t_args -> + ioToUgnM (_ccall_ gprag_unfold_if_v_args t) `thenUgn` \ x_gprag_unfold_if_v_args -> + rdU_numId x_gprag_unfold_if_v_args `thenUgn` \ y_gprag_unfold_if_v_args -> + ioToUgnM (_ccall_ gprag_unfold_if_con_args t) `thenUgn` \ x_gprag_unfold_if_con_args -> + rdU_stringId x_gprag_unfold_if_con_args `thenUgn` \ y_gprag_unfold_if_con_args -> + ioToUgnM (_ccall_ gprag_unfold_if_size t) `thenUgn` \ x_gprag_unfold_if_size -> + rdU_numId x_gprag_unfold_if_size `thenUgn` \ y_gprag_unfold_if_size -> + returnUgn (U_iunfold_if_args y_gprag_unfold_if_t_args y_gprag_unfold_if_v_args y_gprag_unfold_if_con_args y_gprag_unfold_if_size) + else if tag == ``iname_pragma_pr'' then + ioToUgnM (_ccall_ gprag_name_pr1 t) `thenUgn` \ x_gprag_name_pr1 -> + rdU_unkId x_gprag_name_pr1 `thenUgn` \ y_gprag_name_pr1 -> + ioToUgnM (_ccall_ gprag_name_pr2 t) `thenUgn` \ x_gprag_name_pr2 -> + rdU_hpragma x_gprag_name_pr2 `thenUgn` \ y_gprag_name_pr2 -> + returnUgn (U_iname_pragma_pr y_gprag_name_pr1 y_gprag_name_pr2) + else if tag == ``itype_pragma_pr'' then + ioToUgnM (_ccall_ gprag_type_pr1 t) `thenUgn` \ x_gprag_type_pr1 -> + rdU_list x_gprag_type_pr1 `thenUgn` \ y_gprag_type_pr1 -> + ioToUgnM (_ccall_ gprag_type_pr2 t) `thenUgn` \ x_gprag_type_pr2 -> + rdU_numId x_gprag_type_pr2 `thenUgn` \ y_gprag_type_pr2 -> + ioToUgnM (_ccall_ gprag_type_pr3 t) `thenUgn` \ x_gprag_type_pr3 -> + rdU_hpragma x_gprag_type_pr3 `thenUgn` \ y_gprag_type_pr3 -> + returnUgn (U_itype_pragma_pr y_gprag_type_pr1 y_gprag_type_pr2 y_gprag_type_pr3) + else if tag == ``iinst_pragma_3s'' then + ioToUgnM (_ccall_ gprag_inst_pt1 t) `thenUgn` \ x_gprag_inst_pt1 -> + rdU_list x_gprag_inst_pt1 `thenUgn` \ y_gprag_inst_pt1 -> + ioToUgnM (_ccall_ gprag_inst_pt2 t) `thenUgn` \ x_gprag_inst_pt2 -> + rdU_numId x_gprag_inst_pt2 `thenUgn` \ y_gprag_inst_pt2 -> + ioToUgnM (_ccall_ gprag_inst_pt3 t) `thenUgn` \ x_gprag_inst_pt3 -> + rdU_hpragma x_gprag_inst_pt3 `thenUgn` \ y_gprag_inst_pt3 -> + ioToUgnM (_ccall_ gprag_inst_pt4 t) `thenUgn` \ x_gprag_inst_pt4 -> + rdU_list x_gprag_inst_pt4 `thenUgn` \ y_gprag_inst_pt4 -> + returnUgn (U_iinst_pragma_3s y_gprag_inst_pt1 y_gprag_inst_pt2 y_gprag_inst_pt3 y_gprag_inst_pt4) + else if tag == ``idata_pragma_4s'' then + ioToUgnM (_ccall_ gprag_data_spec t) `thenUgn` \ x_gprag_data_spec -> + rdU_list x_gprag_data_spec `thenUgn` \ y_gprag_data_spec -> + returnUgn (U_idata_pragma_4s y_gprag_data_spec) + else + error ("rdU_hpragma: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_list.hi b/ghc/compiler/yaccParser/U_list.hi new file mode 100644 index 0000000..7888acb --- /dev/null +++ b/ghc/compiler/yaccParser/U_list.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_list where +import PreludePS(_PackedString) +data U_list = U_lcons _Addr U_list | U_lnil +rdU_list :: _Addr -> _PackedString -> _State _RealWorld -> (U_list, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_list.hs b/ghc/compiler/yaccParser/U_list.hs new file mode 100644 index 0000000..7e73e77 --- /dev/null +++ b/ghc/compiler/yaccParser/U_list.hs @@ -0,0 +1,20 @@ + + +module U_list where +import UgenUtil +import Util +data U_list = U_lcons U_VOID_STAR U_list | U_lnil + +rdU_list :: _Addr -> UgnM U_list +rdU_list t + = ioToUgnM (_ccall_ tlist t) `thenUgn` \ tag@(I# _) -> + if tag == ``lcons'' then + ioToUgnM (_ccall_ lhd t) `thenUgn` \ x_lhd -> + rdU_VOID_STAR x_lhd `thenUgn` \ y_lhd -> + ioToUgnM (_ccall_ ltl t) `thenUgn` \ x_ltl -> + rdU_list x_ltl `thenUgn` \ y_ltl -> + returnUgn (U_lcons y_lhd y_ltl) + else if tag == ``lnil'' then + returnUgn (U_lnil ) + else + error ("rdU_list: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_literal.hi b/ghc/compiler/yaccParser/U_literal.hi new file mode 100644 index 0000000..8137154 --- /dev/null +++ b/ghc/compiler/yaccParser/U_literal.hi @@ -0,0 +1,7 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_literal where +import PreludePS(_PackedString) +data U_literal = U_integer _PackedString | U_intprim _PackedString | U_floatr _PackedString | U_doubleprim _PackedString | U_floatprim _PackedString | U_charr _PackedString | U_charprim _PackedString | U_string _PackedString | U_stringprim _PackedString | U_clitlit _PackedString _PackedString | U_norepi _PackedString | U_norepr _PackedString _PackedString | U_noreps _PackedString +rdU_literal :: _Addr -> _PackedString -> _State _RealWorld -> (U_literal, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_literal.hs b/ghc/compiler/yaccParser/U_literal.hs new file mode 100644 index 0000000..97fb6ea --- /dev/null +++ b/ghc/compiler/yaccParser/U_literal.hs @@ -0,0 +1,68 @@ + + +module U_literal where +import UgenUtil +import Util +data U_literal = U_integer U_stringId | U_intprim U_stringId | U_floatr U_stringId | U_doubleprim U_stringId | U_floatprim U_stringId | U_charr U_hstring | U_charprim U_hstring | U_string U_hstring | U_stringprim U_hstring | U_clitlit U_stringId U_stringId | U_norepi U_stringId | U_norepr U_stringId U_stringId | U_noreps U_hstring + +rdU_literal :: _Addr -> UgnM U_literal +rdU_literal t + = ioToUgnM (_ccall_ tliteral t) `thenUgn` \ tag@(I# _) -> + if tag == ``integer'' then + ioToUgnM (_ccall_ ginteger t) `thenUgn` \ x_ginteger -> + rdU_stringId x_ginteger `thenUgn` \ y_ginteger -> + returnUgn (U_integer y_ginteger) + else if tag == ``intprim'' then + ioToUgnM (_ccall_ gintprim t) `thenUgn` \ x_gintprim -> + rdU_stringId x_gintprim `thenUgn` \ y_gintprim -> + returnUgn (U_intprim y_gintprim) + else if tag == ``floatr'' then + ioToUgnM (_ccall_ gfloatr t) `thenUgn` \ x_gfloatr -> + rdU_stringId x_gfloatr `thenUgn` \ y_gfloatr -> + returnUgn (U_floatr y_gfloatr) + else if tag == ``doubleprim'' then + ioToUgnM (_ccall_ gdoubleprim t) `thenUgn` \ x_gdoubleprim -> + rdU_stringId x_gdoubleprim `thenUgn` \ y_gdoubleprim -> + returnUgn (U_doubleprim y_gdoubleprim) + else if tag == ``floatprim'' then + ioToUgnM (_ccall_ gfloatprim t) `thenUgn` \ x_gfloatprim -> + rdU_stringId x_gfloatprim `thenUgn` \ y_gfloatprim -> + returnUgn (U_floatprim y_gfloatprim) + else if tag == ``charr'' then + ioToUgnM (_ccall_ gchar t) `thenUgn` \ x_gchar -> + rdU_hstring x_gchar `thenUgn` \ y_gchar -> + returnUgn (U_charr y_gchar) + else if tag == ``charprim'' then + ioToUgnM (_ccall_ gcharprim t) `thenUgn` \ x_gcharprim -> + rdU_hstring x_gcharprim `thenUgn` \ y_gcharprim -> + returnUgn (U_charprim y_gcharprim) + else if tag == ``string'' then + ioToUgnM (_ccall_ gstring t) `thenUgn` \ x_gstring -> + rdU_hstring x_gstring `thenUgn` \ y_gstring -> + returnUgn (U_string y_gstring) + else if tag == ``stringprim'' then + ioToUgnM (_ccall_ gstringprim t) `thenUgn` \ x_gstringprim -> + rdU_hstring x_gstringprim `thenUgn` \ y_gstringprim -> + returnUgn (U_stringprim y_gstringprim) + else if tag == ``clitlit'' then + ioToUgnM (_ccall_ gclitlit t) `thenUgn` \ x_gclitlit -> + rdU_stringId x_gclitlit `thenUgn` \ y_gclitlit -> + ioToUgnM (_ccall_ gclitlit_kind t) `thenUgn` \ x_gclitlit_kind -> + rdU_stringId x_gclitlit_kind `thenUgn` \ y_gclitlit_kind -> + returnUgn (U_clitlit y_gclitlit y_gclitlit_kind) + else if tag == ``norepi'' then + ioToUgnM (_ccall_ gnorepi t) `thenUgn` \ x_gnorepi -> + rdU_stringId x_gnorepi `thenUgn` \ y_gnorepi -> + returnUgn (U_norepi y_gnorepi) + else if tag == ``norepr'' then + ioToUgnM (_ccall_ gnorepr_n t) `thenUgn` \ x_gnorepr_n -> + rdU_stringId x_gnorepr_n `thenUgn` \ y_gnorepr_n -> + ioToUgnM (_ccall_ gnorepr_d t) `thenUgn` \ x_gnorepr_d -> + rdU_stringId x_gnorepr_d `thenUgn` \ y_gnorepr_d -> + returnUgn (U_norepr y_gnorepr_n y_gnorepr_d) + else if tag == ``noreps'' then + ioToUgnM (_ccall_ gnoreps t) `thenUgn` \ x_gnoreps -> + rdU_hstring x_gnoreps `thenUgn` \ y_gnoreps -> + returnUgn (U_noreps y_gnoreps) + else + error ("rdU_literal: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_pbinding.hi b/ghc/compiler/yaccParser/U_pbinding.hi new file mode 100644 index 0000000..65171f2 --- /dev/null +++ b/ghc/compiler/yaccParser/U_pbinding.hi @@ -0,0 +1,10 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_pbinding where +import PreludePS(_PackedString) +import U_binding(U_binding) +import U_list(U_list) +import U_treeHACK(U_tree) +data U_pbinding = U_pgrhs U_tree U_list U_binding _PackedString Int +rdU_pbinding :: _Addr -> _PackedString -> _State _RealWorld -> (U_pbinding, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_pbinding.hs b/ghc/compiler/yaccParser/U_pbinding.hs new file mode 100644 index 0000000..282fbaf --- /dev/null +++ b/ghc/compiler/yaccParser/U_pbinding.hs @@ -0,0 +1,32 @@ + + +module U_pbinding where +import UgenUtil +import Util + +import U_binding +import U_coresyn ( U_coresyn ) -- interface only +import U_hpragma ( U_hpragma ) -- interface only +import U_list +import U_literal ( U_literal ) -- ditto +import U_treeHACK +import U_ttype ( U_ttype ) -- ditto +data U_pbinding = U_pgrhs U_tree U_list U_binding U_stringId U_long + +rdU_pbinding :: _Addr -> UgnM U_pbinding +rdU_pbinding t + = ioToUgnM (_ccall_ tpbinding t) `thenUgn` \ tag@(I# _) -> + if tag == ``pgrhs'' then + ioToUgnM (_ccall_ ggpat t) `thenUgn` \ x_ggpat -> + rdU_tree x_ggpat `thenUgn` \ y_ggpat -> + ioToUgnM (_ccall_ ggdexprs t) `thenUgn` \ x_ggdexprs -> + rdU_list x_ggdexprs `thenUgn` \ y_ggdexprs -> + ioToUgnM (_ccall_ ggbind t) `thenUgn` \ x_ggbind -> + rdU_binding x_ggbind `thenUgn` \ y_ggbind -> + ioToUgnM (_ccall_ ggfuncname t) `thenUgn` \ x_ggfuncname -> + rdU_stringId x_ggfuncname `thenUgn` \ y_ggfuncname -> + ioToUgnM (_ccall_ ggline t) `thenUgn` \ x_ggline -> + rdU_long x_ggline `thenUgn` \ y_ggline -> + returnUgn (U_pgrhs y_ggpat y_ggdexprs y_ggbind y_ggfuncname y_ggline) + else + error ("rdU_pbinding: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_tree.hs b/ghc/compiler/yaccParser/U_tree.hs new file mode 100644 index 0000000..52ae1e6 --- /dev/null +++ b/ghc/compiler/yaccParser/U_tree.hs @@ -0,0 +1,184 @@ + + +module U_tree where +import UgenUtil +import Util + +import U_binding +import U_coresyn ( U_coresyn ) -- interface only +import U_hpragma ( U_hpragma ) -- interface only +import U_list +import U_literal +import U_ttype + +type U_infixTree = (ProtoName, U_tree, U_tree) + +rdU_infixTree :: _Addr -> UgnM U_infixTree +rdU_infixTree pt + = ioToUgnM (_casm_ ``%r = gident(*Rginfun_hs((struct Sap *)%0));'' pt) `thenUgn` \ op_t -> + ioToUgnM (_casm_ ``%r = (*Rginarg1_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t -> + ioToUgnM (_casm_ ``%r = (*Rginarg2_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t -> + + rdU_unkId op_t `thenUgn` \ op -> + rdU_tree arg1_t `thenUgn` \ arg1 -> + rdU_tree arg2_t `thenUgn` \ arg2 -> + returnUgn (op, arg1, arg2) +data U_tree = U_hmodule U_stringId U_list U_list U_binding U_long | U_ident U_unkId | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree U_long | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as U_unkId U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop U_infixTree | U_lsection U_tree U_unkId | U_rsection U_unkId U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall U_stringId U_stringId U_list | U_scc U_hstring U_tree | U_negate U_tree + +rdU_tree :: _Addr -> UgnM U_tree +rdU_tree t + = ioToUgnM (_ccall_ ttree t) `thenUgn` \ tag@(I# _) -> + if tag == ``hmodule'' then + ioToUgnM (_ccall_ ghname t) `thenUgn` \ x_ghname -> + rdU_stringId x_ghname `thenUgn` \ y_ghname -> + ioToUgnM (_ccall_ ghimplist t) `thenUgn` \ x_ghimplist -> + rdU_list x_ghimplist `thenUgn` \ y_ghimplist -> + ioToUgnM (_ccall_ ghexplist t) `thenUgn` \ x_ghexplist -> + rdU_list x_ghexplist `thenUgn` \ y_ghexplist -> + ioToUgnM (_ccall_ ghmodlist t) `thenUgn` \ x_ghmodlist -> + rdU_binding x_ghmodlist `thenUgn` \ y_ghmodlist -> + ioToUgnM (_ccall_ ghmodline t) `thenUgn` \ x_ghmodline -> + rdU_long x_ghmodline `thenUgn` \ y_ghmodline -> + returnUgn (U_hmodule y_ghname y_ghimplist y_ghexplist y_ghmodlist y_ghmodline) + else if tag == ``ident'' then + ioToUgnM (_ccall_ gident t) `thenUgn` \ x_gident -> + rdU_unkId x_gident `thenUgn` \ y_gident -> + returnUgn (U_ident y_gident) + else if tag == ``lit'' then + ioToUgnM (_ccall_ glit t) `thenUgn` \ x_glit -> + rdU_literal x_glit `thenUgn` \ y_glit -> + returnUgn (U_lit y_glit) + else if tag == ``tuple'' then + ioToUgnM (_ccall_ gtuplelist t) `thenUgn` \ x_gtuplelist -> + rdU_list x_gtuplelist `thenUgn` \ y_gtuplelist -> + returnUgn (U_tuple y_gtuplelist) + else if tag == ``ap'' then + ioToUgnM (_ccall_ gfun t) `thenUgn` \ x_gfun -> + rdU_tree x_gfun `thenUgn` \ y_gfun -> + ioToUgnM (_ccall_ garg t) `thenUgn` \ x_garg -> + rdU_tree x_garg `thenUgn` \ y_garg -> + returnUgn (U_ap y_gfun y_garg) + else if tag == ``lambda'' then + ioToUgnM (_ccall_ glampats t) `thenUgn` \ x_glampats -> + rdU_list x_glampats `thenUgn` \ y_glampats -> + ioToUgnM (_ccall_ glamexpr t) `thenUgn` \ x_glamexpr -> + rdU_tree x_glamexpr `thenUgn` \ y_glamexpr -> + ioToUgnM (_ccall_ glamline t) `thenUgn` \ x_glamline -> + rdU_long x_glamline `thenUgn` \ y_glamline -> + returnUgn (U_lambda y_glampats y_glamexpr y_glamline) + else if tag == ``let'' then + ioToUgnM (_ccall_ gletvdeflist t) `thenUgn` \ x_gletvdeflist -> + rdU_binding x_gletvdeflist `thenUgn` \ y_gletvdeflist -> + ioToUgnM (_ccall_ gletvexpr t) `thenUgn` \ x_gletvexpr -> + rdU_tree x_gletvexpr `thenUgn` \ y_gletvexpr -> + returnUgn (U_let y_gletvdeflist y_gletvexpr) + else if tag == ``casee'' then + ioToUgnM (_ccall_ gcaseexpr t) `thenUgn` \ x_gcaseexpr -> + rdU_tree x_gcaseexpr `thenUgn` \ y_gcaseexpr -> + ioToUgnM (_ccall_ gcasebody t) `thenUgn` \ x_gcasebody -> + rdU_list x_gcasebody `thenUgn` \ y_gcasebody -> + returnUgn (U_casee y_gcaseexpr y_gcasebody) + else if tag == ``ife'' then + ioToUgnM (_ccall_ gifpred t) `thenUgn` \ x_gifpred -> + rdU_tree x_gifpred `thenUgn` \ y_gifpred -> + ioToUgnM (_ccall_ gifthen t) `thenUgn` \ x_gifthen -> + rdU_tree x_gifthen `thenUgn` \ y_gifthen -> + ioToUgnM (_ccall_ gifelse t) `thenUgn` \ x_gifelse -> + rdU_tree x_gifelse `thenUgn` \ y_gifelse -> + returnUgn (U_ife y_gifpred y_gifthen y_gifelse) + else if tag == ``par'' then + ioToUgnM (_ccall_ gpare t) `thenUgn` \ x_gpare -> + rdU_tree x_gpare `thenUgn` \ y_gpare -> + returnUgn (U_par y_gpare) + else if tag == ``as'' then + ioToUgnM (_ccall_ gasid t) `thenUgn` \ x_gasid -> + rdU_unkId x_gasid `thenUgn` \ y_gasid -> + ioToUgnM (_ccall_ gase t) `thenUgn` \ x_gase -> + rdU_tree x_gase `thenUgn` \ y_gase -> + returnUgn (U_as y_gasid y_gase) + else if tag == ``lazyp'' then + ioToUgnM (_ccall_ glazyp t) `thenUgn` \ x_glazyp -> + rdU_tree x_glazyp `thenUgn` \ y_glazyp -> + returnUgn (U_lazyp y_glazyp) + else if tag == ``plusp'' then + ioToUgnM (_ccall_ gplusp t) `thenUgn` \ x_gplusp -> + rdU_tree x_gplusp `thenUgn` \ y_gplusp -> + ioToUgnM (_ccall_ gplusi t) `thenUgn` \ x_gplusi -> + rdU_literal x_gplusi `thenUgn` \ y_gplusi -> + returnUgn (U_plusp y_gplusp y_gplusi) + else if tag == ``wildp'' then + returnUgn (U_wildp ) + else if tag == ``restr'' then + ioToUgnM (_ccall_ grestre t) `thenUgn` \ x_grestre -> + rdU_tree x_grestre `thenUgn` \ y_grestre -> + ioToUgnM (_ccall_ grestrt t) `thenUgn` \ x_grestrt -> + rdU_ttype x_grestrt `thenUgn` \ y_grestrt -> + returnUgn (U_restr y_grestre y_grestrt) + else if tag == ``comprh'' then + ioToUgnM (_ccall_ gcexp t) `thenUgn` \ x_gcexp -> + rdU_tree x_gcexp `thenUgn` \ y_gcexp -> + ioToUgnM (_ccall_ gcquals t) `thenUgn` \ x_gcquals -> + rdU_list x_gcquals `thenUgn` \ y_gcquals -> + returnUgn (U_comprh y_gcexp y_gcquals) + else if tag == ``qual'' then + ioToUgnM (_ccall_ gqpat t) `thenUgn` \ x_gqpat -> + rdU_tree x_gqpat `thenUgn` \ y_gqpat -> + ioToUgnM (_ccall_ gqexp t) `thenUgn` \ x_gqexp -> + rdU_tree x_gqexp `thenUgn` \ y_gqexp -> + returnUgn (U_qual y_gqpat y_gqexp) + else if tag == ``guard'' then + ioToUgnM (_ccall_ ggexp t) `thenUgn` \ x_ggexp -> + rdU_tree x_ggexp `thenUgn` \ y_ggexp -> + returnUgn (U_guard y_ggexp) + else if tag == ``def'' then + ioToUgnM (_ccall_ ggdef t) `thenUgn` \ x_ggdef -> + rdU_tree x_ggdef `thenUgn` \ y_ggdef -> + returnUgn (U_def y_ggdef) + else if tag == ``tinfixop'' then + ioToUgnM (_ccall_ gdummy t) `thenUgn` \ x_gdummy -> + rdU_infixTree x_gdummy `thenUgn` \ y_gdummy -> + returnUgn (U_tinfixop y_gdummy) + else if tag == ``lsection'' then + ioToUgnM (_ccall_ glsexp t) `thenUgn` \ x_glsexp -> + rdU_tree x_glsexp `thenUgn` \ y_glsexp -> + ioToUgnM (_ccall_ glsop t) `thenUgn` \ x_glsop -> + rdU_unkId x_glsop `thenUgn` \ y_glsop -> + returnUgn (U_lsection y_glsexp y_glsop) + else if tag == ``rsection'' then + ioToUgnM (_ccall_ grsop t) `thenUgn` \ x_grsop -> + rdU_unkId x_grsop `thenUgn` \ y_grsop -> + ioToUgnM (_ccall_ grsexp t) `thenUgn` \ x_grsexp -> + rdU_tree x_grsexp `thenUgn` \ y_grsexp -> + returnUgn (U_rsection y_grsop y_grsexp) + else if tag == ``eenum'' then + ioToUgnM (_ccall_ gefrom t) `thenUgn` \ x_gefrom -> + rdU_tree x_gefrom `thenUgn` \ y_gefrom -> + ioToUgnM (_ccall_ gestep t) `thenUgn` \ x_gestep -> + rdU_list x_gestep `thenUgn` \ y_gestep -> + ioToUgnM (_ccall_ geto t) `thenUgn` \ x_geto -> + rdU_list x_geto `thenUgn` \ y_geto -> + returnUgn (U_eenum y_gefrom y_gestep y_geto) + else if tag == ``llist'' then + ioToUgnM (_ccall_ gllist t) `thenUgn` \ x_gllist -> + rdU_list x_gllist `thenUgn` \ y_gllist -> + returnUgn (U_llist y_gllist) + else if tag == ``ccall'' then + ioToUgnM (_ccall_ gccid t) `thenUgn` \ x_gccid -> + rdU_stringId x_gccid `thenUgn` \ y_gccid -> + ioToUgnM (_ccall_ gccinfo t) `thenUgn` \ x_gccinfo -> + rdU_stringId x_gccinfo `thenUgn` \ y_gccinfo -> + ioToUgnM (_ccall_ gccargs t) `thenUgn` \ x_gccargs -> + rdU_list x_gccargs `thenUgn` \ y_gccargs -> + returnUgn (U_ccall y_gccid y_gccinfo y_gccargs) + else if tag == ``scc'' then + ioToUgnM (_ccall_ gsccid t) `thenUgn` \ x_gsccid -> + rdU_hstring x_gsccid `thenUgn` \ y_gsccid -> + ioToUgnM (_ccall_ gsccexp t) `thenUgn` \ x_gsccexp -> + rdU_tree x_gsccexp `thenUgn` \ y_gsccexp -> + returnUgn (U_scc y_gsccid y_gsccexp) + else if tag == ``negate'' then + ioToUgnM (_ccall_ gnexp t) `thenUgn` \ x_gnexp -> + rdU_tree x_gnexp `thenUgn` \ y_gnexp -> + returnUgn (U_negate y_gnexp) + else + error ("rdU_tree: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_treeHACK.hi b/ghc/compiler/yaccParser/U_treeHACK.hi new file mode 100644 index 0000000..940d424 --- /dev/null +++ b/ghc/compiler/yaccParser/U_treeHACK.hi @@ -0,0 +1,15 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_treeHACK where +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_binding(U_binding) +import U_list(U_list) +import U_literal(U_literal) +import U_ttype(U_ttype) +type U_infixTree = (ProtoName, U_tree, U_tree) +data U_tree = U_hmodule _PackedString U_list U_list U_binding Int | U_ident ProtoName | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree Int | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as ProtoName U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop (ProtoName, U_tree, U_tree) | U_lsection U_tree ProtoName | U_rsection ProtoName U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall _PackedString _PackedString U_list | U_scc _PackedString U_tree | U_negate U_tree +rdU_infixTree :: _Addr -> _PackedString -> _State _RealWorld -> ((ProtoName, U_tree, U_tree), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_tree :: _Addr -> _PackedString -> _State _RealWorld -> (U_tree, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_treeHACK.hs b/ghc/compiler/yaccParser/U_treeHACK.hs new file mode 100644 index 0000000..c80d2f6 --- /dev/null +++ b/ghc/compiler/yaccParser/U_treeHACK.hs @@ -0,0 +1,185 @@ + + +module U_treeHACK where +import UgenUtil +import Util + +import U_binding +import U_coresyn ( U_coresyn ) -- interface only +import U_hpragma ( U_hpragma ) -- interface only +import U_list +import U_literal +import U_ttype + +type U_infixTree = (ProtoName, U_tree, U_tree) + +rdU_infixTree :: _Addr -> UgnM U_infixTree +rdU_infixTree pt + = ioToUgnM (_casm_ ``%r = gident(*Rginfun((struct Sap *)%0));'' pt) `thenUgn` \ op_t -> + ioToUgnM (_casm_ ``%r = (*Rginarg1((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t -> + ioToUgnM (_casm_ ``%r = (*Rginarg2((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t -> + + rdU_unkId op_t `thenUgn` \ op -> + rdU_tree arg1_t `thenUgn` \ arg1 -> + rdU_tree arg2_t `thenUgn` \ arg2 -> + returnUgn (op, arg1, arg2) + +data U_tree = U_hmodule U_stringId U_list U_list U_binding U_long | U_ident U_unkId | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree U_long | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as U_unkId U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop U_infixTree | U_lsection U_tree U_unkId | U_rsection U_unkId U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall U_stringId U_stringId U_list | U_scc U_hstring U_tree | U_negate U_tree + +rdU_tree :: _Addr -> UgnM U_tree +rdU_tree t + = ioToUgnM (_ccall_ ttree t) `thenUgn` \ tag@(I# _) -> + if tag == ``hmodule'' then + ioToUgnM (_ccall_ ghname t) `thenUgn` \ x_ghname -> + rdU_stringId x_ghname `thenUgn` \ y_ghname -> + ioToUgnM (_ccall_ ghimplist t) `thenUgn` \ x_ghimplist -> + rdU_list x_ghimplist `thenUgn` \ y_ghimplist -> + ioToUgnM (_ccall_ ghexplist t) `thenUgn` \ x_ghexplist -> + rdU_list x_ghexplist `thenUgn` \ y_ghexplist -> + ioToUgnM (_ccall_ ghmodlist t) `thenUgn` \ x_ghmodlist -> + rdU_binding x_ghmodlist `thenUgn` \ y_ghmodlist -> + ioToUgnM (_ccall_ ghmodline t) `thenUgn` \ x_ghmodline -> + rdU_long x_ghmodline `thenUgn` \ y_ghmodline -> + returnUgn (U_hmodule y_ghname y_ghimplist y_ghexplist y_ghmodlist y_ghmodline) + else if tag == ``ident'' then + ioToUgnM (_ccall_ gident t) `thenUgn` \ x_gident -> + rdU_unkId x_gident `thenUgn` \ y_gident -> + returnUgn (U_ident y_gident) + else if tag == ``lit'' then + ioToUgnM (_ccall_ glit t) `thenUgn` \ x_glit -> + rdU_literal x_glit `thenUgn` \ y_glit -> + returnUgn (U_lit y_glit) + else if tag == ``tuple'' then + ioToUgnM (_ccall_ gtuplelist t) `thenUgn` \ x_gtuplelist -> + rdU_list x_gtuplelist `thenUgn` \ y_gtuplelist -> + returnUgn (U_tuple y_gtuplelist) + else if tag == ``ap'' then + ioToUgnM (_ccall_ gfun t) `thenUgn` \ x_gfun -> + rdU_tree x_gfun `thenUgn` \ y_gfun -> + ioToUgnM (_ccall_ garg t) `thenUgn` \ x_garg -> + rdU_tree x_garg `thenUgn` \ y_garg -> + returnUgn (U_ap y_gfun y_garg) + else if tag == ``lambda'' then + ioToUgnM (_ccall_ glampats t) `thenUgn` \ x_glampats -> + rdU_list x_glampats `thenUgn` \ y_glampats -> + ioToUgnM (_ccall_ glamexpr t) `thenUgn` \ x_glamexpr -> + rdU_tree x_glamexpr `thenUgn` \ y_glamexpr -> + ioToUgnM (_ccall_ glamline t) `thenUgn` \ x_glamline -> + rdU_long x_glamline `thenUgn` \ y_glamline -> + returnUgn (U_lambda y_glampats y_glamexpr y_glamline) + else if tag == ``let'' then + ioToUgnM (_ccall_ gletvdeflist t) `thenUgn` \ x_gletvdeflist -> + rdU_binding x_gletvdeflist `thenUgn` \ y_gletvdeflist -> + ioToUgnM (_ccall_ gletvexpr t) `thenUgn` \ x_gletvexpr -> + rdU_tree x_gletvexpr `thenUgn` \ y_gletvexpr -> + returnUgn (U_let y_gletvdeflist y_gletvexpr) + else if tag == ``casee'' then + ioToUgnM (_ccall_ gcaseexpr t) `thenUgn` \ x_gcaseexpr -> + rdU_tree x_gcaseexpr `thenUgn` \ y_gcaseexpr -> + ioToUgnM (_ccall_ gcasebody t) `thenUgn` \ x_gcasebody -> + rdU_list x_gcasebody `thenUgn` \ y_gcasebody -> + returnUgn (U_casee y_gcaseexpr y_gcasebody) + else if tag == ``ife'' then + ioToUgnM (_ccall_ gifpred t) `thenUgn` \ x_gifpred -> + rdU_tree x_gifpred `thenUgn` \ y_gifpred -> + ioToUgnM (_ccall_ gifthen t) `thenUgn` \ x_gifthen -> + rdU_tree x_gifthen `thenUgn` \ y_gifthen -> + ioToUgnM (_ccall_ gifelse t) `thenUgn` \ x_gifelse -> + rdU_tree x_gifelse `thenUgn` \ y_gifelse -> + returnUgn (U_ife y_gifpred y_gifthen y_gifelse) + else if tag == ``par'' then + ioToUgnM (_ccall_ gpare t) `thenUgn` \ x_gpare -> + rdU_tree x_gpare `thenUgn` \ y_gpare -> + returnUgn (U_par y_gpare) + else if tag == ``as'' then + ioToUgnM (_ccall_ gasid t) `thenUgn` \ x_gasid -> + rdU_unkId x_gasid `thenUgn` \ y_gasid -> + ioToUgnM (_ccall_ gase t) `thenUgn` \ x_gase -> + rdU_tree x_gase `thenUgn` \ y_gase -> + returnUgn (U_as y_gasid y_gase) + else if tag == ``lazyp'' then + ioToUgnM (_ccall_ glazyp t) `thenUgn` \ x_glazyp -> + rdU_tree x_glazyp `thenUgn` \ y_glazyp -> + returnUgn (U_lazyp y_glazyp) + else if tag == ``plusp'' then + ioToUgnM (_ccall_ gplusp t) `thenUgn` \ x_gplusp -> + rdU_tree x_gplusp `thenUgn` \ y_gplusp -> + ioToUgnM (_ccall_ gplusi t) `thenUgn` \ x_gplusi -> + rdU_literal x_gplusi `thenUgn` \ y_gplusi -> + returnUgn (U_plusp y_gplusp y_gplusi) + else if tag == ``wildp'' then + returnUgn (U_wildp ) + else if tag == ``restr'' then + ioToUgnM (_ccall_ grestre t) `thenUgn` \ x_grestre -> + rdU_tree x_grestre `thenUgn` \ y_grestre -> + ioToUgnM (_ccall_ grestrt t) `thenUgn` \ x_grestrt -> + rdU_ttype x_grestrt `thenUgn` \ y_grestrt -> + returnUgn (U_restr y_grestre y_grestrt) + else if tag == ``comprh'' then + ioToUgnM (_ccall_ gcexp t) `thenUgn` \ x_gcexp -> + rdU_tree x_gcexp `thenUgn` \ y_gcexp -> + ioToUgnM (_ccall_ gcquals t) `thenUgn` \ x_gcquals -> + rdU_list x_gcquals `thenUgn` \ y_gcquals -> + returnUgn (U_comprh y_gcexp y_gcquals) + else if tag == ``qual'' then + ioToUgnM (_ccall_ gqpat t) `thenUgn` \ x_gqpat -> + rdU_tree x_gqpat `thenUgn` \ y_gqpat -> + ioToUgnM (_ccall_ gqexp t) `thenUgn` \ x_gqexp -> + rdU_tree x_gqexp `thenUgn` \ y_gqexp -> + returnUgn (U_qual y_gqpat y_gqexp) + else if tag == ``guard'' then + ioToUgnM (_ccall_ ggexp t) `thenUgn` \ x_ggexp -> + rdU_tree x_ggexp `thenUgn` \ y_ggexp -> + returnUgn (U_guard y_ggexp) + else if tag == ``def'' then + ioToUgnM (_ccall_ ggdef t) `thenUgn` \ x_ggdef -> + rdU_tree x_ggdef `thenUgn` \ y_ggdef -> + returnUgn (U_def y_ggdef) + else if tag == ``tinfixop'' then +-- ioToUgnM (_ccall_ gdummy t) `thenUgn` \ x_gdummy -> + rdU_infixTree t {-THIS IS THE HACK-} `thenUgn` \ y_gdummy -> + returnUgn (U_tinfixop y_gdummy) + else if tag == ``lsection'' then + ioToUgnM (_ccall_ glsexp t) `thenUgn` \ x_glsexp -> + rdU_tree x_glsexp `thenUgn` \ y_glsexp -> + ioToUgnM (_ccall_ glsop t) `thenUgn` \ x_glsop -> + rdU_unkId x_glsop `thenUgn` \ y_glsop -> + returnUgn (U_lsection y_glsexp y_glsop) + else if tag == ``rsection'' then + ioToUgnM (_ccall_ grsop t) `thenUgn` \ x_grsop -> + rdU_unkId x_grsop `thenUgn` \ y_grsop -> + ioToUgnM (_ccall_ grsexp t) `thenUgn` \ x_grsexp -> + rdU_tree x_grsexp `thenUgn` \ y_grsexp -> + returnUgn (U_rsection y_grsop y_grsexp) + else if tag == ``eenum'' then + ioToUgnM (_ccall_ gefrom t) `thenUgn` \ x_gefrom -> + rdU_tree x_gefrom `thenUgn` \ y_gefrom -> + ioToUgnM (_ccall_ gestep t) `thenUgn` \ x_gestep -> + rdU_list x_gestep `thenUgn` \ y_gestep -> + ioToUgnM (_ccall_ geto t) `thenUgn` \ x_geto -> + rdU_list x_geto `thenUgn` \ y_geto -> + returnUgn (U_eenum y_gefrom y_gestep y_geto) + else if tag == ``llist'' then + ioToUgnM (_ccall_ gllist t) `thenUgn` \ x_gllist -> + rdU_list x_gllist `thenUgn` \ y_gllist -> + returnUgn (U_llist y_gllist) + else if tag == ``ccall'' then + ioToUgnM (_ccall_ gccid t) `thenUgn` \ x_gccid -> + rdU_stringId x_gccid `thenUgn` \ y_gccid -> + ioToUgnM (_ccall_ gccinfo t) `thenUgn` \ x_gccinfo -> + rdU_stringId x_gccinfo `thenUgn` \ y_gccinfo -> + ioToUgnM (_ccall_ gccargs t) `thenUgn` \ x_gccargs -> + rdU_list x_gccargs `thenUgn` \ y_gccargs -> + returnUgn (U_ccall y_gccid y_gccinfo y_gccargs) + else if tag == ``scc'' then + ioToUgnM (_ccall_ gsccid t) `thenUgn` \ x_gsccid -> + rdU_hstring x_gsccid `thenUgn` \ y_gsccid -> + ioToUgnM (_ccall_ gsccexp t) `thenUgn` \ x_gsccexp -> + rdU_tree x_gsccexp `thenUgn` \ y_gsccexp -> + returnUgn (U_scc y_gsccid y_gsccexp) + else if tag == ``negate'' then + ioToUgnM (_ccall_ gnexp t) `thenUgn` \ x_gnexp -> + rdU_tree x_gnexp `thenUgn` \ y_gnexp -> + returnUgn (U_negate y_gnexp) + else + error ("rdU_tree: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/U_ttype.hi b/ghc/compiler/yaccParser/U_ttype.hi new file mode 100644 index 0000000..8dceb92 --- /dev/null +++ b/ghc/compiler/yaccParser/U_ttype.hi @@ -0,0 +1,9 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface U_ttype where +import PreludePS(_PackedString) +import ProtoName(ProtoName) +import U_list(U_list) +data U_ttype = U_tname ProtoName U_list | U_namedtvar ProtoName | U_tllist U_ttype | U_ttuple U_list | U_tfun U_ttype U_ttype | U_context U_list U_ttype | U_unidict ProtoName U_ttype | U_unityvartemplate ProtoName | U_uniforall U_list U_ttype | U_ty_maybe_nothing | U_ty_maybe_just U_ttype +rdU_ttype :: _Addr -> _PackedString -> _State _RealWorld -> (U_ttype, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} + diff --git a/ghc/compiler/yaccParser/U_ttype.hs b/ghc/compiler/yaccParser/U_ttype.hs new file mode 100644 index 0000000..23b455a --- /dev/null +++ b/ghc/compiler/yaccParser/U_ttype.hs @@ -0,0 +1,66 @@ + + +module U_ttype where +import UgenUtil +import Util + +import U_list +data U_ttype = U_tname U_unkId U_list | U_namedtvar U_unkId | U_tllist U_ttype | U_ttuple U_list | U_tfun U_ttype U_ttype | U_context U_list U_ttype | U_unidict U_unkId U_ttype | U_unityvartemplate U_unkId | U_uniforall U_list U_ttype | U_ty_maybe_nothing | U_ty_maybe_just U_ttype + +rdU_ttype :: _Addr -> UgnM U_ttype +rdU_ttype t + = ioToUgnM (_ccall_ tttype t) `thenUgn` \ tag@(I# _) -> + if tag == ``tname'' then + ioToUgnM (_ccall_ gtypeid t) `thenUgn` \ x_gtypeid -> + rdU_unkId x_gtypeid `thenUgn` \ y_gtypeid -> + ioToUgnM (_ccall_ gtypel t) `thenUgn` \ x_gtypel -> + rdU_list x_gtypel `thenUgn` \ y_gtypel -> + returnUgn (U_tname y_gtypeid y_gtypel) + else if tag == ``namedtvar'' then + ioToUgnM (_ccall_ gnamedtvar t) `thenUgn` \ x_gnamedtvar -> + rdU_unkId x_gnamedtvar `thenUgn` \ y_gnamedtvar -> + returnUgn (U_namedtvar y_gnamedtvar) + else if tag == ``tllist'' then + ioToUgnM (_ccall_ gtlist t) `thenUgn` \ x_gtlist -> + rdU_ttype x_gtlist `thenUgn` \ y_gtlist -> + returnUgn (U_tllist y_gtlist) + else if tag == ``ttuple'' then + ioToUgnM (_ccall_ gttuple t) `thenUgn` \ x_gttuple -> + rdU_list x_gttuple `thenUgn` \ y_gttuple -> + returnUgn (U_ttuple y_gttuple) + else if tag == ``tfun'' then + ioToUgnM (_ccall_ gtfun t) `thenUgn` \ x_gtfun -> + rdU_ttype x_gtfun `thenUgn` \ y_gtfun -> + ioToUgnM (_ccall_ gtarg t) `thenUgn` \ x_gtarg -> + rdU_ttype x_gtarg `thenUgn` \ y_gtarg -> + returnUgn (U_tfun y_gtfun y_gtarg) + else if tag == ``context'' then + ioToUgnM (_ccall_ gtcontextl t) `thenUgn` \ x_gtcontextl -> + rdU_list x_gtcontextl `thenUgn` \ y_gtcontextl -> + ioToUgnM (_ccall_ gtcontextt t) `thenUgn` \ x_gtcontextt -> + rdU_ttype x_gtcontextt `thenUgn` \ y_gtcontextt -> + returnUgn (U_context y_gtcontextl y_gtcontextt) + else if tag == ``unidict'' then + ioToUgnM (_ccall_ gunidict_clas t) `thenUgn` \ x_gunidict_clas -> + rdU_unkId x_gunidict_clas `thenUgn` \ y_gunidict_clas -> + ioToUgnM (_ccall_ gunidict_ty t) `thenUgn` \ x_gunidict_ty -> + rdU_ttype x_gunidict_ty `thenUgn` \ y_gunidict_ty -> + returnUgn (U_unidict y_gunidict_clas y_gunidict_ty) + else if tag == ``unityvartemplate'' then + ioToUgnM (_ccall_ gunityvartemplate t) `thenUgn` \ x_gunityvartemplate -> + rdU_unkId x_gunityvartemplate `thenUgn` \ y_gunityvartemplate -> + returnUgn (U_unityvartemplate y_gunityvartemplate) + else if tag == ``uniforall'' then + ioToUgnM (_ccall_ guniforall_tv t) `thenUgn` \ x_guniforall_tv -> + rdU_list x_guniforall_tv `thenUgn` \ y_guniforall_tv -> + ioToUgnM (_ccall_ guniforall_ty t) `thenUgn` \ x_guniforall_ty -> + rdU_ttype x_guniforall_ty `thenUgn` \ y_guniforall_ty -> + returnUgn (U_uniforall y_guniforall_tv y_guniforall_ty) + else if tag == ``ty_maybe_nothing'' then + returnUgn (U_ty_maybe_nothing ) + else if tag == ``ty_maybe_just'' then + ioToUgnM (_ccall_ gty_maybe t) `thenUgn` \ x_gty_maybe -> + rdU_ttype x_gty_maybe `thenUgn` \ y_gty_maybe -> + returnUgn (U_ty_maybe_just y_gty_maybe) + else + error ("rdU_ttype: bad tag selection:"++show tag++"\n") diff --git a/ghc/compiler/yaccParser/UgenAll.hi b/ghc/compiler/yaccParser/UgenAll.hi new file mode 100644 index 0000000..85e484e --- /dev/null +++ b/ghc/compiler/yaccParser/UgenAll.hi @@ -0,0 +1,95 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UgenAll where +import PreludePS(_PackedString) +import PreludePrimIO(returnPrimIO, thenPrimIO) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +import U_atype(U_atype(..), rdU_atype) +import U_binding(U_binding(..), rdU_binding) +import U_coresyn(U_coresyn(..), rdU_coresyn) +import U_entidt(U_entidt(..), rdU_entidt) +import U_finfot(U_finfot(..), rdU_finfot) +import U_hpragma(U_hpragma(..), rdU_hpragma) +import U_list(U_list(..), rdU_list) +import U_literal(U_literal(..), rdU_literal) +import U_pbinding(U_pbinding(..), rdU_pbinding) +import U_treeHACK(U_infixTree(..), U_tree(..), rdU_infixTree, rdU_tree) +import U_ttype(U_ttype(..), rdU_ttype) +import UgenUtil(ParseTree(..), U_VOID_STAR(..), U_hstring(..), U_long(..), U_numId(..), U_stringId(..), U_unkId(..), UgnM(..), getSrcFileUgn, initUgn, ioToUgnM, mkSrcLocUgn, rdU_VOID_STAR, rdU_hstring, rdU_long, rdU_numId, rdU_stringId, rdU_unkId, returnUgn, setSrcFileUgn, thenUgn) +infixr 1 `thenPrimIO` +data U_atype = U_atc ProtoName U_list Int +data U_binding = U_tbind U_list U_ttype U_list U_list Int U_hpragma | U_nbind U_ttype U_ttype Int U_hpragma | U_pbind U_list Int | U_fbind U_list Int | U_abind U_binding U_binding | U_lbind U_binding U_binding | U_ebind U_list U_binding Int | U_hbind U_list U_binding Int | U_ibind U_list ProtoName U_ttype U_binding Int U_hpragma | U_dbind U_list Int | U_cbind U_list U_ttype U_binding Int U_hpragma | U_sbind U_list U_ttype Int U_hpragma | U_mbind _PackedString U_list U_list Int | U_nullbind | U_import _PackedString U_list U_list U_binding _PackedString Int | U_hiding _PackedString U_list U_list U_binding _PackedString Int | U_vspec_uprag ProtoName U_list Int | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag ProtoName U_ttype Int | U_inline_uprag ProtoName U_list Int | U_deforest_uprag ProtoName Int | U_magicuf_uprag ProtoName _PackedString Int | U_abstract_uprag ProtoName Int | U_dspec_uprag ProtoName U_list Int +data U_coresyn + = U_cobinder ProtoName U_ttype | U_colit U_literal | U_colocal U_coresyn | U_cononrec U_coresyn U_coresyn | U_corec U_list | U_corec_pair U_coresyn U_coresyn | U_covar U_coresyn | U_coliteral U_literal | U_cocon U_coresyn U_list U_list | U_coprim U_coresyn U_list U_list | U_colam U_list U_coresyn | U_cotylam U_list U_coresyn | U_coapp U_coresyn U_list | U_cotyapp U_coresyn U_ttype | U_cocase U_coresyn U_coresyn | U_colet U_coresyn U_coresyn | U_coscc U_coresyn U_coresyn | U_coalg_alts U_list U_coresyn | U_coalg_alt U_coresyn U_list U_coresyn | U_coprim_alts U_list U_coresyn | U_coprim_alt U_literal U_coresyn | U_conodeflt | U_cobinddeflt U_coresyn U_coresyn | U_co_primop _PackedString | U_co_ccall _PackedString Int U_list U_ttype | U_co_casm U_literal Int U_list U_ttype | U_co_preludedictscc U_coresyn | U_co_alldictscc _PackedString _PackedString U_coresyn | U_co_usercc _PackedString _PackedString _PackedString U_coresyn U_coresyn | U_co_autocc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_dictcc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_scc_noncaf | U_co_scc_caf | U_co_scc_nondupd | U_co_scc_dupd | U_co_id _PackedString | U_co_orig_id _PackedString _PackedString | U_co_sdselid ProtoName ProtoName | U_co_classopid ProtoName ProtoName | U_co_defmid ProtoName ProtoName | U_co_dfunid ProtoName U_ttype | U_co_constmid ProtoName ProtoName U_ttype | U_co_specid U_coresyn U_list | U_co_wrkrid U_coresyn +data U_entidt = U_entid _PackedString | U_enttype _PackedString | U_enttypeall _PackedString | U_enttypecons _PackedString U_list | U_entclass _PackedString U_list | U_entmod _PackedString +data U_finfot = U_nofinfo | U_finfo _PackedString _PackedString +data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma _PackedString U_hpragma | U_iinst_const_pragma _PackedString U_hpragma U_list | U_iinst_spec_pragma _PackedString U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma Int | U_iupdate_pragma _PackedString | U_ideforest_pragma | U_istrictness_pragma _PackedString U_hpragma | U_imagic_unfolding_pragma _PackedString | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args Int Int _PackedString Int | U_iname_pragma_pr ProtoName U_hpragma | U_itype_pragma_pr U_list Int U_hpragma | U_iinst_pragma_3s U_list Int U_hpragma U_list | U_idata_pragma_4s U_list +data U_list = U_lcons _Addr U_list | U_lnil +data U_literal = U_integer _PackedString | U_intprim _PackedString | U_floatr _PackedString | U_doubleprim _PackedString | U_floatprim _PackedString | U_charr _PackedString | U_charprim _PackedString | U_string _PackedString | U_stringprim _PackedString | U_clitlit _PackedString _PackedString | U_norepi _PackedString | U_norepr _PackedString _PackedString | U_noreps _PackedString +data U_pbinding = U_pgrhs U_tree U_list U_binding _PackedString Int +type U_infixTree = (ProtoName, U_tree, U_tree) +data U_tree = U_hmodule _PackedString U_list U_list U_binding Int | U_ident ProtoName | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree Int | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as ProtoName U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop (ProtoName, U_tree, U_tree) | U_lsection U_tree ProtoName | U_rsection ProtoName U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall _PackedString _PackedString U_list | U_scc _PackedString U_tree | U_negate U_tree +data U_ttype = U_tname ProtoName U_list | U_namedtvar ProtoName | U_tllist U_ttype | U_ttuple U_list | U_tfun U_ttype U_ttype | U_context U_list U_ttype | U_unidict ProtoName U_ttype | U_unityvartemplate ProtoName | U_uniforall U_list U_ttype | U_ty_maybe_nothing | U_ty_maybe_just U_ttype +type ParseTree = _Addr +type U_VOID_STAR = _Addr +type U_hstring = _PackedString +type U_long = Int +type U_numId = Int +type U_stringId = _PackedString +type U_unkId = ProtoName +type UgnM a = _PackedString -> _State _RealWorld -> (a, _State _RealWorld) +returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-} +thenPrimIO :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: u0 -> _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u5, u6 ]; _NO_DEFLT_ } _N_ #-} +rdU_atype :: _Addr -> _PackedString -> _State _RealWorld -> (U_atype, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_binding :: _Addr -> _PackedString -> _State _RealWorld -> (U_binding, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_coresyn :: _Addr -> _PackedString -> _State _RealWorld -> (U_coresyn, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_entidt :: _Addr -> _PackedString -> _State _RealWorld -> (U_entidt, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_finfot :: _Addr -> _PackedString -> _State _RealWorld -> (U_finfot, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_hpragma :: _Addr -> _PackedString -> _State _RealWorld -> (U_hpragma, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_list :: _Addr -> _PackedString -> _State _RealWorld -> (U_list, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_literal :: _Addr -> _PackedString -> _State _RealWorld -> (U_literal, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_pbinding :: _Addr -> _PackedString -> _State _RealWorld -> (U_pbinding, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_infixTree :: _Addr -> _PackedString -> _State _RealWorld -> ((ProtoName, U_tree, U_tree), _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_tree :: _Addr -> _PackedString -> _State _RealWorld -> (U_tree, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_ttype :: _Addr -> _PackedString -> _State _RealWorld -> (U_ttype, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-} +getSrcFileUgn :: _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: _PackedString) (u1 :: _State _RealWorld) -> case u1 of { _ALG_ S# (u2 :: State# _RealWorld) -> _!_ _TUP_2 [_PackedString, (_State _RealWorld)] [u0, u1]; _NO_DEFLT_ } _N_ #-} +initUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_ #-} +ioToUgnM :: (_State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "SAL" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _State _RealWorld) -> _APP_ u1 [ u2 ] _N_} _F_ _IF_ARGS_ 1 3 XXX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _PackedString) (u3 :: _State _RealWorld) -> _APP_ u1 [ u3 ] _N_ #-} +mkSrcLocUgn :: Int -> _PackedString -> _State _RealWorld -> (SrcLoc, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_VOID_STAR :: _Addr -> _PackedString -> _State _RealWorld -> (_Addr, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: _Addr) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [_Addr, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-} +rdU_hstring :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 3 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_long :: Int -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: Int) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [Int, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-} +rdU_numId :: _Addr -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_stringId :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_unkId :: _Addr -> _PackedString -> _State _RealWorld -> (ProtoName, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +returnUgn :: b -> a -> _State _RealWorld -> (b, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LLS" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: u1) (u3 :: u0) (u4 :: _State _RealWorld) -> case u4 of { _ALG_ S# (u5 :: State# _RealWorld) -> _!_ _TUP_2 [u1, (_State _RealWorld)] [u2, u4]; _NO_DEFLT_ } _N_ #-} +setSrcFileUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 2102 _N_ _S_ "LSAL" {_A_ 3 _U_ 212 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_} _F_ _IF_ARGS_ 1 4 XXXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _PackedString) (u4 :: _State _RealWorld) -> _APP_ u2 [ u1, u4 ] _N_ #-} +thenUgn :: (b -> _State _RealWorld -> (a, _State _RealWorld)) -> (a -> b -> _State _RealWorld -> (c, _State _RealWorld)) -> b -> _State _RealWorld -> (c, _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "SSLL" _F_ _ALWAYS_ _/\_ u0 u1 u2 -> \ (u3 :: u1 -> _State _RealWorld -> (u0, _State _RealWorld)) (u4 :: u0 -> u1 -> _State _RealWorld -> (u2, _State _RealWorld)) (u5 :: u1) (u6 :: _State _RealWorld) -> case _APP_ u3 [ u5, u6 ] of { _ALG_ _TUP_2 (u7 :: u0) (u8 :: _State _RealWorld) -> _APP_ u4 [ u7, u5, u8 ]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/yaccParser/UgenAll.lhs b/ghc/compiler/yaccParser/UgenAll.lhs new file mode 100644 index 0000000..7ca0508 --- /dev/null +++ b/ghc/compiler/yaccParser/UgenAll.lhs @@ -0,0 +1,48 @@ +Stuff the Ugenny things show to the parser. + +\begin{code} +module UgenAll ( + -- re-exported Prelude stuff + returnUgn, thenUgn, + + -- stuff defined in utils module + UgenUtil.. , + + -- re-exported ugen-generated stuff + U_atype.. , + U_coresyn.. , + U_hpragma.. , + U_binding.. , + U_treeHACK.. , + U_entidt.. , + U_finfot.. , + U_list.. , + U_literal.. , + U_pbinding.. , + U_ttype.. + + ) where + +#if __GLASGOW_HASKELL__ < 26 +import PreludePrimIO +#else +import PreludeGlaST +#endif + +import U_atype +import U_binding +import U_coresyn +import U_entidt +import U_finfot +import U_hpragma +import U_list +import U_literal +import U_pbinding +import U_treeHACK +import U_ttype + +import SrcLoc ( SrcLoc ) +import Outputable +import UgenUtil +import Util +\end{code} diff --git a/ghc/compiler/yaccParser/UgenUtil.hi b/ghc/compiler/yaccParser/UgenUtil.hi new file mode 100644 index 0000000..d5735cf --- /dev/null +++ b/ghc/compiler/yaccParser/UgenUtil.hi @@ -0,0 +1,48 @@ +{-# GHC_PRAGMA INTERFACE VERSION 5 #-} +interface UgenUtil where +import Name(Name) +import PreludePS(_PackedString) +import PreludePrimIO(returnPrimIO, thenPrimIO) +import ProtoName(ProtoName) +import SrcLoc(SrcLoc) +infixr 1 `thenPrimIO` +type ParseTree = _Addr +data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-} +type U_VOID_STAR = _Addr +type U_hstring = _PackedString +type U_long = Int +type U_numId = Int +type U_stringId = _PackedString +type U_unkId = ProtoName +type UgnM a = _PackedString -> _State _RealWorld -> (a, _State _RealWorld) +getSrcFileUgn :: _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: _PackedString) (u1 :: _State _RealWorld) -> case u1 of { _ALG_ S# (u2 :: State# _RealWorld) -> _!_ _TUP_2 [_PackedString, (_State _RealWorld)] [u0, u1]; _NO_DEFLT_ } _N_ #-} +initUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_ #-} +ioToUgnM :: (_State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "SAL" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _State _RealWorld) -> _APP_ u1 [ u2 ] _N_} _F_ _IF_ARGS_ 1 3 XXX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _PackedString) (u3 :: _State _RealWorld) -> _APP_ u1 [ u3 ] _N_ #-} +mkSrcLocUgn :: Int -> _PackedString -> _State _RealWorld -> (SrcLoc, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_VOID_STAR :: _Addr -> _PackedString -> _State _RealWorld -> (_Addr, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: _Addr) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [_Addr, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-} +rdU_hstring :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 3 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_long :: Int -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: Int) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [Int, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-} +rdU_numId :: _Addr -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_stringId :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +rdU_unkId :: _Addr -> _PackedString -> _State _RealWorld -> (ProtoName, _State _RealWorld) + {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-} +returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-} +returnUgn :: b -> a -> _State _RealWorld -> (b, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LLS" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: u1) (u3 :: u0) (u4 :: _State _RealWorld) -> case u4 of { _ALG_ S# (u5 :: State# _RealWorld) -> _!_ _TUP_2 [u1, (_State _RealWorld)] [u2, u4]; _NO_DEFLT_ } _N_ #-} +setSrcFileUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 2102 _N_ _S_ "LSAL" {_A_ 3 _U_ 212 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_} _F_ _IF_ARGS_ 1 4 XXXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _PackedString) (u4 :: _State _RealWorld) -> _APP_ u2 [ u1, u4 ] _N_ #-} +thenPrimIO :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld) + {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: u0 -> _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u5, u6 ]; _NO_DEFLT_ } _N_ #-} +thenUgn :: (b -> _State _RealWorld -> (a, _State _RealWorld)) -> (a -> b -> _State _RealWorld -> (c, _State _RealWorld)) -> b -> _State _RealWorld -> (c, _State _RealWorld) + {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "SSLL" _F_ _ALWAYS_ _/\_ u0 u1 u2 -> \ (u3 :: u1 -> _State _RealWorld -> (u0, _State _RealWorld)) (u4 :: u0 -> u1 -> _State _RealWorld -> (u2, _State _RealWorld)) (u5 :: u1) (u6 :: _State _RealWorld) -> case _APP_ u3 [ u5, u6 ] of { _ALG_ _TUP_2 (u7 :: u0) (u8 :: _State _RealWorld) -> _APP_ u4 [ u7, u5, u8 ]; _NO_DEFLT_ } _N_ #-} + diff --git a/ghc/compiler/yaccParser/UgenUtil.lhs b/ghc/compiler/yaccParser/UgenUtil.lhs new file mode 100644 index 0000000..80587f1 --- /dev/null +++ b/ghc/compiler/yaccParser/UgenUtil.lhs @@ -0,0 +1,98 @@ +Glues lots of things together for ugen-generated +.hs files here + +\begin{code} +#include "HsVersions.h" + +module UgenUtil ( + -- re-exported Prelude stuff + returnPrimIO, thenPrimIO, + + -- stuff defined here + UgenUtil.., + + -- complete interface + ProtoName + ) where + +#if __GLASGOW_HASKELL__ < 26 +import PreludePrimIO +#else +import PreludeGlaST +#endif +import MainMonad + +import ProtoName +import Outputable +import SrcLoc ( mkSrcLoc2 ) +import Util +\end{code} + +\begin{code} +type UgnM a + = FAST_STRING -- source file name; carried down + -> PrimIO a + +{-# INLINE returnUgn #-} +{-# INLINE thenUgn #-} + +returnUgn x mod = returnPrimIO x + +thenUgn x y mod + = x mod `thenPrimIO` \ z -> + y z mod + +initUgn :: FAST_STRING -> UgnM a -> MainIO a +initUgn srcfile action + = action srcfile + +ioToUgnM :: PrimIO a -> UgnM a +ioToUgnM x mod = x +\end{code} + +\begin{code} +type ParseTree = _Addr + +type U_VOID_STAR = _Addr +rdU_VOID_STAR :: _Addr -> UgnM U_VOID_STAR +rdU_VOID_STAR x = returnUgn x + +type U_long = Int +rdU_long :: Int -> UgnM U_long +rdU_long x = returnUgn x -- (A# x) = returnUgn (I# (addr2Int# x)) + +type U_unkId = ProtoName +rdU_unkId :: _Addr -> UgnM U_unkId +rdU_unkId x + = rdU_stringId x `thenUgn` \ y -> + returnUgn (Unk y) + +type U_stringId = FAST_STRING +rdU_stringId :: _Addr -> UgnM U_stringId +rdU_stringId s + = ioToUgnM (_ccall_ hash_index s) `thenUgn` \ (I# i) -> + returnUgn (_packCString s) -- ToDo: use the i! + +type U_numId = Int -- ToDo: Int +rdU_numId :: _Addr -> UgnM U_numId +rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int) + +type U_hstring = FAST_STRING +rdU_hstring :: _Addr -> UgnM U_hstring +rdU_hstring x + = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len -> + ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes -> + returnUgn (_packCBytes len bytes) +\end{code} + +\begin{code} +setSrcFileUgn :: FAST_STRING{-filename-} -> UgnM a -> UgnM a +setSrcFileUgn file action _ = action file + +getSrcFileUgn :: UgnM FAST_STRING{-filename-} +getSrcFileUgn mod = returnUgn mod mod + +mkSrcLocUgn :: U_long -> UgnM SrcLoc +mkSrcLocUgn ln mod + = returnUgn (mkSrcLoc2 mod ln) mod +\end{code} diff --git a/ghc/compiler/yaccParser/atype.c b/ghc/compiler/yaccParser/atype.c new file mode 100644 index 0000000..b1cbfe3 --- /dev/null +++ b/ghc/compiler/yaccParser/atype.c @@ -0,0 +1,57 @@ + + +#include "hspincl.h" +#include "yaccParser/atype.h" + +Tatype tatype(t) + atype t; +{ + return(t -> tag); +} + + +/************** atc ******************/ + +atype mkatc(PPgatcid, PPgatctypel, PPgatcline) + unkId PPgatcid; + list PPgatctypel; + long PPgatcline; +{ + register struct Satc *pp = + (struct Satc *) malloc(sizeof(struct Satc)); + pp -> tag = atc; + pp -> Xgatcid = PPgatcid; + pp -> Xgatctypel = PPgatctypel; + pp -> Xgatcline = PPgatcline; + return((atype)pp); +} + +unkId *Rgatcid(t) + struct Satc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != atc) + fprintf(stderr,"gatcid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatcid); +} + +list *Rgatctypel(t) + struct Satc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != atc) + fprintf(stderr,"gatctypel: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatctypel); +} + +long *Rgatcline(t) + struct Satc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != atc) + fprintf(stderr,"gatcline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatcline); +} diff --git a/ghc/compiler/yaccParser/atype.h b/ghc/compiler/yaccParser/atype.h new file mode 100644 index 0000000..49ef6bb --- /dev/null +++ b/ghc/compiler/yaccParser/atype.h @@ -0,0 +1,83 @@ +#ifndef atype_defined +#define atype_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + atc +} Tatype; + +typedef struct { Tatype tag; } *atype; + +#ifdef __GNUC__ +extern __inline__ Tatype tatype(atype t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tatype tatype PROTO((atype)); +#endif /* ! __GNUC__ */ + +struct Satc { + Tatype tag; + unkId Xgatcid; + list Xgatctypel; + long Xgatcline; +}; + +extern atype mkatc PROTO((unkId, list, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgatcid(struct Satc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != atc) + fprintf(stderr,"gatcid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatcid); +} +#else /* ! __GNUC__ */ +extern unkId *Rgatcid PROTO((struct Satc *)); +#endif /* ! __GNUC__ */ + +#define gatcid(xyzxyz) (*Rgatcid((struct Satc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgatctypel(struct Satc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != atc) + fprintf(stderr,"gatctypel: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatctypel); +} +#else /* ! __GNUC__ */ +extern list *Rgatctypel PROTO((struct Satc *)); +#endif /* ! __GNUC__ */ + +#define gatctypel(xyzxyz) (*Rgatctypel((struct Satc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgatcline(struct Satc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != atc) + fprintf(stderr,"gatcline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatcline); +} +#else /* ! __GNUC__ */ +extern long *Rgatcline PROTO((struct Satc *)); +#endif /* ! __GNUC__ */ + +#define gatcline(xyzxyz) (*Rgatcline((struct Satc *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/atype.ugn b/ghc/compiler/yaccParser/atype.ugn new file mode 100644 index 0000000..c51e5b2 --- /dev/null +++ b/ghc/compiler/yaccParser/atype.ugn @@ -0,0 +1,15 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_atype where +import UgenUtil +import Util + +import U_list +%}} +type atype; + atc : < gatcid : unkId; + gatctypel : list; + gatcline : long; >; +end; diff --git a/ghc/compiler/yaccParser/binding.c b/ghc/compiler/yaccParser/binding.c new file mode 100644 index 0000000..20a82a3 --- /dev/null +++ b/ghc/compiler/yaccParser/binding.c @@ -0,0 +1,1187 @@ + + +#include "hspincl.h" +#include "yaccParser/binding.h" + +Tbinding tbinding(t) + binding t; +{ + return(t -> tag); +} + + +/************** tbind ******************/ + +binding mktbind(PPgtbindc, PPgtbindid, PPgtbindl, PPgtbindd, PPgtline, PPgtpragma) + list PPgtbindc; + ttype PPgtbindid; + list PPgtbindl; + list PPgtbindd; + long PPgtline; + hpragma PPgtpragma; +{ + register struct Stbind *pp = + (struct Stbind *) malloc(sizeof(struct Stbind)); + pp -> tag = tbind; + pp -> Xgtbindc = PPgtbindc; + pp -> Xgtbindid = PPgtbindid; + pp -> Xgtbindl = PPgtbindl; + pp -> Xgtbindd = PPgtbindd; + pp -> Xgtline = PPgtline; + pp -> Xgtpragma = PPgtpragma; + return((binding)pp); +} + +list *Rgtbindc(t) + struct Stbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindc); +} + +ttype *Rgtbindid(t) + struct Stbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindid); +} + +list *Rgtbindl(t) + struct Stbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindl); +} + +list *Rgtbindd(t) + struct Stbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindd); +} + +long *Rgtline(t) + struct Stbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtline); +} + +hpragma *Rgtpragma(t) + struct Stbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtpragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtpragma); +} + +/************** nbind ******************/ + +binding mknbind(PPgnbindid, PPgnbindas, PPgnline, PPgnpragma) + ttype PPgnbindid; + ttype PPgnbindas; + long PPgnline; + hpragma PPgnpragma; +{ + register struct Snbind *pp = + (struct Snbind *) malloc(sizeof(struct Snbind)); + pp -> tag = nbind; + pp -> Xgnbindid = PPgnbindid; + pp -> Xgnbindas = PPgnbindas; + pp -> Xgnline = PPgnline; + pp -> Xgnpragma = PPgnpragma; + return((binding)pp); +} + +ttype *Rgnbindid(t) + struct Snbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnbindid); +} + +ttype *Rgnbindas(t) + struct Snbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnbindas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnbindas); +} + +long *Rgnline(t) + struct Snbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnline); +} + +hpragma *Rgnpragma(t) + struct Snbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnpragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnpragma); +} + +/************** pbind ******************/ + +binding mkpbind(PPgpbindl, PPgpline) + list PPgpbindl; + long PPgpline; +{ + register struct Spbind *pp = + (struct Spbind *) malloc(sizeof(struct Spbind)); + pp -> tag = pbind; + pp -> Xgpbindl = PPgpbindl; + pp -> Xgpline = PPgpline; + return((binding)pp); +} + +list *Rgpbindl(t) + struct Spbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pbind) + fprintf(stderr,"gpbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgpbindl); +} + +long *Rgpline(t) + struct Spbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pbind) + fprintf(stderr,"gpline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgpline); +} + +/************** fbind ******************/ + +binding mkfbind(PPgfbindl, PPgfline) + list PPgfbindl; + long PPgfline; +{ + register struct Sfbind *pp = + (struct Sfbind *) malloc(sizeof(struct Sfbind)); + pp -> tag = fbind; + pp -> Xgfbindl = PPgfbindl; + pp -> Xgfline = PPgfline; + return((binding)pp); +} + +list *Rgfbindl(t) + struct Sfbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != fbind) + fprintf(stderr,"gfbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfbindl); +} + +long *Rgfline(t) + struct Sfbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != fbind) + fprintf(stderr,"gfline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfline); +} + +/************** abind ******************/ + +binding mkabind(PPgabindfst, PPgabindsnd) + binding PPgabindfst; + binding PPgabindsnd; +{ + register struct Sabind *pp = + (struct Sabind *) malloc(sizeof(struct Sabind)); + pp -> tag = abind; + pp -> Xgabindfst = PPgabindfst; + pp -> Xgabindsnd = PPgabindsnd; + return((binding)pp); +} + +binding *Rgabindfst(t) + struct Sabind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != abind) + fprintf(stderr,"gabindfst: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabindfst); +} + +binding *Rgabindsnd(t) + struct Sabind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != abind) + fprintf(stderr,"gabindsnd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabindsnd); +} + +/************** lbind ******************/ + +binding mklbind(PPglbindfst, PPglbindsnd) + binding PPglbindfst; + binding PPglbindsnd; +{ + register struct Slbind *pp = + (struct Slbind *) malloc(sizeof(struct Slbind)); + pp -> tag = lbind; + pp -> Xglbindfst = PPglbindfst; + pp -> Xglbindsnd = PPglbindsnd; + return((binding)pp); +} + +binding *Rglbindfst(t) + struct Slbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lbind) + fprintf(stderr,"glbindfst: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglbindfst); +} + +binding *Rglbindsnd(t) + struct Slbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lbind) + fprintf(stderr,"glbindsnd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglbindsnd); +} + +/************** ebind ******************/ + +binding mkebind(PPgebindl, PPgebind, PPgeline) + list PPgebindl; + binding PPgebind; + long PPgeline; +{ + register struct Sebind *pp = + (struct Sebind *) malloc(sizeof(struct Sebind)); + pp -> tag = ebind; + pp -> Xgebindl = PPgebindl; + pp -> Xgebind = PPgebind; + pp -> Xgeline = PPgeline; + return((binding)pp); +} + +list *Rgebindl(t) + struct Sebind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ebind) + fprintf(stderr,"gebindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgebindl); +} + +binding *Rgebind(t) + struct Sebind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ebind) + fprintf(stderr,"gebind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgebind); +} + +long *Rgeline(t) + struct Sebind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ebind) + fprintf(stderr,"geline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgeline); +} + +/************** hbind ******************/ + +binding mkhbind(PPghbindl, PPghbind, PPghline) + list PPghbindl; + binding PPghbind; + long PPghline; +{ + register struct Shbind *pp = + (struct Shbind *) malloc(sizeof(struct Shbind)); + pp -> tag = hbind; + pp -> Xghbindl = PPghbindl; + pp -> Xghbind = PPghbind; + pp -> Xghline = PPghline; + return((binding)pp); +} + +list *Rghbindl(t) + struct Shbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hbind) + fprintf(stderr,"ghbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghbindl); +} + +binding *Rghbind(t) + struct Shbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hbind) + fprintf(stderr,"ghbind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghbind); +} + +long *Rghline(t) + struct Shbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hbind) + fprintf(stderr,"ghline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghline); +} + +/************** ibind ******************/ + +binding mkibind(PPgibindc, PPgibindid, PPgibindi, PPgibindw, PPgiline, PPgipragma) + list PPgibindc; + unkId PPgibindid; + ttype PPgibindi; + binding PPgibindw; + long PPgiline; + hpragma PPgipragma; +{ + register struct Sibind *pp = + (struct Sibind *) malloc(sizeof(struct Sibind)); + pp -> tag = ibind; + pp -> Xgibindc = PPgibindc; + pp -> Xgibindid = PPgibindid; + pp -> Xgibindi = PPgibindi; + pp -> Xgibindw = PPgibindw; + pp -> Xgiline = PPgiline; + pp -> Xgipragma = PPgipragma; + return((binding)pp); +} + +list *Rgibindc(t) + struct Sibind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindc); +} + +unkId *Rgibindid(t) + struct Sibind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindid); +} + +ttype *Rgibindi(t) + struct Sibind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindi: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindi); +} + +binding *Rgibindw(t) + struct Sibind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindw: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindw); +} + +long *Rgiline(t) + struct Sibind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"giline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiline); +} + +hpragma *Rgipragma(t) + struct Sibind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gipragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgipragma); +} + +/************** dbind ******************/ + +binding mkdbind(PPgdbindts, PPgdline) + list PPgdbindts; + long PPgdline; +{ + register struct Sdbind *pp = + (struct Sdbind *) malloc(sizeof(struct Sdbind)); + pp -> tag = dbind; + pp -> Xgdbindts = PPgdbindts; + pp -> Xgdline = PPgdline; + return((binding)pp); +} + +list *Rgdbindts(t) + struct Sdbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != dbind) + fprintf(stderr,"gdbindts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdbindts); +} + +long *Rgdline(t) + struct Sdbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != dbind) + fprintf(stderr,"gdline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdline); +} + +/************** cbind ******************/ + +binding mkcbind(PPgcbindc, PPgcbindid, PPgcbindw, PPgcline, PPgcpragma) + list PPgcbindc; + ttype PPgcbindid; + binding PPgcbindw; + long PPgcline; + hpragma PPgcpragma; +{ + register struct Scbind *pp = + (struct Scbind *) malloc(sizeof(struct Scbind)); + pp -> tag = cbind; + pp -> Xgcbindc = PPgcbindc; + pp -> Xgcbindid = PPgcbindid; + pp -> Xgcbindw = PPgcbindw; + pp -> Xgcline = PPgcline; + pp -> Xgcpragma = PPgcpragma; + return((binding)pp); +} + +list *Rgcbindc(t) + struct Scbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcbindc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcbindc); +} + +ttype *Rgcbindid(t) + struct Scbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcbindid); +} + +binding *Rgcbindw(t) + struct Scbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcbindw: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcbindw); +} + +long *Rgcline(t) + struct Scbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcline); +} + +hpragma *Rgcpragma(t) + struct Scbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcpragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcpragma); +} + +/************** sbind ******************/ + +binding mksbind(PPgsbindids, PPgsbindid, PPgsline, PPgspragma) + list PPgsbindids; + ttype PPgsbindid; + long PPgsline; + hpragma PPgspragma; +{ + register struct Ssbind *pp = + (struct Ssbind *) malloc(sizeof(struct Ssbind)); + pp -> tag = sbind; + pp -> Xgsbindids = PPgsbindids; + pp -> Xgsbindid = PPgsbindid; + pp -> Xgsline = PPgsline; + pp -> Xgspragma = PPgspragma; + return((binding)pp); +} + +list *Rgsbindids(t) + struct Ssbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gsbindids: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsbindids); +} + +ttype *Rgsbindid(t) + struct Ssbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gsbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsbindid); +} + +long *Rgsline(t) + struct Ssbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gsline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsline); +} + +hpragma *Rgspragma(t) + struct Ssbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gspragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgspragma); +} + +/************** mbind ******************/ + +binding mkmbind(PPgmbindmodn, PPgmbindimp, PPgmbindren, PPgmline) + stringId PPgmbindmodn; + list PPgmbindimp; + list PPgmbindren; + long PPgmline; +{ + register struct Smbind *pp = + (struct Smbind *) malloc(sizeof(struct Smbind)); + pp -> tag = mbind; + pp -> Xgmbindmodn = PPgmbindmodn; + pp -> Xgmbindimp = PPgmbindimp; + pp -> Xgmbindren = PPgmbindren; + pp -> Xgmline = PPgmline; + return((binding)pp); +} + +stringId *Rgmbindmodn(t) + struct Smbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmbindmodn: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmbindmodn); +} + +list *Rgmbindimp(t) + struct Smbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmbindimp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmbindimp); +} + +list *Rgmbindren(t) + struct Smbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmbindren: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmbindren); +} + +long *Rgmline(t) + struct Smbind *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmline); +} + +/************** nullbind ******************/ + +binding mknullbind() +{ + register struct Snullbind *pp = + (struct Snullbind *) malloc(sizeof(struct Snullbind)); + pp -> tag = nullbind; + return((binding)pp); +} + +/************** import ******************/ + +binding mkimport(PPgiebindmod, PPgiebindexp, PPgiebindren, PPgiebinddef, PPgiebindfile, PPgiebindline) + stringId PPgiebindmod; + list PPgiebindexp; + list PPgiebindren; + binding PPgiebinddef; + stringId PPgiebindfile; + long PPgiebindline; +{ + register struct Simport *pp = + (struct Simport *) malloc(sizeof(struct Simport)); + pp -> tag = import; + pp -> Xgiebindmod = PPgiebindmod; + pp -> Xgiebindexp = PPgiebindexp; + pp -> Xgiebindren = PPgiebindren; + pp -> Xgiebinddef = PPgiebinddef; + pp -> Xgiebindfile = PPgiebindfile; + pp -> Xgiebindline = PPgiebindline; + return((binding)pp); +} + +stringId *Rgiebindmod(t) + struct Simport *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindmod: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindmod); +} + +list *Rgiebindexp(t) + struct Simport *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindexp); +} + +list *Rgiebindren(t) + struct Simport *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindren: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindren); +} + +binding *Rgiebinddef(t) + struct Simport *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebinddef: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebinddef); +} + +stringId *Rgiebindfile(t) + struct Simport *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindfile: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindfile); +} + +long *Rgiebindline(t) + struct Simport *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindline); +} + +/************** hiding ******************/ + +binding mkhiding(PPgihbindmod, PPgihbindexp, PPgihbindren, PPgihbinddef, PPgihbindfile, PPgihbindline) + stringId PPgihbindmod; + list PPgihbindexp; + list PPgihbindren; + binding PPgihbinddef; + stringId PPgihbindfile; + long PPgihbindline; +{ + register struct Shiding *pp = + (struct Shiding *) malloc(sizeof(struct Shiding)); + pp -> tag = hiding; + pp -> Xgihbindmod = PPgihbindmod; + pp -> Xgihbindexp = PPgihbindexp; + pp -> Xgihbindren = PPgihbindren; + pp -> Xgihbinddef = PPgihbinddef; + pp -> Xgihbindfile = PPgihbindfile; + pp -> Xgihbindline = PPgihbindline; + return((binding)pp); +} + +stringId *Rgihbindmod(t) + struct Shiding *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindmod: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindmod); +} + +list *Rgihbindexp(t) + struct Shiding *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindexp); +} + +list *Rgihbindren(t) + struct Shiding *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindren: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindren); +} + +binding *Rgihbinddef(t) + struct Shiding *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbinddef: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbinddef); +} + +stringId *Rgihbindfile(t) + struct Shiding *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindfile: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindfile); +} + +long *Rgihbindline(t) + struct Shiding *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindline); +} + +/************** vspec_uprag ******************/ + +binding mkvspec_uprag(PPgvspec_id, PPgvspec_tys, PPgvspec_line) + unkId PPgvspec_id; + list PPgvspec_tys; + long PPgvspec_line; +{ + register struct Svspec_uprag *pp = + (struct Svspec_uprag *) malloc(sizeof(struct Svspec_uprag)); + pp -> tag = vspec_uprag; + pp -> Xgvspec_id = PPgvspec_id; + pp -> Xgvspec_tys = PPgvspec_tys; + pp -> Xgvspec_line = PPgvspec_line; + return((binding)pp); +} + +unkId *Rgvspec_id(t) + struct Svspec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_uprag) + fprintf(stderr,"gvspec_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_id); +} + +list *Rgvspec_tys(t) + struct Svspec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_uprag) + fprintf(stderr,"gvspec_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_tys); +} + +long *Rgvspec_line(t) + struct Svspec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_uprag) + fprintf(stderr,"gvspec_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_line); +} + +/************** vspec_ty_and_id ******************/ + +binding mkvspec_ty_and_id(PPgvspec_ty, PPgvspec_tyid) + ttype PPgvspec_ty; + list PPgvspec_tyid; +{ + register struct Svspec_ty_and_id *pp = + (struct Svspec_ty_and_id *) malloc(sizeof(struct Svspec_ty_and_id)); + pp -> tag = vspec_ty_and_id; + pp -> Xgvspec_ty = PPgvspec_ty; + pp -> Xgvspec_tyid = PPgvspec_tyid; + return((binding)pp); +} + +ttype *Rgvspec_ty(t) + struct Svspec_ty_and_id *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_ty_and_id) + fprintf(stderr,"gvspec_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_ty); +} + +list *Rgvspec_tyid(t) + struct Svspec_ty_and_id *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_ty_and_id) + fprintf(stderr,"gvspec_tyid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_tyid); +} + +/************** ispec_uprag ******************/ + +binding mkispec_uprag(PPgispec_clas, PPgispec_ty, PPgispec_line) + unkId PPgispec_clas; + ttype PPgispec_ty; + long PPgispec_line; +{ + register struct Sispec_uprag *pp = + (struct Sispec_uprag *) malloc(sizeof(struct Sispec_uprag)); + pp -> tag = ispec_uprag; + pp -> Xgispec_clas = PPgispec_clas; + pp -> Xgispec_ty = PPgispec_ty; + pp -> Xgispec_line = PPgispec_line; + return((binding)pp); +} + +unkId *Rgispec_clas(t) + struct Sispec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ispec_uprag) + fprintf(stderr,"gispec_clas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgispec_clas); +} + +ttype *Rgispec_ty(t) + struct Sispec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ispec_uprag) + fprintf(stderr,"gispec_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgispec_ty); +} + +long *Rgispec_line(t) + struct Sispec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ispec_uprag) + fprintf(stderr,"gispec_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgispec_line); +} + +/************** inline_uprag ******************/ + +binding mkinline_uprag(PPginline_id, PPginline_howto, PPginline_line) + unkId PPginline_id; + list PPginline_howto; + long PPginline_line; +{ + register struct Sinline_uprag *pp = + (struct Sinline_uprag *) malloc(sizeof(struct Sinline_uprag)); + pp -> tag = inline_uprag; + pp -> Xginline_id = PPginline_id; + pp -> Xginline_howto = PPginline_howto; + pp -> Xginline_line = PPginline_line; + return((binding)pp); +} + +unkId *Rginline_id(t) + struct Sinline_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != inline_uprag) + fprintf(stderr,"ginline_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginline_id); +} + +list *Rginline_howto(t) + struct Sinline_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != inline_uprag) + fprintf(stderr,"ginline_howto: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginline_howto); +} + +long *Rginline_line(t) + struct Sinline_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != inline_uprag) + fprintf(stderr,"ginline_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginline_line); +} + +/************** deforest_uprag ******************/ + +binding mkdeforest_uprag(PPgdeforest_id, PPgdeforest_line) + unkId PPgdeforest_id; + long PPgdeforest_line; +{ + register struct Sdeforest_uprag *pp = + (struct Sdeforest_uprag *) malloc(sizeof(struct Sdeforest_uprag)); + pp -> tag = deforest_uprag; + pp -> Xgdeforest_id = PPgdeforest_id; + pp -> Xgdeforest_line = PPgdeforest_line; + return((binding)pp); +} + +unkId *Rgdeforest_id(t) + struct Sdeforest_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != deforest_uprag) + fprintf(stderr,"gdeforest_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdeforest_id); +} + +long *Rgdeforest_line(t) + struct Sdeforest_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != deforest_uprag) + fprintf(stderr,"gdeforest_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdeforest_line); +} + +/************** magicuf_uprag ******************/ + +binding mkmagicuf_uprag(PPgmagicuf_id, PPgmagicuf_str, PPgmagicuf_line) + unkId PPgmagicuf_id; + stringId PPgmagicuf_str; + long PPgmagicuf_line; +{ + register struct Smagicuf_uprag *pp = + (struct Smagicuf_uprag *) malloc(sizeof(struct Smagicuf_uprag)); + pp -> tag = magicuf_uprag; + pp -> Xgmagicuf_id = PPgmagicuf_id; + pp -> Xgmagicuf_str = PPgmagicuf_str; + pp -> Xgmagicuf_line = PPgmagicuf_line; + return((binding)pp); +} + +unkId *Rgmagicuf_id(t) + struct Smagicuf_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != magicuf_uprag) + fprintf(stderr,"gmagicuf_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmagicuf_id); +} + +stringId *Rgmagicuf_str(t) + struct Smagicuf_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != magicuf_uprag) + fprintf(stderr,"gmagicuf_str: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmagicuf_str); +} + +long *Rgmagicuf_line(t) + struct Smagicuf_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != magicuf_uprag) + fprintf(stderr,"gmagicuf_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmagicuf_line); +} + +/************** abstract_uprag ******************/ + +binding mkabstract_uprag(PPgabstract_id, PPgabstract_line) + unkId PPgabstract_id; + long PPgabstract_line; +{ + register struct Sabstract_uprag *pp = + (struct Sabstract_uprag *) malloc(sizeof(struct Sabstract_uprag)); + pp -> tag = abstract_uprag; + pp -> Xgabstract_id = PPgabstract_id; + pp -> Xgabstract_line = PPgabstract_line; + return((binding)pp); +} + +unkId *Rgabstract_id(t) + struct Sabstract_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != abstract_uprag) + fprintf(stderr,"gabstract_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabstract_id); +} + +long *Rgabstract_line(t) + struct Sabstract_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != abstract_uprag) + fprintf(stderr,"gabstract_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabstract_line); +} + +/************** dspec_uprag ******************/ + +binding mkdspec_uprag(PPgdspec_id, PPgdspec_tys, PPgdspec_line) + unkId PPgdspec_id; + list PPgdspec_tys; + long PPgdspec_line; +{ + register struct Sdspec_uprag *pp = + (struct Sdspec_uprag *) malloc(sizeof(struct Sdspec_uprag)); + pp -> tag = dspec_uprag; + pp -> Xgdspec_id = PPgdspec_id; + pp -> Xgdspec_tys = PPgdspec_tys; + pp -> Xgdspec_line = PPgdspec_line; + return((binding)pp); +} + +unkId *Rgdspec_id(t) + struct Sdspec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != dspec_uprag) + fprintf(stderr,"gdspec_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdspec_id); +} + +list *Rgdspec_tys(t) + struct Sdspec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != dspec_uprag) + fprintf(stderr,"gdspec_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdspec_tys); +} + +long *Rgdspec_line(t) + struct Sdspec_uprag *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != dspec_uprag) + fprintf(stderr,"gdspec_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdspec_line); +} diff --git a/ghc/compiler/yaccParser/binding.h b/ghc/compiler/yaccParser/binding.h new file mode 100644 index 0000000..add5394 --- /dev/null +++ b/ghc/compiler/yaccParser/binding.h @@ -0,0 +1,1444 @@ +#ifndef binding_defined +#define binding_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + tbind, + nbind, + pbind, + fbind, + abind, + lbind, + ebind, + hbind, + ibind, + dbind, + cbind, + sbind, + mbind, + nullbind, + import, + hiding, + vspec_uprag, + vspec_ty_and_id, + ispec_uprag, + inline_uprag, + deforest_uprag, + magicuf_uprag, + abstract_uprag, + dspec_uprag +} Tbinding; + +typedef struct { Tbinding tag; } *binding; + +#ifdef __GNUC__ +extern __inline__ Tbinding tbinding(binding t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tbinding tbinding PROTO((binding)); +#endif /* ! __GNUC__ */ + +struct Stbind { + Tbinding tag; + list Xgtbindc; + ttype Xgtbindid; + list Xgtbindl; + list Xgtbindd; + long Xgtline; + hpragma Xgtpragma; +}; + +struct Snbind { + Tbinding tag; + ttype Xgnbindid; + ttype Xgnbindas; + long Xgnline; + hpragma Xgnpragma; +}; + +struct Spbind { + Tbinding tag; + list Xgpbindl; + long Xgpline; +}; + +struct Sfbind { + Tbinding tag; + list Xgfbindl; + long Xgfline; +}; + +struct Sabind { + Tbinding tag; + binding Xgabindfst; + binding Xgabindsnd; +}; + +struct Slbind { + Tbinding tag; + binding Xglbindfst; + binding Xglbindsnd; +}; + +struct Sebind { + Tbinding tag; + list Xgebindl; + binding Xgebind; + long Xgeline; +}; + +struct Shbind { + Tbinding tag; + list Xghbindl; + binding Xghbind; + long Xghline; +}; + +struct Sibind { + Tbinding tag; + list Xgibindc; + unkId Xgibindid; + ttype Xgibindi; + binding Xgibindw; + long Xgiline; + hpragma Xgipragma; +}; + +struct Sdbind { + Tbinding tag; + list Xgdbindts; + long Xgdline; +}; + +struct Scbind { + Tbinding tag; + list Xgcbindc; + ttype Xgcbindid; + binding Xgcbindw; + long Xgcline; + hpragma Xgcpragma; +}; + +struct Ssbind { + Tbinding tag; + list Xgsbindids; + ttype Xgsbindid; + long Xgsline; + hpragma Xgspragma; +}; + +struct Smbind { + Tbinding tag; + stringId Xgmbindmodn; + list Xgmbindimp; + list Xgmbindren; + long Xgmline; +}; + +struct Snullbind { + Tbinding tag; +}; + +struct Simport { + Tbinding tag; + stringId Xgiebindmod; + list Xgiebindexp; + list Xgiebindren; + binding Xgiebinddef; + stringId Xgiebindfile; + long Xgiebindline; +}; + +struct Shiding { + Tbinding tag; + stringId Xgihbindmod; + list Xgihbindexp; + list Xgihbindren; + binding Xgihbinddef; + stringId Xgihbindfile; + long Xgihbindline; +}; + +struct Svspec_uprag { + Tbinding tag; + unkId Xgvspec_id; + list Xgvspec_tys; + long Xgvspec_line; +}; + +struct Svspec_ty_and_id { + Tbinding tag; + ttype Xgvspec_ty; + list Xgvspec_tyid; +}; + +struct Sispec_uprag { + Tbinding tag; + unkId Xgispec_clas; + ttype Xgispec_ty; + long Xgispec_line; +}; + +struct Sinline_uprag { + Tbinding tag; + unkId Xginline_id; + list Xginline_howto; + long Xginline_line; +}; + +struct Sdeforest_uprag { + Tbinding tag; + unkId Xgdeforest_id; + long Xgdeforest_line; +}; + +struct Smagicuf_uprag { + Tbinding tag; + unkId Xgmagicuf_id; + stringId Xgmagicuf_str; + long Xgmagicuf_line; +}; + +struct Sabstract_uprag { + Tbinding tag; + unkId Xgabstract_id; + long Xgabstract_line; +}; + +struct Sdspec_uprag { + Tbinding tag; + unkId Xgdspec_id; + list Xgdspec_tys; + long Xgdspec_line; +}; + +extern binding mktbind PROTO((list, ttype, list, list, long, hpragma)); +#ifdef __GNUC__ + +extern __inline__ list *Rgtbindc(struct Stbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindc); +} +#else /* ! __GNUC__ */ +extern list *Rgtbindc PROTO((struct Stbind *)); +#endif /* ! __GNUC__ */ + +#define gtbindc(xyzxyz) (*Rgtbindc((struct Stbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgtbindid(struct Stbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindid); +} +#else /* ! __GNUC__ */ +extern ttype *Rgtbindid PROTO((struct Stbind *)); +#endif /* ! __GNUC__ */ + +#define gtbindid(xyzxyz) (*Rgtbindid((struct Stbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgtbindl(struct Stbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindl); +} +#else /* ! __GNUC__ */ +extern list *Rgtbindl PROTO((struct Stbind *)); +#endif /* ! __GNUC__ */ + +#define gtbindl(xyzxyz) (*Rgtbindl((struct Stbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgtbindd(struct Stbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtbindd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtbindd); +} +#else /* ! __GNUC__ */ +extern list *Rgtbindd PROTO((struct Stbind *)); +#endif /* ! __GNUC__ */ + +#define gtbindd(xyzxyz) (*Rgtbindd((struct Stbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgtline(struct Stbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtline); +} +#else /* ! __GNUC__ */ +extern long *Rgtline PROTO((struct Stbind *)); +#endif /* ! __GNUC__ */ + +#define gtline(xyzxyz) (*Rgtline((struct Stbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgtpragma(struct Stbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tbind) + fprintf(stderr,"gtpragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtpragma); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgtpragma PROTO((struct Stbind *)); +#endif /* ! __GNUC__ */ + +#define gtpragma(xyzxyz) (*Rgtpragma((struct Stbind *) (xyzxyz))) + +extern binding mknbind PROTO((ttype, ttype, long, hpragma)); +#ifdef __GNUC__ + +extern __inline__ ttype *Rgnbindid(struct Snbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnbindid); +} +#else /* ! __GNUC__ */ +extern ttype *Rgnbindid PROTO((struct Snbind *)); +#endif /* ! __GNUC__ */ + +#define gnbindid(xyzxyz) (*Rgnbindid((struct Snbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgnbindas(struct Snbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnbindas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnbindas); +} +#else /* ! __GNUC__ */ +extern ttype *Rgnbindas PROTO((struct Snbind *)); +#endif /* ! __GNUC__ */ + +#define gnbindas(xyzxyz) (*Rgnbindas((struct Snbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgnline(struct Snbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnline); +} +#else /* ! __GNUC__ */ +extern long *Rgnline PROTO((struct Snbind *)); +#endif /* ! __GNUC__ */ + +#define gnline(xyzxyz) (*Rgnline((struct Snbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgnpragma(struct Snbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != nbind) + fprintf(stderr,"gnpragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnpragma); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgnpragma PROTO((struct Snbind *)); +#endif /* ! __GNUC__ */ + +#define gnpragma(xyzxyz) (*Rgnpragma((struct Snbind *) (xyzxyz))) + +extern binding mkpbind PROTO((list, long)); +#ifdef __GNUC__ + +extern __inline__ list *Rgpbindl(struct Spbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pbind) + fprintf(stderr,"gpbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgpbindl); +} +#else /* ! __GNUC__ */ +extern list *Rgpbindl PROTO((struct Spbind *)); +#endif /* ! __GNUC__ */ + +#define gpbindl(xyzxyz) (*Rgpbindl((struct Spbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgpline(struct Spbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pbind) + fprintf(stderr,"gpline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgpline); +} +#else /* ! __GNUC__ */ +extern long *Rgpline PROTO((struct Spbind *)); +#endif /* ! __GNUC__ */ + +#define gpline(xyzxyz) (*Rgpline((struct Spbind *) (xyzxyz))) + +extern binding mkfbind PROTO((list, long)); +#ifdef __GNUC__ + +extern __inline__ list *Rgfbindl(struct Sfbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != fbind) + fprintf(stderr,"gfbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfbindl); +} +#else /* ! __GNUC__ */ +extern list *Rgfbindl PROTO((struct Sfbind *)); +#endif /* ! __GNUC__ */ + +#define gfbindl(xyzxyz) (*Rgfbindl((struct Sfbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgfline(struct Sfbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != fbind) + fprintf(stderr,"gfline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfline); +} +#else /* ! __GNUC__ */ +extern long *Rgfline PROTO((struct Sfbind *)); +#endif /* ! __GNUC__ */ + +#define gfline(xyzxyz) (*Rgfline((struct Sfbind *) (xyzxyz))) + +extern binding mkabind PROTO((binding, binding)); +#ifdef __GNUC__ + +extern __inline__ binding *Rgabindfst(struct Sabind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != abind) + fprintf(stderr,"gabindfst: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabindfst); +} +#else /* ! __GNUC__ */ +extern binding *Rgabindfst PROTO((struct Sabind *)); +#endif /* ! __GNUC__ */ + +#define gabindfst(xyzxyz) (*Rgabindfst((struct Sabind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rgabindsnd(struct Sabind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != abind) + fprintf(stderr,"gabindsnd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabindsnd); +} +#else /* ! __GNUC__ */ +extern binding *Rgabindsnd PROTO((struct Sabind *)); +#endif /* ! __GNUC__ */ + +#define gabindsnd(xyzxyz) (*Rgabindsnd((struct Sabind *) (xyzxyz))) + +extern binding mklbind PROTO((binding, binding)); +#ifdef __GNUC__ + +extern __inline__ binding *Rglbindfst(struct Slbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lbind) + fprintf(stderr,"glbindfst: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglbindfst); +} +#else /* ! __GNUC__ */ +extern binding *Rglbindfst PROTO((struct Slbind *)); +#endif /* ! __GNUC__ */ + +#define glbindfst(xyzxyz) (*Rglbindfst((struct Slbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rglbindsnd(struct Slbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lbind) + fprintf(stderr,"glbindsnd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglbindsnd); +} +#else /* ! __GNUC__ */ +extern binding *Rglbindsnd PROTO((struct Slbind *)); +#endif /* ! __GNUC__ */ + +#define glbindsnd(xyzxyz) (*Rglbindsnd((struct Slbind *) (xyzxyz))) + +extern binding mkebind PROTO((list, binding, long)); +#ifdef __GNUC__ + +extern __inline__ list *Rgebindl(struct Sebind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ebind) + fprintf(stderr,"gebindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgebindl); +} +#else /* ! __GNUC__ */ +extern list *Rgebindl PROTO((struct Sebind *)); +#endif /* ! __GNUC__ */ + +#define gebindl(xyzxyz) (*Rgebindl((struct Sebind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rgebind(struct Sebind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ebind) + fprintf(stderr,"gebind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgebind); +} +#else /* ! __GNUC__ */ +extern binding *Rgebind PROTO((struct Sebind *)); +#endif /* ! __GNUC__ */ + +#define gebind(xyzxyz) (*Rgebind((struct Sebind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgeline(struct Sebind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ebind) + fprintf(stderr,"geline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgeline); +} +#else /* ! __GNUC__ */ +extern long *Rgeline PROTO((struct Sebind *)); +#endif /* ! __GNUC__ */ + +#define geline(xyzxyz) (*Rgeline((struct Sebind *) (xyzxyz))) + +extern binding mkhbind PROTO((list, binding, long)); +#ifdef __GNUC__ + +extern __inline__ list *Rghbindl(struct Shbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hbind) + fprintf(stderr,"ghbindl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghbindl); +} +#else /* ! __GNUC__ */ +extern list *Rghbindl PROTO((struct Shbind *)); +#endif /* ! __GNUC__ */ + +#define ghbindl(xyzxyz) (*Rghbindl((struct Shbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rghbind(struct Shbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hbind) + fprintf(stderr,"ghbind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghbind); +} +#else /* ! __GNUC__ */ +extern binding *Rghbind PROTO((struct Shbind *)); +#endif /* ! __GNUC__ */ + +#define ghbind(xyzxyz) (*Rghbind((struct Shbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rghline(struct Shbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hbind) + fprintf(stderr,"ghline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghline); +} +#else /* ! __GNUC__ */ +extern long *Rghline PROTO((struct Shbind *)); +#endif /* ! __GNUC__ */ + +#define ghline(xyzxyz) (*Rghline((struct Shbind *) (xyzxyz))) + +extern binding mkibind PROTO((list, unkId, ttype, binding, long, hpragma)); +#ifdef __GNUC__ + +extern __inline__ list *Rgibindc(struct Sibind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindc); +} +#else /* ! __GNUC__ */ +extern list *Rgibindc PROTO((struct Sibind *)); +#endif /* ! __GNUC__ */ + +#define gibindc(xyzxyz) (*Rgibindc((struct Sibind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ unkId *Rgibindid(struct Sibind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindid); +} +#else /* ! __GNUC__ */ +extern unkId *Rgibindid PROTO((struct Sibind *)); +#endif /* ! __GNUC__ */ + +#define gibindid(xyzxyz) (*Rgibindid((struct Sibind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgibindi(struct Sibind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindi: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindi); +} +#else /* ! __GNUC__ */ +extern ttype *Rgibindi PROTO((struct Sibind *)); +#endif /* ! __GNUC__ */ + +#define gibindi(xyzxyz) (*Rgibindi((struct Sibind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rgibindw(struct Sibind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gibindw: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgibindw); +} +#else /* ! __GNUC__ */ +extern binding *Rgibindw PROTO((struct Sibind *)); +#endif /* ! __GNUC__ */ + +#define gibindw(xyzxyz) (*Rgibindw((struct Sibind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgiline(struct Sibind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"giline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiline); +} +#else /* ! __GNUC__ */ +extern long *Rgiline PROTO((struct Sibind *)); +#endif /* ! __GNUC__ */ + +#define giline(xyzxyz) (*Rgiline((struct Sibind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgipragma(struct Sibind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ibind) + fprintf(stderr,"gipragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgipragma); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgipragma PROTO((struct Sibind *)); +#endif /* ! __GNUC__ */ + +#define gipragma(xyzxyz) (*Rgipragma((struct Sibind *) (xyzxyz))) + +extern binding mkdbind PROTO((list, long)); +#ifdef __GNUC__ + +extern __inline__ list *Rgdbindts(struct Sdbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != dbind) + fprintf(stderr,"gdbindts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdbindts); +} +#else /* ! __GNUC__ */ +extern list *Rgdbindts PROTO((struct Sdbind *)); +#endif /* ! __GNUC__ */ + +#define gdbindts(xyzxyz) (*Rgdbindts((struct Sdbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgdline(struct Sdbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != dbind) + fprintf(stderr,"gdline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdline); +} +#else /* ! __GNUC__ */ +extern long *Rgdline PROTO((struct Sdbind *)); +#endif /* ! __GNUC__ */ + +#define gdline(xyzxyz) (*Rgdline((struct Sdbind *) (xyzxyz))) + +extern binding mkcbind PROTO((list, ttype, binding, long, hpragma)); +#ifdef __GNUC__ + +extern __inline__ list *Rgcbindc(struct Scbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcbindc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcbindc); +} +#else /* ! __GNUC__ */ +extern list *Rgcbindc PROTO((struct Scbind *)); +#endif /* ! __GNUC__ */ + +#define gcbindc(xyzxyz) (*Rgcbindc((struct Scbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgcbindid(struct Scbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcbindid); +} +#else /* ! __GNUC__ */ +extern ttype *Rgcbindid PROTO((struct Scbind *)); +#endif /* ! __GNUC__ */ + +#define gcbindid(xyzxyz) (*Rgcbindid((struct Scbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rgcbindw(struct Scbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcbindw: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcbindw); +} +#else /* ! __GNUC__ */ +extern binding *Rgcbindw PROTO((struct Scbind *)); +#endif /* ! __GNUC__ */ + +#define gcbindw(xyzxyz) (*Rgcbindw((struct Scbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgcline(struct Scbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcline); +} +#else /* ! __GNUC__ */ +extern long *Rgcline PROTO((struct Scbind *)); +#endif /* ! __GNUC__ */ + +#define gcline(xyzxyz) (*Rgcline((struct Scbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgcpragma(struct Scbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cbind) + fprintf(stderr,"gcpragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcpragma); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgcpragma PROTO((struct Scbind *)); +#endif /* ! __GNUC__ */ + +#define gcpragma(xyzxyz) (*Rgcpragma((struct Scbind *) (xyzxyz))) + +extern binding mksbind PROTO((list, ttype, long, hpragma)); +#ifdef __GNUC__ + +extern __inline__ list *Rgsbindids(struct Ssbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gsbindids: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsbindids); +} +#else /* ! __GNUC__ */ +extern list *Rgsbindids PROTO((struct Ssbind *)); +#endif /* ! __GNUC__ */ + +#define gsbindids(xyzxyz) (*Rgsbindids((struct Ssbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgsbindid(struct Ssbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gsbindid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsbindid); +} +#else /* ! __GNUC__ */ +extern ttype *Rgsbindid PROTO((struct Ssbind *)); +#endif /* ! __GNUC__ */ + +#define gsbindid(xyzxyz) (*Rgsbindid((struct Ssbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgsline(struct Ssbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gsline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsline); +} +#else /* ! __GNUC__ */ +extern long *Rgsline PROTO((struct Ssbind *)); +#endif /* ! __GNUC__ */ + +#define gsline(xyzxyz) (*Rgsline((struct Ssbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgspragma(struct Ssbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != sbind) + fprintf(stderr,"gspragma: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgspragma); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgspragma PROTO((struct Ssbind *)); +#endif /* ! __GNUC__ */ + +#define gspragma(xyzxyz) (*Rgspragma((struct Ssbind *) (xyzxyz))) + +extern binding mkmbind PROTO((stringId, list, list, long)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgmbindmodn(struct Smbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmbindmodn: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmbindmodn); +} +#else /* ! __GNUC__ */ +extern stringId *Rgmbindmodn PROTO((struct Smbind *)); +#endif /* ! __GNUC__ */ + +#define gmbindmodn(xyzxyz) (*Rgmbindmodn((struct Smbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgmbindimp(struct Smbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmbindimp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmbindimp); +} +#else /* ! __GNUC__ */ +extern list *Rgmbindimp PROTO((struct Smbind *)); +#endif /* ! __GNUC__ */ + +#define gmbindimp(xyzxyz) (*Rgmbindimp((struct Smbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgmbindren(struct Smbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmbindren: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmbindren); +} +#else /* ! __GNUC__ */ +extern list *Rgmbindren PROTO((struct Smbind *)); +#endif /* ! __GNUC__ */ + +#define gmbindren(xyzxyz) (*Rgmbindren((struct Smbind *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgmline(struct Smbind *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != mbind) + fprintf(stderr,"gmline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmline); +} +#else /* ! __GNUC__ */ +extern long *Rgmline PROTO((struct Smbind *)); +#endif /* ! __GNUC__ */ + +#define gmline(xyzxyz) (*Rgmline((struct Smbind *) (xyzxyz))) + +extern binding mknullbind PROTO(()); + +extern binding mkimport PROTO((stringId, list, list, binding, stringId, long)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgiebindmod(struct Simport *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindmod: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindmod); +} +#else /* ! __GNUC__ */ +extern stringId *Rgiebindmod PROTO((struct Simport *)); +#endif /* ! __GNUC__ */ + +#define giebindmod(xyzxyz) (*Rgiebindmod((struct Simport *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgiebindexp(struct Simport *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindexp); +} +#else /* ! __GNUC__ */ +extern list *Rgiebindexp PROTO((struct Simport *)); +#endif /* ! __GNUC__ */ + +#define giebindexp(xyzxyz) (*Rgiebindexp((struct Simport *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgiebindren(struct Simport *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindren: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindren); +} +#else /* ! __GNUC__ */ +extern list *Rgiebindren PROTO((struct Simport *)); +#endif /* ! __GNUC__ */ + +#define giebindren(xyzxyz) (*Rgiebindren((struct Simport *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rgiebinddef(struct Simport *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebinddef: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebinddef); +} +#else /* ! __GNUC__ */ +extern binding *Rgiebinddef PROTO((struct Simport *)); +#endif /* ! __GNUC__ */ + +#define giebinddef(xyzxyz) (*Rgiebinddef((struct Simport *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgiebindfile(struct Simport *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindfile: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindfile); +} +#else /* ! __GNUC__ */ +extern stringId *Rgiebindfile PROTO((struct Simport *)); +#endif /* ! __GNUC__ */ + +#define giebindfile(xyzxyz) (*Rgiebindfile((struct Simport *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgiebindline(struct Simport *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != import) + fprintf(stderr,"giebindline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgiebindline); +} +#else /* ! __GNUC__ */ +extern long *Rgiebindline PROTO((struct Simport *)); +#endif /* ! __GNUC__ */ + +#define giebindline(xyzxyz) (*Rgiebindline((struct Simport *) (xyzxyz))) + +extern binding mkhiding PROTO((stringId, list, list, binding, stringId, long)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgihbindmod(struct Shiding *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindmod: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindmod); +} +#else /* ! __GNUC__ */ +extern stringId *Rgihbindmod PROTO((struct Shiding *)); +#endif /* ! __GNUC__ */ + +#define gihbindmod(xyzxyz) (*Rgihbindmod((struct Shiding *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgihbindexp(struct Shiding *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindexp); +} +#else /* ! __GNUC__ */ +extern list *Rgihbindexp PROTO((struct Shiding *)); +#endif /* ! __GNUC__ */ + +#define gihbindexp(xyzxyz) (*Rgihbindexp((struct Shiding *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgihbindren(struct Shiding *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindren: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindren); +} +#else /* ! __GNUC__ */ +extern list *Rgihbindren PROTO((struct Shiding *)); +#endif /* ! __GNUC__ */ + +#define gihbindren(xyzxyz) (*Rgihbindren((struct Shiding *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rgihbinddef(struct Shiding *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbinddef: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbinddef); +} +#else /* ! __GNUC__ */ +extern binding *Rgihbinddef PROTO((struct Shiding *)); +#endif /* ! __GNUC__ */ + +#define gihbinddef(xyzxyz) (*Rgihbinddef((struct Shiding *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgihbindfile(struct Shiding *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindfile: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindfile); +} +#else /* ! __GNUC__ */ +extern stringId *Rgihbindfile PROTO((struct Shiding *)); +#endif /* ! __GNUC__ */ + +#define gihbindfile(xyzxyz) (*Rgihbindfile((struct Shiding *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgihbindline(struct Shiding *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hiding) + fprintf(stderr,"gihbindline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgihbindline); +} +#else /* ! __GNUC__ */ +extern long *Rgihbindline PROTO((struct Shiding *)); +#endif /* ! __GNUC__ */ + +#define gihbindline(xyzxyz) (*Rgihbindline((struct Shiding *) (xyzxyz))) + +extern binding mkvspec_uprag PROTO((unkId, list, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgvspec_id(struct Svspec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_uprag) + fprintf(stderr,"gvspec_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_id); +} +#else /* ! __GNUC__ */ +extern unkId *Rgvspec_id PROTO((struct Svspec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gvspec_id(xyzxyz) (*Rgvspec_id((struct Svspec_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgvspec_tys(struct Svspec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_uprag) + fprintf(stderr,"gvspec_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgvspec_tys PROTO((struct Svspec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gvspec_tys(xyzxyz) (*Rgvspec_tys((struct Svspec_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgvspec_line(struct Svspec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_uprag) + fprintf(stderr,"gvspec_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_line); +} +#else /* ! __GNUC__ */ +extern long *Rgvspec_line PROTO((struct Svspec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gvspec_line(xyzxyz) (*Rgvspec_line((struct Svspec_uprag *) (xyzxyz))) + +extern binding mkvspec_ty_and_id PROTO((ttype, list)); +#ifdef __GNUC__ + +extern __inline__ ttype *Rgvspec_ty(struct Svspec_ty_and_id *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_ty_and_id) + fprintf(stderr,"gvspec_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgvspec_ty PROTO((struct Svspec_ty_and_id *)); +#endif /* ! __GNUC__ */ + +#define gvspec_ty(xyzxyz) (*Rgvspec_ty((struct Svspec_ty_and_id *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgvspec_tyid(struct Svspec_ty_and_id *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != vspec_ty_and_id) + fprintf(stderr,"gvspec_tyid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgvspec_tyid); +} +#else /* ! __GNUC__ */ +extern list *Rgvspec_tyid PROTO((struct Svspec_ty_and_id *)); +#endif /* ! __GNUC__ */ + +#define gvspec_tyid(xyzxyz) (*Rgvspec_tyid((struct Svspec_ty_and_id *) (xyzxyz))) + +extern binding mkispec_uprag PROTO((unkId, ttype, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgispec_clas(struct Sispec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ispec_uprag) + fprintf(stderr,"gispec_clas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgispec_clas); +} +#else /* ! __GNUC__ */ +extern unkId *Rgispec_clas PROTO((struct Sispec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gispec_clas(xyzxyz) (*Rgispec_clas((struct Sispec_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgispec_ty(struct Sispec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ispec_uprag) + fprintf(stderr,"gispec_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgispec_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgispec_ty PROTO((struct Sispec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gispec_ty(xyzxyz) (*Rgispec_ty((struct Sispec_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgispec_line(struct Sispec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ispec_uprag) + fprintf(stderr,"gispec_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgispec_line); +} +#else /* ! __GNUC__ */ +extern long *Rgispec_line PROTO((struct Sispec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gispec_line(xyzxyz) (*Rgispec_line((struct Sispec_uprag *) (xyzxyz))) + +extern binding mkinline_uprag PROTO((unkId, list, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rginline_id(struct Sinline_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != inline_uprag) + fprintf(stderr,"ginline_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginline_id); +} +#else /* ! __GNUC__ */ +extern unkId *Rginline_id PROTO((struct Sinline_uprag *)); +#endif /* ! __GNUC__ */ + +#define ginline_id(xyzxyz) (*Rginline_id((struct Sinline_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rginline_howto(struct Sinline_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != inline_uprag) + fprintf(stderr,"ginline_howto: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginline_howto); +} +#else /* ! __GNUC__ */ +extern list *Rginline_howto PROTO((struct Sinline_uprag *)); +#endif /* ! __GNUC__ */ + +#define ginline_howto(xyzxyz) (*Rginline_howto((struct Sinline_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rginline_line(struct Sinline_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != inline_uprag) + fprintf(stderr,"ginline_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginline_line); +} +#else /* ! __GNUC__ */ +extern long *Rginline_line PROTO((struct Sinline_uprag *)); +#endif /* ! __GNUC__ */ + +#define ginline_line(xyzxyz) (*Rginline_line((struct Sinline_uprag *) (xyzxyz))) + +extern binding mkdeforest_uprag PROTO((unkId, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgdeforest_id(struct Sdeforest_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != deforest_uprag) + fprintf(stderr,"gdeforest_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdeforest_id); +} +#else /* ! __GNUC__ */ +extern unkId *Rgdeforest_id PROTO((struct Sdeforest_uprag *)); +#endif /* ! __GNUC__ */ + +#define gdeforest_id(xyzxyz) (*Rgdeforest_id((struct Sdeforest_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgdeforest_line(struct Sdeforest_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != deforest_uprag) + fprintf(stderr,"gdeforest_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdeforest_line); +} +#else /* ! __GNUC__ */ +extern long *Rgdeforest_line PROTO((struct Sdeforest_uprag *)); +#endif /* ! __GNUC__ */ + +#define gdeforest_line(xyzxyz) (*Rgdeforest_line((struct Sdeforest_uprag *) (xyzxyz))) + +extern binding mkmagicuf_uprag PROTO((unkId, stringId, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgmagicuf_id(struct Smagicuf_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != magicuf_uprag) + fprintf(stderr,"gmagicuf_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmagicuf_id); +} +#else /* ! __GNUC__ */ +extern unkId *Rgmagicuf_id PROTO((struct Smagicuf_uprag *)); +#endif /* ! __GNUC__ */ + +#define gmagicuf_id(xyzxyz) (*Rgmagicuf_id((struct Smagicuf_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgmagicuf_str(struct Smagicuf_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != magicuf_uprag) + fprintf(stderr,"gmagicuf_str: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmagicuf_str); +} +#else /* ! __GNUC__ */ +extern stringId *Rgmagicuf_str PROTO((struct Smagicuf_uprag *)); +#endif /* ! __GNUC__ */ + +#define gmagicuf_str(xyzxyz) (*Rgmagicuf_str((struct Smagicuf_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgmagicuf_line(struct Smagicuf_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != magicuf_uprag) + fprintf(stderr,"gmagicuf_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmagicuf_line); +} +#else /* ! __GNUC__ */ +extern long *Rgmagicuf_line PROTO((struct Smagicuf_uprag *)); +#endif /* ! __GNUC__ */ + +#define gmagicuf_line(xyzxyz) (*Rgmagicuf_line((struct Smagicuf_uprag *) (xyzxyz))) + +extern binding mkabstract_uprag PROTO((unkId, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgabstract_id(struct Sabstract_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != abstract_uprag) + fprintf(stderr,"gabstract_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabstract_id); +} +#else /* ! __GNUC__ */ +extern unkId *Rgabstract_id PROTO((struct Sabstract_uprag *)); +#endif /* ! __GNUC__ */ + +#define gabstract_id(xyzxyz) (*Rgabstract_id((struct Sabstract_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgabstract_line(struct Sabstract_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != abstract_uprag) + fprintf(stderr,"gabstract_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgabstract_line); +} +#else /* ! __GNUC__ */ +extern long *Rgabstract_line PROTO((struct Sabstract_uprag *)); +#endif /* ! __GNUC__ */ + +#define gabstract_line(xyzxyz) (*Rgabstract_line((struct Sabstract_uprag *) (xyzxyz))) + +extern binding mkdspec_uprag PROTO((unkId, list, long)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgdspec_id(struct Sdspec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != dspec_uprag) + fprintf(stderr,"gdspec_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdspec_id); +} +#else /* ! __GNUC__ */ +extern unkId *Rgdspec_id PROTO((struct Sdspec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gdspec_id(xyzxyz) (*Rgdspec_id((struct Sdspec_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgdspec_tys(struct Sdspec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != dspec_uprag) + fprintf(stderr,"gdspec_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdspec_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgdspec_tys PROTO((struct Sdspec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gdspec_tys(xyzxyz) (*Rgdspec_tys((struct Sdspec_uprag *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgdspec_line(struct Sdspec_uprag *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != dspec_uprag) + fprintf(stderr,"gdspec_line: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdspec_line); +} +#else /* ! __GNUC__ */ +extern long *Rgdspec_line PROTO((struct Sdspec_uprag *)); +#endif /* ! __GNUC__ */ + +#define gdspec_line(xyzxyz) (*Rgdspec_line((struct Sdspec_uprag *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/binding.ugn b/ghc/compiler/yaccParser/binding.ugn new file mode 100644 index 0000000..6c7b19e --- /dev/null +++ b/ghc/compiler/yaccParser/binding.ugn @@ -0,0 +1,106 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_binding where +import UgenUtil +import Util + +import U_coresyn ( U_coresyn ) -- for interfaces only +import U_hpragma +import U_list +import U_literal ( U_literal ) -- for interfaces only +import U_ttype +%}} +type binding; + tbind : < gtbindc : list; + gtbindid : ttype; + gtbindl : list; + gtbindd : list; + gtline : long; + gtpragma : hpragma; >; + nbind : < gnbindid : ttype; + gnbindas : ttype; + gnline : long; + gnpragma : hpragma; >; + pbind : < gpbindl : list; + gpline : long; >; + fbind : < gfbindl : list; + gfline : long; >; + abind : < gabindfst : binding; + gabindsnd : binding; >; + lbind : < glbindfst : binding; + glbindsnd : binding; >; + ebind : < gebindl : list; + gebind : binding; + geline : long; >; + hbind : < ghbindl : list; + ghbind : binding; + ghline : long; >; + ibind : < gibindc : list; + gibindid : unkId; + gibindi : ttype; + gibindw : binding; + giline : long; + gipragma : hpragma; >; + dbind : < gdbindts : list; + gdline : long; >; + cbind : < gcbindc : list; + gcbindid : ttype; + gcbindw : binding; + gcline : long; + gcpragma : hpragma; >; + sbind : < gsbindids : list; + gsbindid : ttype; + gsline : long; + gspragma : hpragma; >; + mbind : < gmbindmodn : stringId; + gmbindimp : list; + gmbindren : list; + gmline : long; >; + nullbind : < >; + import : < giebindmod : stringId; + giebindexp : list; + giebindren : list; + giebinddef : binding; + giebindfile : stringId; + giebindline : long; >; + hiding : < gihbindmod : stringId; + gihbindexp : list; + gihbindren : list; + gihbinddef : binding; + gihbindfile : stringId; + gihbindline : long; >; + + /* user-specified pragmas:XXXX */ + + vspec_uprag : < gvspec_id : unkId; + gvspec_tys : list; + gvspec_line : long; >; + + vspec_ty_and_id : < gvspec_ty : ttype; + gvspec_tyid : list; /* nil or singleton */ >; + + ispec_uprag : < gispec_clas : unkId; + gispec_ty : ttype; + gispec_line : long; >; + + inline_uprag: < ginline_id : unkId; + ginline_howto: list; + ginline_line : long; >; + + deforest_uprag: < gdeforest_id : unkId; + gdeforest_line : long; >; + + magicuf_uprag:< gmagicuf_id : unkId; + gmagicuf_str : stringId; + gmagicuf_line : long; >; + + abstract_uprag:; + + dspec_uprag : < gdspec_id : unkId; + gdspec_tys : list; + gdspec_line : long; >; + +end; diff --git a/ghc/compiler/yaccParser/constants.h b/ghc/compiler/yaccParser/constants.h new file mode 100644 index 0000000..9e168c7 --- /dev/null +++ b/ghc/compiler/yaccParser/constants.h @@ -0,0 +1,52 @@ +/* + Include File for the Lexical Analyser and Parser. + + 19/11/91 kh Created. +*/ + + +#ifndef __CONSTANTS_H +#define __CONSTANTS_H + +/* + Important Literal Constants. +*/ + +#define MODNAME_SIZE 512 /* Size of Module Name buffers */ +#define FILENAME_SIZE 4096 /* Size of File buffers */ +#define ERR_BUF_SIZE 512 /* Size of error buffers */ + +#ifdef YYLMAX /* Get rid of YYLMAX */ +#undef YYLMAX /* Ugly -- but necessary */ +#endif + +#define YYLMAX 8192 /* Size of yytext -- limits strings, identifiers etc. */ + + +#define HASH_TABLE_SIZE 993 /* Default number of entries in the hash table. */ + + +#define MAX_CONTEXTS 100 /* Maximum nesting of wheres, cases etc */ +#define MAX_INFIX 500 /* Maximum number of infix operators */ +#define MAX_ISTR (MAX_INFIX*10) /* Total size of all infix operatrors */ +#define INFIX_SCOPES 3 /* The number of infix scopes + -- Predefs, Module, Imports */ + + +#define MAX_ESC_CHAR 255 /* Largest Recognised Character: \255 */ +#define MAX_ESC_DIGITS 10 /* Maximum number of digits in an escape \dd */ + + +#ifdef TRUE +#undef TRUE +#endif + +#ifdef FALSE +#undef FALSE +#endif + +#define TRUE 1 +#define FALSE 0 +typedef int BOOLEAN; + +#endif /* __CONSTANTS_H */ diff --git a/ghc/compiler/yaccParser/coresyn.c b/ghc/compiler/yaccParser/coresyn.c new file mode 100644 index 0000000..34318db --- /dev/null +++ b/ghc/compiler/yaccParser/coresyn.c @@ -0,0 +1,1495 @@ + + +#include "hspincl.h" +#include "yaccParser/coresyn.h" + +Tcoresyn tcoresyn(t) + coresyn t; +{ + return(t -> tag); +} + + +/************** cobinder ******************/ + +coresyn mkcobinder(PPgcobinder_v, PPgcobinder_ty) + unkId PPgcobinder_v; + ttype PPgcobinder_ty; +{ + register struct Scobinder *pp = + (struct Scobinder *) malloc(sizeof(struct Scobinder)); + pp -> tag = cobinder; + pp -> Xgcobinder_v = PPgcobinder_v; + pp -> Xgcobinder_ty = PPgcobinder_ty; + return((coresyn)pp); +} + +unkId *Rgcobinder_v(t) + struct Scobinder *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinder) + fprintf(stderr,"gcobinder_v: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinder_v); +} + +ttype *Rgcobinder_ty(t) + struct Scobinder *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinder) + fprintf(stderr,"gcobinder_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinder_ty); +} + +/************** colit ******************/ + +coresyn mkcolit(PPgcolit) + literal PPgcolit; +{ + register struct Scolit *pp = + (struct Scolit *) malloc(sizeof(struct Scolit)); + pp -> tag = colit; + pp -> Xgcolit = PPgcolit; + return((coresyn)pp); +} + +literal *Rgcolit(t) + struct Scolit *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != colit) + fprintf(stderr,"gcolit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolit); +} + +/************** colocal ******************/ + +coresyn mkcolocal(PPgcolocal_v) + coresyn PPgcolocal_v; +{ + register struct Scolocal *pp = + (struct Scolocal *) malloc(sizeof(struct Scolocal)); + pp -> tag = colocal; + pp -> Xgcolocal_v = PPgcolocal_v; + return((coresyn)pp); +} + +coresyn *Rgcolocal_v(t) + struct Scolocal *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != colocal) + fprintf(stderr,"gcolocal_v: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolocal_v); +} + +/************** cononrec ******************/ + +coresyn mkcononrec(PPgcononrec_b, PPgcononrec_rhs) + coresyn PPgcononrec_b; + coresyn PPgcononrec_rhs; +{ + register struct Scononrec *pp = + (struct Scononrec *) malloc(sizeof(struct Scononrec)); + pp -> tag = cononrec; + pp -> Xgcononrec_b = PPgcononrec_b; + pp -> Xgcononrec_rhs = PPgcononrec_rhs; + return((coresyn)pp); +} + +coresyn *Rgcononrec_b(t) + struct Scononrec *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cononrec) + fprintf(stderr,"gcononrec_b: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcononrec_b); +} + +coresyn *Rgcononrec_rhs(t) + struct Scononrec *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cononrec) + fprintf(stderr,"gcononrec_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcononrec_rhs); +} + +/************** corec ******************/ + +coresyn mkcorec(PPgcorec) + list PPgcorec; +{ + register struct Scorec *pp = + (struct Scorec *) malloc(sizeof(struct Scorec)); + pp -> tag = corec; + pp -> Xgcorec = PPgcorec; + return((coresyn)pp); +} + +list *Rgcorec(t) + struct Scorec *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != corec) + fprintf(stderr,"gcorec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcorec); +} + +/************** corec_pair ******************/ + +coresyn mkcorec_pair(PPgcorec_b, PPgcorec_rhs) + coresyn PPgcorec_b; + coresyn PPgcorec_rhs; +{ + register struct Scorec_pair *pp = + (struct Scorec_pair *) malloc(sizeof(struct Scorec_pair)); + pp -> tag = corec_pair; + pp -> Xgcorec_b = PPgcorec_b; + pp -> Xgcorec_rhs = PPgcorec_rhs; + return((coresyn)pp); +} + +coresyn *Rgcorec_b(t) + struct Scorec_pair *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != corec_pair) + fprintf(stderr,"gcorec_b: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcorec_b); +} + +coresyn *Rgcorec_rhs(t) + struct Scorec_pair *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != corec_pair) + fprintf(stderr,"gcorec_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcorec_rhs); +} + +/************** covar ******************/ + +coresyn mkcovar(PPgcovar) + coresyn PPgcovar; +{ + register struct Scovar *pp = + (struct Scovar *) malloc(sizeof(struct Scovar)); + pp -> tag = covar; + pp -> Xgcovar = PPgcovar; + return((coresyn)pp); +} + +coresyn *Rgcovar(t) + struct Scovar *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != covar) + fprintf(stderr,"gcovar: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcovar); +} + +/************** coliteral ******************/ + +coresyn mkcoliteral(PPgcoliteral) + literal PPgcoliteral; +{ + register struct Scoliteral *pp = + (struct Scoliteral *) malloc(sizeof(struct Scoliteral)); + pp -> tag = coliteral; + pp -> Xgcoliteral = PPgcoliteral; + return((coresyn)pp); +} + +literal *Rgcoliteral(t) + struct Scoliteral *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coliteral) + fprintf(stderr,"gcoliteral: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoliteral); +} + +/************** cocon ******************/ + +coresyn mkcocon(PPgcocon_con, PPgcocon_tys, PPgcocon_args) + coresyn PPgcocon_con; + list PPgcocon_tys; + list PPgcocon_args; +{ + register struct Scocon *pp = + (struct Scocon *) malloc(sizeof(struct Scocon)); + pp -> tag = cocon; + pp -> Xgcocon_con = PPgcocon_con; + pp -> Xgcocon_tys = PPgcocon_tys; + pp -> Xgcocon_args = PPgcocon_args; + return((coresyn)pp); +} + +coresyn *Rgcocon_con(t) + struct Scocon *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocon) + fprintf(stderr,"gcocon_con: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocon_con); +} + +list *Rgcocon_tys(t) + struct Scocon *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocon) + fprintf(stderr,"gcocon_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocon_tys); +} + +list *Rgcocon_args(t) + struct Scocon *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocon) + fprintf(stderr,"gcocon_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocon_args); +} + +/************** coprim ******************/ + +coresyn mkcoprim(PPgcoprim_op, PPgcoprim_tys, PPgcoprim_args) + coresyn PPgcoprim_op; + list PPgcoprim_tys; + list PPgcoprim_args; +{ + register struct Scoprim *pp = + (struct Scoprim *) malloc(sizeof(struct Scoprim)); + pp -> tag = coprim; + pp -> Xgcoprim_op = PPgcoprim_op; + pp -> Xgcoprim_tys = PPgcoprim_tys; + pp -> Xgcoprim_args = PPgcoprim_args; + return((coresyn)pp); +} + +coresyn *Rgcoprim_op(t) + struct Scoprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim) + fprintf(stderr,"gcoprim_op: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_op); +} + +list *Rgcoprim_tys(t) + struct Scoprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim) + fprintf(stderr,"gcoprim_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_tys); +} + +list *Rgcoprim_args(t) + struct Scoprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim) + fprintf(stderr,"gcoprim_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_args); +} + +/************** colam ******************/ + +coresyn mkcolam(PPgcolam_vars, PPgcolam_body) + list PPgcolam_vars; + coresyn PPgcolam_body; +{ + register struct Scolam *pp = + (struct Scolam *) malloc(sizeof(struct Scolam)); + pp -> tag = colam; + pp -> Xgcolam_vars = PPgcolam_vars; + pp -> Xgcolam_body = PPgcolam_body; + return((coresyn)pp); +} + +list *Rgcolam_vars(t) + struct Scolam *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != colam) + fprintf(stderr,"gcolam_vars: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolam_vars); +} + +coresyn *Rgcolam_body(t) + struct Scolam *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != colam) + fprintf(stderr,"gcolam_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolam_body); +} + +/************** cotylam ******************/ + +coresyn mkcotylam(PPgcotylam_tvs, PPgcotylam_body) + list PPgcotylam_tvs; + coresyn PPgcotylam_body; +{ + register struct Scotylam *pp = + (struct Scotylam *) malloc(sizeof(struct Scotylam)); + pp -> tag = cotylam; + pp -> Xgcotylam_tvs = PPgcotylam_tvs; + pp -> Xgcotylam_body = PPgcotylam_body; + return((coresyn)pp); +} + +list *Rgcotylam_tvs(t) + struct Scotylam *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotylam) + fprintf(stderr,"gcotylam_tvs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotylam_tvs); +} + +coresyn *Rgcotylam_body(t) + struct Scotylam *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotylam) + fprintf(stderr,"gcotylam_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotylam_body); +} + +/************** coapp ******************/ + +coresyn mkcoapp(PPgcoapp_fun, PPgcoapp_args) + coresyn PPgcoapp_fun; + list PPgcoapp_args; +{ + register struct Scoapp *pp = + (struct Scoapp *) malloc(sizeof(struct Scoapp)); + pp -> tag = coapp; + pp -> Xgcoapp_fun = PPgcoapp_fun; + pp -> Xgcoapp_args = PPgcoapp_args; + return((coresyn)pp); +} + +coresyn *Rgcoapp_fun(t) + struct Scoapp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coapp) + fprintf(stderr,"gcoapp_fun: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoapp_fun); +} + +list *Rgcoapp_args(t) + struct Scoapp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coapp) + fprintf(stderr,"gcoapp_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoapp_args); +} + +/************** cotyapp ******************/ + +coresyn mkcotyapp(PPgcotyapp_e, PPgcotyapp_t) + coresyn PPgcotyapp_e; + ttype PPgcotyapp_t; +{ + register struct Scotyapp *pp = + (struct Scotyapp *) malloc(sizeof(struct Scotyapp)); + pp -> tag = cotyapp; + pp -> Xgcotyapp_e = PPgcotyapp_e; + pp -> Xgcotyapp_t = PPgcotyapp_t; + return((coresyn)pp); +} + +coresyn *Rgcotyapp_e(t) + struct Scotyapp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotyapp) + fprintf(stderr,"gcotyapp_e: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotyapp_e); +} + +ttype *Rgcotyapp_t(t) + struct Scotyapp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotyapp) + fprintf(stderr,"gcotyapp_t: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotyapp_t); +} + +/************** cocase ******************/ + +coresyn mkcocase(PPgcocase_s, PPgcocase_alts) + coresyn PPgcocase_s; + coresyn PPgcocase_alts; +{ + register struct Scocase *pp = + (struct Scocase *) malloc(sizeof(struct Scocase)); + pp -> tag = cocase; + pp -> Xgcocase_s = PPgcocase_s; + pp -> Xgcocase_alts = PPgcocase_alts; + return((coresyn)pp); +} + +coresyn *Rgcocase_s(t) + struct Scocase *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocase) + fprintf(stderr,"gcocase_s: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocase_s); +} + +coresyn *Rgcocase_alts(t) + struct Scocase *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocase) + fprintf(stderr,"gcocase_alts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocase_alts); +} + +/************** colet ******************/ + +coresyn mkcolet(PPgcolet_bind, PPgcolet_body) + coresyn PPgcolet_bind; + coresyn PPgcolet_body; +{ + register struct Scolet *pp = + (struct Scolet *) malloc(sizeof(struct Scolet)); + pp -> tag = colet; + pp -> Xgcolet_bind = PPgcolet_bind; + pp -> Xgcolet_body = PPgcolet_body; + return((coresyn)pp); +} + +coresyn *Rgcolet_bind(t) + struct Scolet *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != colet) + fprintf(stderr,"gcolet_bind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolet_bind); +} + +coresyn *Rgcolet_body(t) + struct Scolet *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != colet) + fprintf(stderr,"gcolet_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolet_body); +} + +/************** coscc ******************/ + +coresyn mkcoscc(PPgcoscc_scc, PPgcoscc_body) + coresyn PPgcoscc_scc; + coresyn PPgcoscc_body; +{ + register struct Scoscc *pp = + (struct Scoscc *) malloc(sizeof(struct Scoscc)); + pp -> tag = coscc; + pp -> Xgcoscc_scc = PPgcoscc_scc; + pp -> Xgcoscc_body = PPgcoscc_body; + return((coresyn)pp); +} + +coresyn *Rgcoscc_scc(t) + struct Scoscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coscc) + fprintf(stderr,"gcoscc_scc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoscc_scc); +} + +coresyn *Rgcoscc_body(t) + struct Scoscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coscc) + fprintf(stderr,"gcoscc_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoscc_body); +} + +/************** coalg_alts ******************/ + +coresyn mkcoalg_alts(PPgcoalg_alts, PPgcoalg_deflt) + list PPgcoalg_alts; + coresyn PPgcoalg_deflt; +{ + register struct Scoalg_alts *pp = + (struct Scoalg_alts *) malloc(sizeof(struct Scoalg_alts)); + pp -> tag = coalg_alts; + pp -> Xgcoalg_alts = PPgcoalg_alts; + pp -> Xgcoalg_deflt = PPgcoalg_deflt; + return((coresyn)pp); +} + +list *Rgcoalg_alts(t) + struct Scoalg_alts *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alts) + fprintf(stderr,"gcoalg_alts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_alts); +} + +coresyn *Rgcoalg_deflt(t) + struct Scoalg_alts *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alts) + fprintf(stderr,"gcoalg_deflt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_deflt); +} + +/************** coalg_alt ******************/ + +coresyn mkcoalg_alt(PPgcoalg_con, PPgcoalg_bs, PPgcoalg_rhs) + coresyn PPgcoalg_con; + list PPgcoalg_bs; + coresyn PPgcoalg_rhs; +{ + register struct Scoalg_alt *pp = + (struct Scoalg_alt *) malloc(sizeof(struct Scoalg_alt)); + pp -> tag = coalg_alt; + pp -> Xgcoalg_con = PPgcoalg_con; + pp -> Xgcoalg_bs = PPgcoalg_bs; + pp -> Xgcoalg_rhs = PPgcoalg_rhs; + return((coresyn)pp); +} + +coresyn *Rgcoalg_con(t) + struct Scoalg_alt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alt) + fprintf(stderr,"gcoalg_con: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_con); +} + +list *Rgcoalg_bs(t) + struct Scoalg_alt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alt) + fprintf(stderr,"gcoalg_bs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_bs); +} + +coresyn *Rgcoalg_rhs(t) + struct Scoalg_alt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alt) + fprintf(stderr,"gcoalg_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_rhs); +} + +/************** coprim_alts ******************/ + +coresyn mkcoprim_alts(PPgcoprim_alts, PPgcoprim_deflt) + list PPgcoprim_alts; + coresyn PPgcoprim_deflt; +{ + register struct Scoprim_alts *pp = + (struct Scoprim_alts *) malloc(sizeof(struct Scoprim_alts)); + pp -> tag = coprim_alts; + pp -> Xgcoprim_alts = PPgcoprim_alts; + pp -> Xgcoprim_deflt = PPgcoprim_deflt; + return((coresyn)pp); +} + +list *Rgcoprim_alts(t) + struct Scoprim_alts *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alts) + fprintf(stderr,"gcoprim_alts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_alts); +} + +coresyn *Rgcoprim_deflt(t) + struct Scoprim_alts *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alts) + fprintf(stderr,"gcoprim_deflt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_deflt); +} + +/************** coprim_alt ******************/ + +coresyn mkcoprim_alt(PPgcoprim_lit, PPgcoprim_rhs) + literal PPgcoprim_lit; + coresyn PPgcoprim_rhs; +{ + register struct Scoprim_alt *pp = + (struct Scoprim_alt *) malloc(sizeof(struct Scoprim_alt)); + pp -> tag = coprim_alt; + pp -> Xgcoprim_lit = PPgcoprim_lit; + pp -> Xgcoprim_rhs = PPgcoprim_rhs; + return((coresyn)pp); +} + +literal *Rgcoprim_lit(t) + struct Scoprim_alt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alt) + fprintf(stderr,"gcoprim_lit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_lit); +} + +coresyn *Rgcoprim_rhs(t) + struct Scoprim_alt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alt) + fprintf(stderr,"gcoprim_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_rhs); +} + +/************** conodeflt ******************/ + +coresyn mkconodeflt() +{ + register struct Sconodeflt *pp = + (struct Sconodeflt *) malloc(sizeof(struct Sconodeflt)); + pp -> tag = conodeflt; + return((coresyn)pp); +} + +/************** cobinddeflt ******************/ + +coresyn mkcobinddeflt(PPgcobinddeflt_v, PPgcobinddeflt_rhs) + coresyn PPgcobinddeflt_v; + coresyn PPgcobinddeflt_rhs; +{ + register struct Scobinddeflt *pp = + (struct Scobinddeflt *) malloc(sizeof(struct Scobinddeflt)); + pp -> tag = cobinddeflt; + pp -> Xgcobinddeflt_v = PPgcobinddeflt_v; + pp -> Xgcobinddeflt_rhs = PPgcobinddeflt_rhs; + return((coresyn)pp); +} + +coresyn *Rgcobinddeflt_v(t) + struct Scobinddeflt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinddeflt) + fprintf(stderr,"gcobinddeflt_v: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinddeflt_v); +} + +coresyn *Rgcobinddeflt_rhs(t) + struct Scobinddeflt *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinddeflt) + fprintf(stderr,"gcobinddeflt_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinddeflt_rhs); +} + +/************** co_primop ******************/ + +coresyn mkco_primop(PPgco_primop) + stringId PPgco_primop; +{ + register struct Sco_primop *pp = + (struct Sco_primop *) malloc(sizeof(struct Sco_primop)); + pp -> tag = co_primop; + pp -> Xgco_primop = PPgco_primop; + return((coresyn)pp); +} + +stringId *Rgco_primop(t) + struct Sco_primop *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_primop) + fprintf(stderr,"gco_primop: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_primop); +} + +/************** co_ccall ******************/ + +coresyn mkco_ccall(PPgco_ccall, PPgco_ccall_may_gc, PPgco_ccall_arg_tys, PPgco_ccall_res_ty) + stringId PPgco_ccall; + long PPgco_ccall_may_gc; + list PPgco_ccall_arg_tys; + ttype PPgco_ccall_res_ty; +{ + register struct Sco_ccall *pp = + (struct Sco_ccall *) malloc(sizeof(struct Sco_ccall)); + pp -> tag = co_ccall; + pp -> Xgco_ccall = PPgco_ccall; + pp -> Xgco_ccall_may_gc = PPgco_ccall_may_gc; + pp -> Xgco_ccall_arg_tys = PPgco_ccall_arg_tys; + pp -> Xgco_ccall_res_ty = PPgco_ccall_res_ty; + return((coresyn)pp); +} + +stringId *Rgco_ccall(t) + struct Sco_ccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall); +} + +long *Rgco_ccall_may_gc(t) + struct Sco_ccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall_may_gc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall_may_gc); +} + +list *Rgco_ccall_arg_tys(t) + struct Sco_ccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall_arg_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall_arg_tys); +} + +ttype *Rgco_ccall_res_ty(t) + struct Sco_ccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall_res_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall_res_ty); +} + +/************** co_casm ******************/ + +coresyn mkco_casm(PPgco_casm, PPgco_casm_may_gc, PPgco_casm_arg_tys, PPgco_casm_res_ty) + literal PPgco_casm; + long PPgco_casm_may_gc; + list PPgco_casm_arg_tys; + ttype PPgco_casm_res_ty; +{ + register struct Sco_casm *pp = + (struct Sco_casm *) malloc(sizeof(struct Sco_casm)); + pp -> tag = co_casm; + pp -> Xgco_casm = PPgco_casm; + pp -> Xgco_casm_may_gc = PPgco_casm_may_gc; + pp -> Xgco_casm_arg_tys = PPgco_casm_arg_tys; + pp -> Xgco_casm_res_ty = PPgco_casm_res_ty; + return((coresyn)pp); +} + +literal *Rgco_casm(t) + struct Sco_casm *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm); +} + +long *Rgco_casm_may_gc(t) + struct Sco_casm *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm_may_gc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm_may_gc); +} + +list *Rgco_casm_arg_tys(t) + struct Sco_casm *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm_arg_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm_arg_tys); +} + +ttype *Rgco_casm_res_ty(t) + struct Sco_casm *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm_res_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm_res_ty); +} + +/************** co_preludedictscc ******************/ + +coresyn mkco_preludedictscc(PPgco_preludedictscc_dupd) + coresyn PPgco_preludedictscc_dupd; +{ + register struct Sco_preludedictscc *pp = + (struct Sco_preludedictscc *) malloc(sizeof(struct Sco_preludedictscc)); + pp -> tag = co_preludedictscc; + pp -> Xgco_preludedictscc_dupd = PPgco_preludedictscc_dupd; + return((coresyn)pp); +} + +coresyn *Rgco_preludedictscc_dupd(t) + struct Sco_preludedictscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_preludedictscc) + fprintf(stderr,"gco_preludedictscc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_preludedictscc_dupd); +} + +/************** co_alldictscc ******************/ + +coresyn mkco_alldictscc(PPgco_alldictscc_m, PPgco_alldictscc_g, PPgco_alldictscc_dupd) + hstring PPgco_alldictscc_m; + hstring PPgco_alldictscc_g; + coresyn PPgco_alldictscc_dupd; +{ + register struct Sco_alldictscc *pp = + (struct Sco_alldictscc *) malloc(sizeof(struct Sco_alldictscc)); + pp -> tag = co_alldictscc; + pp -> Xgco_alldictscc_m = PPgco_alldictscc_m; + pp -> Xgco_alldictscc_g = PPgco_alldictscc_g; + pp -> Xgco_alldictscc_dupd = PPgco_alldictscc_dupd; + return((coresyn)pp); +} + +hstring *Rgco_alldictscc_m(t) + struct Sco_alldictscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_alldictscc) + fprintf(stderr,"gco_alldictscc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_alldictscc_m); +} + +hstring *Rgco_alldictscc_g(t) + struct Sco_alldictscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_alldictscc) + fprintf(stderr,"gco_alldictscc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_alldictscc_g); +} + +coresyn *Rgco_alldictscc_dupd(t) + struct Sco_alldictscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_alldictscc) + fprintf(stderr,"gco_alldictscc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_alldictscc_dupd); +} + +/************** co_usercc ******************/ + +coresyn mkco_usercc(PPgco_usercc_n, PPgco_usercc_m, PPgco_usercc_g, PPgco_usercc_dupd, PPgco_usercc_cafd) + hstring PPgco_usercc_n; + hstring PPgco_usercc_m; + hstring PPgco_usercc_g; + coresyn PPgco_usercc_dupd; + coresyn PPgco_usercc_cafd; +{ + register struct Sco_usercc *pp = + (struct Sco_usercc *) malloc(sizeof(struct Sco_usercc)); + pp -> tag = co_usercc; + pp -> Xgco_usercc_n = PPgco_usercc_n; + pp -> Xgco_usercc_m = PPgco_usercc_m; + pp -> Xgco_usercc_g = PPgco_usercc_g; + pp -> Xgco_usercc_dupd = PPgco_usercc_dupd; + pp -> Xgco_usercc_cafd = PPgco_usercc_cafd; + return((coresyn)pp); +} + +hstring *Rgco_usercc_n(t) + struct Sco_usercc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_n: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_n); +} + +hstring *Rgco_usercc_m(t) + struct Sco_usercc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_m); +} + +hstring *Rgco_usercc_g(t) + struct Sco_usercc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_g); +} + +coresyn *Rgco_usercc_dupd(t) + struct Sco_usercc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_dupd); +} + +coresyn *Rgco_usercc_cafd(t) + struct Sco_usercc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_cafd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_cafd); +} + +/************** co_autocc ******************/ + +coresyn mkco_autocc(PPgco_autocc_i, PPgco_autocc_m, PPgco_autocc_g, PPgco_autocc_dupd, PPgco_autocc_cafd) + coresyn PPgco_autocc_i; + hstring PPgco_autocc_m; + hstring PPgco_autocc_g; + coresyn PPgco_autocc_dupd; + coresyn PPgco_autocc_cafd; +{ + register struct Sco_autocc *pp = + (struct Sco_autocc *) malloc(sizeof(struct Sco_autocc)); + pp -> tag = co_autocc; + pp -> Xgco_autocc_i = PPgco_autocc_i; + pp -> Xgco_autocc_m = PPgco_autocc_m; + pp -> Xgco_autocc_g = PPgco_autocc_g; + pp -> Xgco_autocc_dupd = PPgco_autocc_dupd; + pp -> Xgco_autocc_cafd = PPgco_autocc_cafd; + return((coresyn)pp); +} + +coresyn *Rgco_autocc_i(t) + struct Sco_autocc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_i: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_i); +} + +hstring *Rgco_autocc_m(t) + struct Sco_autocc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_m); +} + +hstring *Rgco_autocc_g(t) + struct Sco_autocc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_g); +} + +coresyn *Rgco_autocc_dupd(t) + struct Sco_autocc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_dupd); +} + +coresyn *Rgco_autocc_cafd(t) + struct Sco_autocc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_cafd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_cafd); +} + +/************** co_dictcc ******************/ + +coresyn mkco_dictcc(PPgco_dictcc_i, PPgco_dictcc_m, PPgco_dictcc_g, PPgco_dictcc_dupd, PPgco_dictcc_cafd) + coresyn PPgco_dictcc_i; + hstring PPgco_dictcc_m; + hstring PPgco_dictcc_g; + coresyn PPgco_dictcc_dupd; + coresyn PPgco_dictcc_cafd; +{ + register struct Sco_dictcc *pp = + (struct Sco_dictcc *) malloc(sizeof(struct Sco_dictcc)); + pp -> tag = co_dictcc; + pp -> Xgco_dictcc_i = PPgco_dictcc_i; + pp -> Xgco_dictcc_m = PPgco_dictcc_m; + pp -> Xgco_dictcc_g = PPgco_dictcc_g; + pp -> Xgco_dictcc_dupd = PPgco_dictcc_dupd; + pp -> Xgco_dictcc_cafd = PPgco_dictcc_cafd; + return((coresyn)pp); +} + +coresyn *Rgco_dictcc_i(t) + struct Sco_dictcc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_i: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_i); +} + +hstring *Rgco_dictcc_m(t) + struct Sco_dictcc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_m); +} + +hstring *Rgco_dictcc_g(t) + struct Sco_dictcc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_g); +} + +coresyn *Rgco_dictcc_dupd(t) + struct Sco_dictcc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_dupd); +} + +coresyn *Rgco_dictcc_cafd(t) + struct Sco_dictcc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_cafd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_cafd); +} + +/************** co_scc_noncaf ******************/ + +coresyn mkco_scc_noncaf() +{ + register struct Sco_scc_noncaf *pp = + (struct Sco_scc_noncaf *) malloc(sizeof(struct Sco_scc_noncaf)); + pp -> tag = co_scc_noncaf; + return((coresyn)pp); +} + +/************** co_scc_caf ******************/ + +coresyn mkco_scc_caf() +{ + register struct Sco_scc_caf *pp = + (struct Sco_scc_caf *) malloc(sizeof(struct Sco_scc_caf)); + pp -> tag = co_scc_caf; + return((coresyn)pp); +} + +/************** co_scc_nondupd ******************/ + +coresyn mkco_scc_nondupd() +{ + register struct Sco_scc_nondupd *pp = + (struct Sco_scc_nondupd *) malloc(sizeof(struct Sco_scc_nondupd)); + pp -> tag = co_scc_nondupd; + return((coresyn)pp); +} + +/************** co_scc_dupd ******************/ + +coresyn mkco_scc_dupd() +{ + register struct Sco_scc_dupd *pp = + (struct Sco_scc_dupd *) malloc(sizeof(struct Sco_scc_dupd)); + pp -> tag = co_scc_dupd; + return((coresyn)pp); +} + +/************** co_id ******************/ + +coresyn mkco_id(PPgco_id) + stringId PPgco_id; +{ + register struct Sco_id *pp = + (struct Sco_id *) malloc(sizeof(struct Sco_id)); + pp -> tag = co_id; + pp -> Xgco_id = PPgco_id; + return((coresyn)pp); +} + +stringId *Rgco_id(t) + struct Sco_id *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_id) + fprintf(stderr,"gco_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_id); +} + +/************** co_orig_id ******************/ + +coresyn mkco_orig_id(PPgco_orig_id_m, PPgco_orig_id_n) + stringId PPgco_orig_id_m; + stringId PPgco_orig_id_n; +{ + register struct Sco_orig_id *pp = + (struct Sco_orig_id *) malloc(sizeof(struct Sco_orig_id)); + pp -> tag = co_orig_id; + pp -> Xgco_orig_id_m = PPgco_orig_id_m; + pp -> Xgco_orig_id_n = PPgco_orig_id_n; + return((coresyn)pp); +} + +stringId *Rgco_orig_id_m(t) + struct Sco_orig_id *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_orig_id) + fprintf(stderr,"gco_orig_id_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_orig_id_m); +} + +stringId *Rgco_orig_id_n(t) + struct Sco_orig_id *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_orig_id) + fprintf(stderr,"gco_orig_id_n: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_orig_id_n); +} + +/************** co_sdselid ******************/ + +coresyn mkco_sdselid(PPgco_sdselid_c, PPgco_sdselid_sc) + unkId PPgco_sdselid_c; + unkId PPgco_sdselid_sc; +{ + register struct Sco_sdselid *pp = + (struct Sco_sdselid *) malloc(sizeof(struct Sco_sdselid)); + pp -> tag = co_sdselid; + pp -> Xgco_sdselid_c = PPgco_sdselid_c; + pp -> Xgco_sdselid_sc = PPgco_sdselid_sc; + return((coresyn)pp); +} + +unkId *Rgco_sdselid_c(t) + struct Sco_sdselid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_sdselid) + fprintf(stderr,"gco_sdselid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_sdselid_c); +} + +unkId *Rgco_sdselid_sc(t) + struct Sco_sdselid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_sdselid) + fprintf(stderr,"gco_sdselid_sc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_sdselid_sc); +} + +/************** co_classopid ******************/ + +coresyn mkco_classopid(PPgco_classopid_c, PPgco_classopid_o) + unkId PPgco_classopid_c; + unkId PPgco_classopid_o; +{ + register struct Sco_classopid *pp = + (struct Sco_classopid *) malloc(sizeof(struct Sco_classopid)); + pp -> tag = co_classopid; + pp -> Xgco_classopid_c = PPgco_classopid_c; + pp -> Xgco_classopid_o = PPgco_classopid_o; + return((coresyn)pp); +} + +unkId *Rgco_classopid_c(t) + struct Sco_classopid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_classopid) + fprintf(stderr,"gco_classopid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_classopid_c); +} + +unkId *Rgco_classopid_o(t) + struct Sco_classopid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_classopid) + fprintf(stderr,"gco_classopid_o: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_classopid_o); +} + +/************** co_defmid ******************/ + +coresyn mkco_defmid(PPgco_defmid_c, PPgco_defmid_op) + unkId PPgco_defmid_c; + unkId PPgco_defmid_op; +{ + register struct Sco_defmid *pp = + (struct Sco_defmid *) malloc(sizeof(struct Sco_defmid)); + pp -> tag = co_defmid; + pp -> Xgco_defmid_c = PPgco_defmid_c; + pp -> Xgco_defmid_op = PPgco_defmid_op; + return((coresyn)pp); +} + +unkId *Rgco_defmid_c(t) + struct Sco_defmid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_defmid) + fprintf(stderr,"gco_defmid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_defmid_c); +} + +unkId *Rgco_defmid_op(t) + struct Sco_defmid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_defmid) + fprintf(stderr,"gco_defmid_op: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_defmid_op); +} + +/************** co_dfunid ******************/ + +coresyn mkco_dfunid(PPgco_dfunid_c, PPgco_dfunid_ty) + unkId PPgco_dfunid_c; + ttype PPgco_dfunid_ty; +{ + register struct Sco_dfunid *pp = + (struct Sco_dfunid *) malloc(sizeof(struct Sco_dfunid)); + pp -> tag = co_dfunid; + pp -> Xgco_dfunid_c = PPgco_dfunid_c; + pp -> Xgco_dfunid_ty = PPgco_dfunid_ty; + return((coresyn)pp); +} + +unkId *Rgco_dfunid_c(t) + struct Sco_dfunid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dfunid) + fprintf(stderr,"gco_dfunid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dfunid_c); +} + +ttype *Rgco_dfunid_ty(t) + struct Sco_dfunid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dfunid) + fprintf(stderr,"gco_dfunid_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dfunid_ty); +} + +/************** co_constmid ******************/ + +coresyn mkco_constmid(PPgco_constmid_c, PPgco_constmid_op, PPgco_constmid_ty) + unkId PPgco_constmid_c; + unkId PPgco_constmid_op; + ttype PPgco_constmid_ty; +{ + register struct Sco_constmid *pp = + (struct Sco_constmid *) malloc(sizeof(struct Sco_constmid)); + pp -> tag = co_constmid; + pp -> Xgco_constmid_c = PPgco_constmid_c; + pp -> Xgco_constmid_op = PPgco_constmid_op; + pp -> Xgco_constmid_ty = PPgco_constmid_ty; + return((coresyn)pp); +} + +unkId *Rgco_constmid_c(t) + struct Sco_constmid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_constmid) + fprintf(stderr,"gco_constmid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_constmid_c); +} + +unkId *Rgco_constmid_op(t) + struct Sco_constmid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_constmid) + fprintf(stderr,"gco_constmid_op: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_constmid_op); +} + +ttype *Rgco_constmid_ty(t) + struct Sco_constmid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_constmid) + fprintf(stderr,"gco_constmid_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_constmid_ty); +} + +/************** co_specid ******************/ + +coresyn mkco_specid(PPgco_specid_un, PPgco_specid_tys) + coresyn PPgco_specid_un; + list PPgco_specid_tys; +{ + register struct Sco_specid *pp = + (struct Sco_specid *) malloc(sizeof(struct Sco_specid)); + pp -> tag = co_specid; + pp -> Xgco_specid_un = PPgco_specid_un; + pp -> Xgco_specid_tys = PPgco_specid_tys; + return((coresyn)pp); +} + +coresyn *Rgco_specid_un(t) + struct Sco_specid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_specid) + fprintf(stderr,"gco_specid_un: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_specid_un); +} + +list *Rgco_specid_tys(t) + struct Sco_specid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_specid) + fprintf(stderr,"gco_specid_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_specid_tys); +} + +/************** co_wrkrid ******************/ + +coresyn mkco_wrkrid(PPgco_wrkrid_un) + coresyn PPgco_wrkrid_un; +{ + register struct Sco_wrkrid *pp = + (struct Sco_wrkrid *) malloc(sizeof(struct Sco_wrkrid)); + pp -> tag = co_wrkrid; + pp -> Xgco_wrkrid_un = PPgco_wrkrid_un; + return((coresyn)pp); +} + +coresyn *Rgco_wrkrid_un(t) + struct Sco_wrkrid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_wrkrid) + fprintf(stderr,"gco_wrkrid_un: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_wrkrid_un); +} diff --git a/ghc/compiler/yaccParser/coresyn.h b/ghc/compiler/yaccParser/coresyn.h new file mode 100644 index 0000000..6786e3e --- /dev/null +++ b/ghc/compiler/yaccParser/coresyn.h @@ -0,0 +1,1728 @@ +#ifndef coresyn_defined +#define coresyn_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + cobinder, + colit, + colocal, + cononrec, + corec, + corec_pair, + covar, + coliteral, + cocon, + coprim, + colam, + cotylam, + coapp, + cotyapp, + cocase, + colet, + coscc, + coalg_alts, + coalg_alt, + coprim_alts, + coprim_alt, + conodeflt, + cobinddeflt, + co_primop, + co_ccall, + co_casm, + co_preludedictscc, + co_alldictscc, + co_usercc, + co_autocc, + co_dictcc, + co_scc_noncaf, + co_scc_caf, + co_scc_nondupd, + co_scc_dupd, + co_id, + co_orig_id, + co_sdselid, + co_classopid, + co_defmid, + co_dfunid, + co_constmid, + co_specid, + co_wrkrid +} Tcoresyn; + +typedef struct { Tcoresyn tag; } *coresyn; + +#ifdef __GNUC__ +extern __inline__ Tcoresyn tcoresyn(coresyn t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tcoresyn tcoresyn PROTO((coresyn)); +#endif /* ! __GNUC__ */ + +struct Scobinder { + Tcoresyn tag; + unkId Xgcobinder_v; + ttype Xgcobinder_ty; +}; + +struct Scolit { + Tcoresyn tag; + literal Xgcolit; +}; + +struct Scolocal { + Tcoresyn tag; + coresyn Xgcolocal_v; +}; + +struct Scononrec { + Tcoresyn tag; + coresyn Xgcononrec_b; + coresyn Xgcononrec_rhs; +}; + +struct Scorec { + Tcoresyn tag; + list Xgcorec; +}; + +struct Scorec_pair { + Tcoresyn tag; + coresyn Xgcorec_b; + coresyn Xgcorec_rhs; +}; + +struct Scovar { + Tcoresyn tag; + coresyn Xgcovar; +}; + +struct Scoliteral { + Tcoresyn tag; + literal Xgcoliteral; +}; + +struct Scocon { + Tcoresyn tag; + coresyn Xgcocon_con; + list Xgcocon_tys; + list Xgcocon_args; +}; + +struct Scoprim { + Tcoresyn tag; + coresyn Xgcoprim_op; + list Xgcoprim_tys; + list Xgcoprim_args; +}; + +struct Scolam { + Tcoresyn tag; + list Xgcolam_vars; + coresyn Xgcolam_body; +}; + +struct Scotylam { + Tcoresyn tag; + list Xgcotylam_tvs; + coresyn Xgcotylam_body; +}; + +struct Scoapp { + Tcoresyn tag; + coresyn Xgcoapp_fun; + list Xgcoapp_args; +}; + +struct Scotyapp { + Tcoresyn tag; + coresyn Xgcotyapp_e; + ttype Xgcotyapp_t; +}; + +struct Scocase { + Tcoresyn tag; + coresyn Xgcocase_s; + coresyn Xgcocase_alts; +}; + +struct Scolet { + Tcoresyn tag; + coresyn Xgcolet_bind; + coresyn Xgcolet_body; +}; + +struct Scoscc { + Tcoresyn tag; + coresyn Xgcoscc_scc; + coresyn Xgcoscc_body; +}; + +struct Scoalg_alts { + Tcoresyn tag; + list Xgcoalg_alts; + coresyn Xgcoalg_deflt; +}; + +struct Scoalg_alt { + Tcoresyn tag; + coresyn Xgcoalg_con; + list Xgcoalg_bs; + coresyn Xgcoalg_rhs; +}; + +struct Scoprim_alts { + Tcoresyn tag; + list Xgcoprim_alts; + coresyn Xgcoprim_deflt; +}; + +struct Scoprim_alt { + Tcoresyn tag; + literal Xgcoprim_lit; + coresyn Xgcoprim_rhs; +}; + +struct Sconodeflt { + Tcoresyn tag; +}; + +struct Scobinddeflt { + Tcoresyn tag; + coresyn Xgcobinddeflt_v; + coresyn Xgcobinddeflt_rhs; +}; + +struct Sco_primop { + Tcoresyn tag; + stringId Xgco_primop; +}; + +struct Sco_ccall { + Tcoresyn tag; + stringId Xgco_ccall; + long Xgco_ccall_may_gc; + list Xgco_ccall_arg_tys; + ttype Xgco_ccall_res_ty; +}; + +struct Sco_casm { + Tcoresyn tag; + literal Xgco_casm; + long Xgco_casm_may_gc; + list Xgco_casm_arg_tys; + ttype Xgco_casm_res_ty; +}; + +struct Sco_preludedictscc { + Tcoresyn tag; + coresyn Xgco_preludedictscc_dupd; +}; + +struct Sco_alldictscc { + Tcoresyn tag; + hstring Xgco_alldictscc_m; + hstring Xgco_alldictscc_g; + coresyn Xgco_alldictscc_dupd; +}; + +struct Sco_usercc { + Tcoresyn tag; + hstring Xgco_usercc_n; + hstring Xgco_usercc_m; + hstring Xgco_usercc_g; + coresyn Xgco_usercc_dupd; + coresyn Xgco_usercc_cafd; +}; + +struct Sco_autocc { + Tcoresyn tag; + coresyn Xgco_autocc_i; + hstring Xgco_autocc_m; + hstring Xgco_autocc_g; + coresyn Xgco_autocc_dupd; + coresyn Xgco_autocc_cafd; +}; + +struct Sco_dictcc { + Tcoresyn tag; + coresyn Xgco_dictcc_i; + hstring Xgco_dictcc_m; + hstring Xgco_dictcc_g; + coresyn Xgco_dictcc_dupd; + coresyn Xgco_dictcc_cafd; +}; + +struct Sco_scc_noncaf { + Tcoresyn tag; +}; + +struct Sco_scc_caf { + Tcoresyn tag; +}; + +struct Sco_scc_nondupd { + Tcoresyn tag; +}; + +struct Sco_scc_dupd { + Tcoresyn tag; +}; + +struct Sco_id { + Tcoresyn tag; + stringId Xgco_id; +}; + +struct Sco_orig_id { + Tcoresyn tag; + stringId Xgco_orig_id_m; + stringId Xgco_orig_id_n; +}; + +struct Sco_sdselid { + Tcoresyn tag; + unkId Xgco_sdselid_c; + unkId Xgco_sdselid_sc; +}; + +struct Sco_classopid { + Tcoresyn tag; + unkId Xgco_classopid_c; + unkId Xgco_classopid_o; +}; + +struct Sco_defmid { + Tcoresyn tag; + unkId Xgco_defmid_c; + unkId Xgco_defmid_op; +}; + +struct Sco_dfunid { + Tcoresyn tag; + unkId Xgco_dfunid_c; + ttype Xgco_dfunid_ty; +}; + +struct Sco_constmid { + Tcoresyn tag; + unkId Xgco_constmid_c; + unkId Xgco_constmid_op; + ttype Xgco_constmid_ty; +}; + +struct Sco_specid { + Tcoresyn tag; + coresyn Xgco_specid_un; + list Xgco_specid_tys; +}; + +struct Sco_wrkrid { + Tcoresyn tag; + coresyn Xgco_wrkrid_un; +}; + +extern coresyn mkcobinder PROTO((unkId, ttype)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgcobinder_v(struct Scobinder *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinder) + fprintf(stderr,"gcobinder_v: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinder_v); +} +#else /* ! __GNUC__ */ +extern unkId *Rgcobinder_v PROTO((struct Scobinder *)); +#endif /* ! __GNUC__ */ + +#define gcobinder_v(xyzxyz) (*Rgcobinder_v((struct Scobinder *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgcobinder_ty(struct Scobinder *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinder) + fprintf(stderr,"gcobinder_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinder_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgcobinder_ty PROTO((struct Scobinder *)); +#endif /* ! __GNUC__ */ + +#define gcobinder_ty(xyzxyz) (*Rgcobinder_ty((struct Scobinder *) (xyzxyz))) + +extern coresyn mkcolit PROTO((literal)); +#ifdef __GNUC__ + +extern __inline__ literal *Rgcolit(struct Scolit *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != colit) + fprintf(stderr,"gcolit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolit); +} +#else /* ! __GNUC__ */ +extern literal *Rgcolit PROTO((struct Scolit *)); +#endif /* ! __GNUC__ */ + +#define gcolit(xyzxyz) (*Rgcolit((struct Scolit *) (xyzxyz))) + +extern coresyn mkcolocal PROTO((coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcolocal_v(struct Scolocal *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != colocal) + fprintf(stderr,"gcolocal_v: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolocal_v); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcolocal_v PROTO((struct Scolocal *)); +#endif /* ! __GNUC__ */ + +#define gcolocal_v(xyzxyz) (*Rgcolocal_v((struct Scolocal *) (xyzxyz))) + +extern coresyn mkcononrec PROTO((coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcononrec_b(struct Scononrec *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cononrec) + fprintf(stderr,"gcononrec_b: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcononrec_b); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcononrec_b PROTO((struct Scononrec *)); +#endif /* ! __GNUC__ */ + +#define gcononrec_b(xyzxyz) (*Rgcononrec_b((struct Scononrec *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcononrec_rhs(struct Scononrec *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cononrec) + fprintf(stderr,"gcononrec_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcononrec_rhs); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcononrec_rhs PROTO((struct Scononrec *)); +#endif /* ! __GNUC__ */ + +#define gcononrec_rhs(xyzxyz) (*Rgcononrec_rhs((struct Scononrec *) (xyzxyz))) + +extern coresyn mkcorec PROTO((list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgcorec(struct Scorec *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != corec) + fprintf(stderr,"gcorec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcorec); +} +#else /* ! __GNUC__ */ +extern list *Rgcorec PROTO((struct Scorec *)); +#endif /* ! __GNUC__ */ + +#define gcorec(xyzxyz) (*Rgcorec((struct Scorec *) (xyzxyz))) + +extern coresyn mkcorec_pair PROTO((coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcorec_b(struct Scorec_pair *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != corec_pair) + fprintf(stderr,"gcorec_b: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcorec_b); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcorec_b PROTO((struct Scorec_pair *)); +#endif /* ! __GNUC__ */ + +#define gcorec_b(xyzxyz) (*Rgcorec_b((struct Scorec_pair *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcorec_rhs(struct Scorec_pair *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != corec_pair) + fprintf(stderr,"gcorec_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcorec_rhs); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcorec_rhs PROTO((struct Scorec_pair *)); +#endif /* ! __GNUC__ */ + +#define gcorec_rhs(xyzxyz) (*Rgcorec_rhs((struct Scorec_pair *) (xyzxyz))) + +extern coresyn mkcovar PROTO((coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcovar(struct Scovar *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != covar) + fprintf(stderr,"gcovar: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcovar); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcovar PROTO((struct Scovar *)); +#endif /* ! __GNUC__ */ + +#define gcovar(xyzxyz) (*Rgcovar((struct Scovar *) (xyzxyz))) + +extern coresyn mkcoliteral PROTO((literal)); +#ifdef __GNUC__ + +extern __inline__ literal *Rgcoliteral(struct Scoliteral *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coliteral) + fprintf(stderr,"gcoliteral: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoliteral); +} +#else /* ! __GNUC__ */ +extern literal *Rgcoliteral PROTO((struct Scoliteral *)); +#endif /* ! __GNUC__ */ + +#define gcoliteral(xyzxyz) (*Rgcoliteral((struct Scoliteral *) (xyzxyz))) + +extern coresyn mkcocon PROTO((coresyn, list, list)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcocon_con(struct Scocon *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocon) + fprintf(stderr,"gcocon_con: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocon_con); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcocon_con PROTO((struct Scocon *)); +#endif /* ! __GNUC__ */ + +#define gcocon_con(xyzxyz) (*Rgcocon_con((struct Scocon *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcocon_tys(struct Scocon *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocon) + fprintf(stderr,"gcocon_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocon_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgcocon_tys PROTO((struct Scocon *)); +#endif /* ! __GNUC__ */ + +#define gcocon_tys(xyzxyz) (*Rgcocon_tys((struct Scocon *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcocon_args(struct Scocon *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocon) + fprintf(stderr,"gcocon_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocon_args); +} +#else /* ! __GNUC__ */ +extern list *Rgcocon_args PROTO((struct Scocon *)); +#endif /* ! __GNUC__ */ + +#define gcocon_args(xyzxyz) (*Rgcocon_args((struct Scocon *) (xyzxyz))) + +extern coresyn mkcoprim PROTO((coresyn, list, list)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoprim_op(struct Scoprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim) + fprintf(stderr,"gcoprim_op: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_op); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoprim_op PROTO((struct Scoprim *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_op(xyzxyz) (*Rgcoprim_op((struct Scoprim *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcoprim_tys(struct Scoprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim) + fprintf(stderr,"gcoprim_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgcoprim_tys PROTO((struct Scoprim *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_tys(xyzxyz) (*Rgcoprim_tys((struct Scoprim *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcoprim_args(struct Scoprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim) + fprintf(stderr,"gcoprim_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_args); +} +#else /* ! __GNUC__ */ +extern list *Rgcoprim_args PROTO((struct Scoprim *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_args(xyzxyz) (*Rgcoprim_args((struct Scoprim *) (xyzxyz))) + +extern coresyn mkcolam PROTO((list, coresyn)); +#ifdef __GNUC__ + +extern __inline__ list *Rgcolam_vars(struct Scolam *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != colam) + fprintf(stderr,"gcolam_vars: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolam_vars); +} +#else /* ! __GNUC__ */ +extern list *Rgcolam_vars PROTO((struct Scolam *)); +#endif /* ! __GNUC__ */ + +#define gcolam_vars(xyzxyz) (*Rgcolam_vars((struct Scolam *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcolam_body(struct Scolam *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != colam) + fprintf(stderr,"gcolam_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolam_body); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcolam_body PROTO((struct Scolam *)); +#endif /* ! __GNUC__ */ + +#define gcolam_body(xyzxyz) (*Rgcolam_body((struct Scolam *) (xyzxyz))) + +extern coresyn mkcotylam PROTO((list, coresyn)); +#ifdef __GNUC__ + +extern __inline__ list *Rgcotylam_tvs(struct Scotylam *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotylam) + fprintf(stderr,"gcotylam_tvs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotylam_tvs); +} +#else /* ! __GNUC__ */ +extern list *Rgcotylam_tvs PROTO((struct Scotylam *)); +#endif /* ! __GNUC__ */ + +#define gcotylam_tvs(xyzxyz) (*Rgcotylam_tvs((struct Scotylam *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcotylam_body(struct Scotylam *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotylam) + fprintf(stderr,"gcotylam_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotylam_body); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcotylam_body PROTO((struct Scotylam *)); +#endif /* ! __GNUC__ */ + +#define gcotylam_body(xyzxyz) (*Rgcotylam_body((struct Scotylam *) (xyzxyz))) + +extern coresyn mkcoapp PROTO((coresyn, list)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoapp_fun(struct Scoapp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coapp) + fprintf(stderr,"gcoapp_fun: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoapp_fun); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoapp_fun PROTO((struct Scoapp *)); +#endif /* ! __GNUC__ */ + +#define gcoapp_fun(xyzxyz) (*Rgcoapp_fun((struct Scoapp *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcoapp_args(struct Scoapp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coapp) + fprintf(stderr,"gcoapp_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoapp_args); +} +#else /* ! __GNUC__ */ +extern list *Rgcoapp_args PROTO((struct Scoapp *)); +#endif /* ! __GNUC__ */ + +#define gcoapp_args(xyzxyz) (*Rgcoapp_args((struct Scoapp *) (xyzxyz))) + +extern coresyn mkcotyapp PROTO((coresyn, ttype)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcotyapp_e(struct Scotyapp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotyapp) + fprintf(stderr,"gcotyapp_e: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotyapp_e); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcotyapp_e PROTO((struct Scotyapp *)); +#endif /* ! __GNUC__ */ + +#define gcotyapp_e(xyzxyz) (*Rgcotyapp_e((struct Scotyapp *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgcotyapp_t(struct Scotyapp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cotyapp) + fprintf(stderr,"gcotyapp_t: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcotyapp_t); +} +#else /* ! __GNUC__ */ +extern ttype *Rgcotyapp_t PROTO((struct Scotyapp *)); +#endif /* ! __GNUC__ */ + +#define gcotyapp_t(xyzxyz) (*Rgcotyapp_t((struct Scotyapp *) (xyzxyz))) + +extern coresyn mkcocase PROTO((coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcocase_s(struct Scocase *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocase) + fprintf(stderr,"gcocase_s: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocase_s); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcocase_s PROTO((struct Scocase *)); +#endif /* ! __GNUC__ */ + +#define gcocase_s(xyzxyz) (*Rgcocase_s((struct Scocase *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcocase_alts(struct Scocase *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cocase) + fprintf(stderr,"gcocase_alts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcocase_alts); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcocase_alts PROTO((struct Scocase *)); +#endif /* ! __GNUC__ */ + +#define gcocase_alts(xyzxyz) (*Rgcocase_alts((struct Scocase *) (xyzxyz))) + +extern coresyn mkcolet PROTO((coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcolet_bind(struct Scolet *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != colet) + fprintf(stderr,"gcolet_bind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolet_bind); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcolet_bind PROTO((struct Scolet *)); +#endif /* ! __GNUC__ */ + +#define gcolet_bind(xyzxyz) (*Rgcolet_bind((struct Scolet *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcolet_body(struct Scolet *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != colet) + fprintf(stderr,"gcolet_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcolet_body); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcolet_body PROTO((struct Scolet *)); +#endif /* ! __GNUC__ */ + +#define gcolet_body(xyzxyz) (*Rgcolet_body((struct Scolet *) (xyzxyz))) + +extern coresyn mkcoscc PROTO((coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoscc_scc(struct Scoscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coscc) + fprintf(stderr,"gcoscc_scc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoscc_scc); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoscc_scc PROTO((struct Scoscc *)); +#endif /* ! __GNUC__ */ + +#define gcoscc_scc(xyzxyz) (*Rgcoscc_scc((struct Scoscc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoscc_body(struct Scoscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coscc) + fprintf(stderr,"gcoscc_body: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoscc_body); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoscc_body PROTO((struct Scoscc *)); +#endif /* ! __GNUC__ */ + +#define gcoscc_body(xyzxyz) (*Rgcoscc_body((struct Scoscc *) (xyzxyz))) + +extern coresyn mkcoalg_alts PROTO((list, coresyn)); +#ifdef __GNUC__ + +extern __inline__ list *Rgcoalg_alts(struct Scoalg_alts *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alts) + fprintf(stderr,"gcoalg_alts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_alts); +} +#else /* ! __GNUC__ */ +extern list *Rgcoalg_alts PROTO((struct Scoalg_alts *)); +#endif /* ! __GNUC__ */ + +#define gcoalg_alts(xyzxyz) (*Rgcoalg_alts((struct Scoalg_alts *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoalg_deflt(struct Scoalg_alts *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alts) + fprintf(stderr,"gcoalg_deflt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_deflt); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoalg_deflt PROTO((struct Scoalg_alts *)); +#endif /* ! __GNUC__ */ + +#define gcoalg_deflt(xyzxyz) (*Rgcoalg_deflt((struct Scoalg_alts *) (xyzxyz))) + +extern coresyn mkcoalg_alt PROTO((coresyn, list, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoalg_con(struct Scoalg_alt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alt) + fprintf(stderr,"gcoalg_con: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_con); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoalg_con PROTO((struct Scoalg_alt *)); +#endif /* ! __GNUC__ */ + +#define gcoalg_con(xyzxyz) (*Rgcoalg_con((struct Scoalg_alt *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcoalg_bs(struct Scoalg_alt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alt) + fprintf(stderr,"gcoalg_bs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_bs); +} +#else /* ! __GNUC__ */ +extern list *Rgcoalg_bs PROTO((struct Scoalg_alt *)); +#endif /* ! __GNUC__ */ + +#define gcoalg_bs(xyzxyz) (*Rgcoalg_bs((struct Scoalg_alt *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoalg_rhs(struct Scoalg_alt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coalg_alt) + fprintf(stderr,"gcoalg_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoalg_rhs); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoalg_rhs PROTO((struct Scoalg_alt *)); +#endif /* ! __GNUC__ */ + +#define gcoalg_rhs(xyzxyz) (*Rgcoalg_rhs((struct Scoalg_alt *) (xyzxyz))) + +extern coresyn mkcoprim_alts PROTO((list, coresyn)); +#ifdef __GNUC__ + +extern __inline__ list *Rgcoprim_alts(struct Scoprim_alts *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alts) + fprintf(stderr,"gcoprim_alts: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_alts); +} +#else /* ! __GNUC__ */ +extern list *Rgcoprim_alts PROTO((struct Scoprim_alts *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_alts(xyzxyz) (*Rgcoprim_alts((struct Scoprim_alts *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoprim_deflt(struct Scoprim_alts *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alts) + fprintf(stderr,"gcoprim_deflt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_deflt); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoprim_deflt PROTO((struct Scoprim_alts *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_deflt(xyzxyz) (*Rgcoprim_deflt((struct Scoprim_alts *) (xyzxyz))) + +extern coresyn mkcoprim_alt PROTO((literal, coresyn)); +#ifdef __GNUC__ + +extern __inline__ literal *Rgcoprim_lit(struct Scoprim_alt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alt) + fprintf(stderr,"gcoprim_lit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_lit); +} +#else /* ! __GNUC__ */ +extern literal *Rgcoprim_lit PROTO((struct Scoprim_alt *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_lit(xyzxyz) (*Rgcoprim_lit((struct Scoprim_alt *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcoprim_rhs(struct Scoprim_alt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != coprim_alt) + fprintf(stderr,"gcoprim_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcoprim_rhs); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcoprim_rhs PROTO((struct Scoprim_alt *)); +#endif /* ! __GNUC__ */ + +#define gcoprim_rhs(xyzxyz) (*Rgcoprim_rhs((struct Scoprim_alt *) (xyzxyz))) + +extern coresyn mkconodeflt PROTO(()); + +extern coresyn mkcobinddeflt PROTO((coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcobinddeflt_v(struct Scobinddeflt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinddeflt) + fprintf(stderr,"gcobinddeflt_v: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinddeflt_v); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcobinddeflt_v PROTO((struct Scobinddeflt *)); +#endif /* ! __GNUC__ */ + +#define gcobinddeflt_v(xyzxyz) (*Rgcobinddeflt_v((struct Scobinddeflt *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgcobinddeflt_rhs(struct Scobinddeflt *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != cobinddeflt) + fprintf(stderr,"gcobinddeflt_rhs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcobinddeflt_rhs); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgcobinddeflt_rhs PROTO((struct Scobinddeflt *)); +#endif /* ! __GNUC__ */ + +#define gcobinddeflt_rhs(xyzxyz) (*Rgcobinddeflt_rhs((struct Scobinddeflt *) (xyzxyz))) + +extern coresyn mkco_primop PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgco_primop(struct Sco_primop *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_primop) + fprintf(stderr,"gco_primop: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_primop); +} +#else /* ! __GNUC__ */ +extern stringId *Rgco_primop PROTO((struct Sco_primop *)); +#endif /* ! __GNUC__ */ + +#define gco_primop(xyzxyz) (*Rgco_primop((struct Sco_primop *) (xyzxyz))) + +extern coresyn mkco_ccall PROTO((stringId, long, list, ttype)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgco_ccall(struct Sco_ccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall); +} +#else /* ! __GNUC__ */ +extern stringId *Rgco_ccall PROTO((struct Sco_ccall *)); +#endif /* ! __GNUC__ */ + +#define gco_ccall(xyzxyz) (*Rgco_ccall((struct Sco_ccall *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgco_ccall_may_gc(struct Sco_ccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall_may_gc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall_may_gc); +} +#else /* ! __GNUC__ */ +extern long *Rgco_ccall_may_gc PROTO((struct Sco_ccall *)); +#endif /* ! __GNUC__ */ + +#define gco_ccall_may_gc(xyzxyz) (*Rgco_ccall_may_gc((struct Sco_ccall *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgco_ccall_arg_tys(struct Sco_ccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall_arg_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall_arg_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgco_ccall_arg_tys PROTO((struct Sco_ccall *)); +#endif /* ! __GNUC__ */ + +#define gco_ccall_arg_tys(xyzxyz) (*Rgco_ccall_arg_tys((struct Sco_ccall *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgco_ccall_res_ty(struct Sco_ccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_ccall) + fprintf(stderr,"gco_ccall_res_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_ccall_res_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgco_ccall_res_ty PROTO((struct Sco_ccall *)); +#endif /* ! __GNUC__ */ + +#define gco_ccall_res_ty(xyzxyz) (*Rgco_ccall_res_ty((struct Sco_ccall *) (xyzxyz))) + +extern coresyn mkco_casm PROTO((literal, long, list, ttype)); +#ifdef __GNUC__ + +extern __inline__ literal *Rgco_casm(struct Sco_casm *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm); +} +#else /* ! __GNUC__ */ +extern literal *Rgco_casm PROTO((struct Sco_casm *)); +#endif /* ! __GNUC__ */ + +#define gco_casm(xyzxyz) (*Rgco_casm((struct Sco_casm *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rgco_casm_may_gc(struct Sco_casm *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm_may_gc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm_may_gc); +} +#else /* ! __GNUC__ */ +extern long *Rgco_casm_may_gc PROTO((struct Sco_casm *)); +#endif /* ! __GNUC__ */ + +#define gco_casm_may_gc(xyzxyz) (*Rgco_casm_may_gc((struct Sco_casm *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgco_casm_arg_tys(struct Sco_casm *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm_arg_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm_arg_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgco_casm_arg_tys PROTO((struct Sco_casm *)); +#endif /* ! __GNUC__ */ + +#define gco_casm_arg_tys(xyzxyz) (*Rgco_casm_arg_tys((struct Sco_casm *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgco_casm_res_ty(struct Sco_casm *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_casm) + fprintf(stderr,"gco_casm_res_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_casm_res_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgco_casm_res_ty PROTO((struct Sco_casm *)); +#endif /* ! __GNUC__ */ + +#define gco_casm_res_ty(xyzxyz) (*Rgco_casm_res_ty((struct Sco_casm *) (xyzxyz))) + +extern coresyn mkco_preludedictscc PROTO((coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_preludedictscc_dupd(struct Sco_preludedictscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_preludedictscc) + fprintf(stderr,"gco_preludedictscc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_preludedictscc_dupd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_preludedictscc_dupd PROTO((struct Sco_preludedictscc *)); +#endif /* ! __GNUC__ */ + +#define gco_preludedictscc_dupd(xyzxyz) (*Rgco_preludedictscc_dupd((struct Sco_preludedictscc *) (xyzxyz))) + +extern coresyn mkco_alldictscc PROTO((hstring, hstring, coresyn)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_alldictscc_m(struct Sco_alldictscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_alldictscc) + fprintf(stderr,"gco_alldictscc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_alldictscc_m); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_alldictscc_m PROTO((struct Sco_alldictscc *)); +#endif /* ! __GNUC__ */ + +#define gco_alldictscc_m(xyzxyz) (*Rgco_alldictscc_m((struct Sco_alldictscc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_alldictscc_g(struct Sco_alldictscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_alldictscc) + fprintf(stderr,"gco_alldictscc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_alldictscc_g); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_alldictscc_g PROTO((struct Sco_alldictscc *)); +#endif /* ! __GNUC__ */ + +#define gco_alldictscc_g(xyzxyz) (*Rgco_alldictscc_g((struct Sco_alldictscc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_alldictscc_dupd(struct Sco_alldictscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_alldictscc) + fprintf(stderr,"gco_alldictscc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_alldictscc_dupd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_alldictscc_dupd PROTO((struct Sco_alldictscc *)); +#endif /* ! __GNUC__ */ + +#define gco_alldictscc_dupd(xyzxyz) (*Rgco_alldictscc_dupd((struct Sco_alldictscc *) (xyzxyz))) + +extern coresyn mkco_usercc PROTO((hstring, hstring, hstring, coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_usercc_n(struct Sco_usercc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_n: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_n); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_usercc_n PROTO((struct Sco_usercc *)); +#endif /* ! __GNUC__ */ + +#define gco_usercc_n(xyzxyz) (*Rgco_usercc_n((struct Sco_usercc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_usercc_m(struct Sco_usercc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_m); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_usercc_m PROTO((struct Sco_usercc *)); +#endif /* ! __GNUC__ */ + +#define gco_usercc_m(xyzxyz) (*Rgco_usercc_m((struct Sco_usercc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_usercc_g(struct Sco_usercc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_g); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_usercc_g PROTO((struct Sco_usercc *)); +#endif /* ! __GNUC__ */ + +#define gco_usercc_g(xyzxyz) (*Rgco_usercc_g((struct Sco_usercc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_usercc_dupd(struct Sco_usercc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_dupd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_usercc_dupd PROTO((struct Sco_usercc *)); +#endif /* ! __GNUC__ */ + +#define gco_usercc_dupd(xyzxyz) (*Rgco_usercc_dupd((struct Sco_usercc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_usercc_cafd(struct Sco_usercc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_usercc) + fprintf(stderr,"gco_usercc_cafd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_usercc_cafd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_usercc_cafd PROTO((struct Sco_usercc *)); +#endif /* ! __GNUC__ */ + +#define gco_usercc_cafd(xyzxyz) (*Rgco_usercc_cafd((struct Sco_usercc *) (xyzxyz))) + +extern coresyn mkco_autocc PROTO((coresyn, hstring, hstring, coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_autocc_i(struct Sco_autocc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_i: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_i); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_autocc_i PROTO((struct Sco_autocc *)); +#endif /* ! __GNUC__ */ + +#define gco_autocc_i(xyzxyz) (*Rgco_autocc_i((struct Sco_autocc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_autocc_m(struct Sco_autocc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_m); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_autocc_m PROTO((struct Sco_autocc *)); +#endif /* ! __GNUC__ */ + +#define gco_autocc_m(xyzxyz) (*Rgco_autocc_m((struct Sco_autocc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_autocc_g(struct Sco_autocc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_g); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_autocc_g PROTO((struct Sco_autocc *)); +#endif /* ! __GNUC__ */ + +#define gco_autocc_g(xyzxyz) (*Rgco_autocc_g((struct Sco_autocc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_autocc_dupd(struct Sco_autocc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_dupd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_autocc_dupd PROTO((struct Sco_autocc *)); +#endif /* ! __GNUC__ */ + +#define gco_autocc_dupd(xyzxyz) (*Rgco_autocc_dupd((struct Sco_autocc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_autocc_cafd(struct Sco_autocc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_autocc) + fprintf(stderr,"gco_autocc_cafd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_autocc_cafd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_autocc_cafd PROTO((struct Sco_autocc *)); +#endif /* ! __GNUC__ */ + +#define gco_autocc_cafd(xyzxyz) (*Rgco_autocc_cafd((struct Sco_autocc *) (xyzxyz))) + +extern coresyn mkco_dictcc PROTO((coresyn, hstring, hstring, coresyn, coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_dictcc_i(struct Sco_dictcc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_i: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_i); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_dictcc_i PROTO((struct Sco_dictcc *)); +#endif /* ! __GNUC__ */ + +#define gco_dictcc_i(xyzxyz) (*Rgco_dictcc_i((struct Sco_dictcc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_dictcc_m(struct Sco_dictcc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_m); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_dictcc_m PROTO((struct Sco_dictcc *)); +#endif /* ! __GNUC__ */ + +#define gco_dictcc_m(xyzxyz) (*Rgco_dictcc_m((struct Sco_dictcc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hstring *Rgco_dictcc_g(struct Sco_dictcc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_g: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_g); +} +#else /* ! __GNUC__ */ +extern hstring *Rgco_dictcc_g PROTO((struct Sco_dictcc *)); +#endif /* ! __GNUC__ */ + +#define gco_dictcc_g(xyzxyz) (*Rgco_dictcc_g((struct Sco_dictcc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_dictcc_dupd(struct Sco_dictcc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_dupd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_dupd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_dictcc_dupd PROTO((struct Sco_dictcc *)); +#endif /* ! __GNUC__ */ + +#define gco_dictcc_dupd(xyzxyz) (*Rgco_dictcc_dupd((struct Sco_dictcc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_dictcc_cafd(struct Sco_dictcc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dictcc) + fprintf(stderr,"gco_dictcc_cafd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dictcc_cafd); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_dictcc_cafd PROTO((struct Sco_dictcc *)); +#endif /* ! __GNUC__ */ + +#define gco_dictcc_cafd(xyzxyz) (*Rgco_dictcc_cafd((struct Sco_dictcc *) (xyzxyz))) + +extern coresyn mkco_scc_noncaf PROTO(()); + +extern coresyn mkco_scc_caf PROTO(()); + +extern coresyn mkco_scc_nondupd PROTO(()); + +extern coresyn mkco_scc_dupd PROTO(()); + +extern coresyn mkco_id PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgco_id(struct Sco_id *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_id) + fprintf(stderr,"gco_id: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_id); +} +#else /* ! __GNUC__ */ +extern stringId *Rgco_id PROTO((struct Sco_id *)); +#endif /* ! __GNUC__ */ + +#define gco_id(xyzxyz) (*Rgco_id((struct Sco_id *) (xyzxyz))) + +extern coresyn mkco_orig_id PROTO((stringId, stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgco_orig_id_m(struct Sco_orig_id *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_orig_id) + fprintf(stderr,"gco_orig_id_m: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_orig_id_m); +} +#else /* ! __GNUC__ */ +extern stringId *Rgco_orig_id_m PROTO((struct Sco_orig_id *)); +#endif /* ! __GNUC__ */ + +#define gco_orig_id_m(xyzxyz) (*Rgco_orig_id_m((struct Sco_orig_id *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgco_orig_id_n(struct Sco_orig_id *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_orig_id) + fprintf(stderr,"gco_orig_id_n: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_orig_id_n); +} +#else /* ! __GNUC__ */ +extern stringId *Rgco_orig_id_n PROTO((struct Sco_orig_id *)); +#endif /* ! __GNUC__ */ + +#define gco_orig_id_n(xyzxyz) (*Rgco_orig_id_n((struct Sco_orig_id *) (xyzxyz))) + +extern coresyn mkco_sdselid PROTO((unkId, unkId)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_sdselid_c(struct Sco_sdselid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_sdselid) + fprintf(stderr,"gco_sdselid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_sdselid_c); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_sdselid_c PROTO((struct Sco_sdselid *)); +#endif /* ! __GNUC__ */ + +#define gco_sdselid_c(xyzxyz) (*Rgco_sdselid_c((struct Sco_sdselid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_sdselid_sc(struct Sco_sdselid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_sdselid) + fprintf(stderr,"gco_sdselid_sc: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_sdselid_sc); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_sdselid_sc PROTO((struct Sco_sdselid *)); +#endif /* ! __GNUC__ */ + +#define gco_sdselid_sc(xyzxyz) (*Rgco_sdselid_sc((struct Sco_sdselid *) (xyzxyz))) + +extern coresyn mkco_classopid PROTO((unkId, unkId)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_classopid_c(struct Sco_classopid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_classopid) + fprintf(stderr,"gco_classopid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_classopid_c); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_classopid_c PROTO((struct Sco_classopid *)); +#endif /* ! __GNUC__ */ + +#define gco_classopid_c(xyzxyz) (*Rgco_classopid_c((struct Sco_classopid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_classopid_o(struct Sco_classopid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_classopid) + fprintf(stderr,"gco_classopid_o: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_classopid_o); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_classopid_o PROTO((struct Sco_classopid *)); +#endif /* ! __GNUC__ */ + +#define gco_classopid_o(xyzxyz) (*Rgco_classopid_o((struct Sco_classopid *) (xyzxyz))) + +extern coresyn mkco_defmid PROTO((unkId, unkId)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_defmid_c(struct Sco_defmid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_defmid) + fprintf(stderr,"gco_defmid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_defmid_c); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_defmid_c PROTO((struct Sco_defmid *)); +#endif /* ! __GNUC__ */ + +#define gco_defmid_c(xyzxyz) (*Rgco_defmid_c((struct Sco_defmid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_defmid_op(struct Sco_defmid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_defmid) + fprintf(stderr,"gco_defmid_op: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_defmid_op); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_defmid_op PROTO((struct Sco_defmid *)); +#endif /* ! __GNUC__ */ + +#define gco_defmid_op(xyzxyz) (*Rgco_defmid_op((struct Sco_defmid *) (xyzxyz))) + +extern coresyn mkco_dfunid PROTO((unkId, ttype)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_dfunid_c(struct Sco_dfunid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dfunid) + fprintf(stderr,"gco_dfunid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dfunid_c); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_dfunid_c PROTO((struct Sco_dfunid *)); +#endif /* ! __GNUC__ */ + +#define gco_dfunid_c(xyzxyz) (*Rgco_dfunid_c((struct Sco_dfunid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgco_dfunid_ty(struct Sco_dfunid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_dfunid) + fprintf(stderr,"gco_dfunid_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_dfunid_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgco_dfunid_ty PROTO((struct Sco_dfunid *)); +#endif /* ! __GNUC__ */ + +#define gco_dfunid_ty(xyzxyz) (*Rgco_dfunid_ty((struct Sco_dfunid *) (xyzxyz))) + +extern coresyn mkco_constmid PROTO((unkId, unkId, ttype)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_constmid_c(struct Sco_constmid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_constmid) + fprintf(stderr,"gco_constmid_c: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_constmid_c); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_constmid_c PROTO((struct Sco_constmid *)); +#endif /* ! __GNUC__ */ + +#define gco_constmid_c(xyzxyz) (*Rgco_constmid_c((struct Sco_constmid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ unkId *Rgco_constmid_op(struct Sco_constmid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_constmid) + fprintf(stderr,"gco_constmid_op: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_constmid_op); +} +#else /* ! __GNUC__ */ +extern unkId *Rgco_constmid_op PROTO((struct Sco_constmid *)); +#endif /* ! __GNUC__ */ + +#define gco_constmid_op(xyzxyz) (*Rgco_constmid_op((struct Sco_constmid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgco_constmid_ty(struct Sco_constmid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_constmid) + fprintf(stderr,"gco_constmid_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_constmid_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgco_constmid_ty PROTO((struct Sco_constmid *)); +#endif /* ! __GNUC__ */ + +#define gco_constmid_ty(xyzxyz) (*Rgco_constmid_ty((struct Sco_constmid *) (xyzxyz))) + +extern coresyn mkco_specid PROTO((coresyn, list)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_specid_un(struct Sco_specid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_specid) + fprintf(stderr,"gco_specid_un: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_specid_un); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_specid_un PROTO((struct Sco_specid *)); +#endif /* ! __GNUC__ */ + +#define gco_specid_un(xyzxyz) (*Rgco_specid_un((struct Sco_specid *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgco_specid_tys(struct Sco_specid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_specid) + fprintf(stderr,"gco_specid_tys: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_specid_tys); +} +#else /* ! __GNUC__ */ +extern list *Rgco_specid_tys PROTO((struct Sco_specid *)); +#endif /* ! __GNUC__ */ + +#define gco_specid_tys(xyzxyz) (*Rgco_specid_tys((struct Sco_specid *) (xyzxyz))) + +extern coresyn mkco_wrkrid PROTO((coresyn)); +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgco_wrkrid_un(struct Sco_wrkrid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != co_wrkrid) + fprintf(stderr,"gco_wrkrid_un: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgco_wrkrid_un); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgco_wrkrid_un PROTO((struct Sco_wrkrid *)); +#endif /* ! __GNUC__ */ + +#define gco_wrkrid_un(xyzxyz) (*Rgco_wrkrid_un((struct Sco_wrkrid *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/coresyn.ugn b/ghc/compiler/yaccParser/coresyn.ugn new file mode 100644 index 0000000..5d65c84 --- /dev/null +++ b/ghc/compiler/yaccParser/coresyn.ugn @@ -0,0 +1,120 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_coresyn where +import UgenUtil +import Util + +import U_list +import U_literal +import U_ttype +%}} +type coresyn; + /* binders: simple Id, plus a type */ + cobinder : < gcobinder_v : unkId; + gcobinder_ty : ttype; >; + + /* atoms */ + colit : < gcolit : literal; >; + colocal : < gcolocal_v : coresyn; >; + + cononrec : ; + corec : ; + corec_pair: ; + + covar : < gcovar : coresyn; >; + coliteral :< gcoliteral : literal; >; + cocon : < gcocon_con : coresyn; + gcocon_tys : list; + gcocon_args : list; >; + coprim : < gcoprim_op : coresyn; /* primop or something */ + gcoprim_tys : list; + gcoprim_args: list; >; + colam : < gcolam_vars : list; + gcolam_body : coresyn; >; + cotylam : < gcotylam_tvs: list; + gcotylam_body : coresyn; >; + coapp : < gcoapp_fun : coresyn; + gcoapp_args : list; >; + cotyapp : < gcotyapp_e : coresyn; + gcotyapp_t : ttype; >; + cocase : < gcocase_s : coresyn; + gcocase_alts : coresyn; >; + colet : < gcolet_bind : coresyn; + gcolet_body : coresyn; >; + coscc : < gcoscc_scc : coresyn; + gcoscc_body : coresyn; >; + + coalg_alts : < gcoalg_alts : list; + gcoalg_deflt : coresyn; >; + coalg_alt : < gcoalg_con : coresyn; + gcoalg_bs : list; + gcoalg_rhs : coresyn; >; + + coprim_alts : < gcoprim_alts : list; + gcoprim_deflt : coresyn; >; + coprim_alt : < gcoprim_lit : literal; + gcoprim_rhs : coresyn; >; + + conodeflt : < >; + cobinddeflt : < gcobinddeflt_v : coresyn; + gcobinddeflt_rhs : coresyn; >; + + co_primop : < gco_primop : stringId;>; + co_ccall : < gco_ccall : stringId; + gco_ccall_may_gc : long; + gco_ccall_arg_tys : list; + gco_ccall_res_ty : ttype; >; + co_casm : < gco_casm : literal; + gco_casm_may_gc : long; + gco_casm_arg_tys : list; + gco_casm_res_ty : ttype; >; + + /* various flavours of cost-centres */ + co_preludedictscc : < gco_preludedictscc_dupd : coresyn; >; + co_alldictscc : < gco_alldictscc_m : hstring; + gco_alldictscc_g : hstring; + gco_alldictscc_dupd : coresyn; >; + co_usercc : < gco_usercc_n : hstring; + gco_usercc_m : hstring; + gco_usercc_g : hstring; + gco_usercc_dupd : coresyn; + gco_usercc_cafd : coresyn; >; + co_autocc : < gco_autocc_i : coresyn; + gco_autocc_m : hstring; + gco_autocc_g : hstring; + gco_autocc_dupd : coresyn; + gco_autocc_cafd : coresyn; >; + co_dictcc : < gco_dictcc_i : coresyn; + gco_dictcc_m : hstring; + gco_dictcc_g : hstring; + gco_dictcc_dupd : coresyn; + gco_dictcc_cafd : coresyn; >; + + co_scc_noncaf : < >; + co_scc_caf : < >; + co_scc_nondupd : < >; + co_scc_dupd : < >; + + /* various flavours of Ids */ + co_id : < gco_id : stringId; >; + co_orig_id : < gco_orig_id_m : stringId; + gco_orig_id_n : stringId; >; + co_sdselid : < gco_sdselid_c : unkId; + gco_sdselid_sc : unkId; >; + co_classopid : < gco_classopid_c : unkId; + gco_classopid_o : unkId; >; + co_defmid : < gco_defmid_c : unkId; + gco_defmid_op : unkId; >; + co_dfunid : < gco_dfunid_c : unkId; + gco_dfunid_ty : ttype; >; + co_constmid : < gco_constmid_c : unkId; + gco_constmid_op : unkId; + gco_constmid_ty : ttype; >; + co_specid : < gco_specid_un : coresyn; + gco_specid_tys : list; >; + co_wrkrid : < gco_wrkrid_un : coresyn; >; +end; diff --git a/ghc/compiler/yaccParser/entidt.c b/ghc/compiler/yaccParser/entidt.c new file mode 100644 index 0000000..3e6c951 --- /dev/null +++ b/ghc/compiler/yaccParser/entidt.c @@ -0,0 +1,167 @@ + + +#include "hspincl.h" +#include "yaccParser/entidt.h" + +Tentidt tentidt(t) + entidt t; +{ + return(t -> tag); +} + + +/************** entid ******************/ + +entidt mkentid(PPgentid) + stringId PPgentid; +{ + register struct Sentid *pp = + (struct Sentid *) malloc(sizeof(struct Sentid)); + pp -> tag = entid; + pp -> Xgentid = PPgentid; + return((entidt)pp); +} + +stringId *Rgentid(t) + struct Sentid *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != entid) + fprintf(stderr,"gentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgentid); +} + +/************** enttype ******************/ + +entidt mkenttype(PPgitentid) + stringId PPgitentid; +{ + register struct Senttype *pp = + (struct Senttype *) malloc(sizeof(struct Senttype)); + pp -> tag = enttype; + pp -> Xgitentid = PPgitentid; + return((entidt)pp); +} + +stringId *Rgitentid(t) + struct Senttype *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttype) + fprintf(stderr,"gitentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgitentid); +} + +/************** enttypeall ******************/ + +entidt mkenttypeall(PPgatentid) + stringId PPgatentid; +{ + register struct Senttypeall *pp = + (struct Senttypeall *) malloc(sizeof(struct Senttypeall)); + pp -> tag = enttypeall; + pp -> Xgatentid = PPgatentid; + return((entidt)pp); +} + +stringId *Rgatentid(t) + struct Senttypeall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttypeall) + fprintf(stderr,"gatentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatentid); +} + +/************** enttypecons ******************/ + +entidt mkenttypecons(PPgctentid, PPgctentcons) + stringId PPgctentid; + list PPgctentcons; +{ + register struct Senttypecons *pp = + (struct Senttypecons *) malloc(sizeof(struct Senttypecons)); + pp -> tag = enttypecons; + pp -> Xgctentid = PPgctentid; + pp -> Xgctentcons = PPgctentcons; + return((entidt)pp); +} + +stringId *Rgctentid(t) + struct Senttypecons *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttypecons) + fprintf(stderr,"gctentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgctentid); +} + +list *Rgctentcons(t) + struct Senttypecons *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttypecons) + fprintf(stderr,"gctentcons: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgctentcons); +} + +/************** entclass ******************/ + +entidt mkentclass(PPgcentid, PPgcentops) + stringId PPgcentid; + list PPgcentops; +{ + register struct Sentclass *pp = + (struct Sentclass *) malloc(sizeof(struct Sentclass)); + pp -> tag = entclass; + pp -> Xgcentid = PPgcentid; + pp -> Xgcentops = PPgcentops; + return((entidt)pp); +} + +stringId *Rgcentid(t) + struct Sentclass *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != entclass) + fprintf(stderr,"gcentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcentid); +} + +list *Rgcentops(t) + struct Sentclass *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != entclass) + fprintf(stderr,"gcentops: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcentops); +} + +/************** entmod ******************/ + +entidt mkentmod(PPgmentid) + stringId PPgmentid; +{ + register struct Sentmod *pp = + (struct Sentmod *) malloc(sizeof(struct Sentmod)); + pp -> tag = entmod; + pp -> Xgmentid = PPgmentid; + return((entidt)pp); +} + +stringId *Rgmentid(t) + struct Sentmod *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != entmod) + fprintf(stderr,"gmentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmentid); +} diff --git a/ghc/compiler/yaccParser/entidt.h b/ghc/compiler/yaccParser/entidt.h new file mode 100644 index 0000000..e376a72 --- /dev/null +++ b/ghc/compiler/yaccParser/entidt.h @@ -0,0 +1,198 @@ +#ifndef entidt_defined +#define entidt_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + entid, + enttype, + enttypeall, + enttypecons, + entclass, + entmod +} Tentidt; + +typedef struct { Tentidt tag; } *entidt; + +#ifdef __GNUC__ +extern __inline__ Tentidt tentidt(entidt t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tentidt tentidt PROTO((entidt)); +#endif /* ! __GNUC__ */ + +struct Sentid { + Tentidt tag; + stringId Xgentid; +}; + +struct Senttype { + Tentidt tag; + stringId Xgitentid; +}; + +struct Senttypeall { + Tentidt tag; + stringId Xgatentid; +}; + +struct Senttypecons { + Tentidt tag; + stringId Xgctentid; + list Xgctentcons; +}; + +struct Sentclass { + Tentidt tag; + stringId Xgcentid; + list Xgcentops; +}; + +struct Sentmod { + Tentidt tag; + stringId Xgmentid; +}; + +extern entidt mkentid PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgentid(struct Sentid *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != entid) + fprintf(stderr,"gentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgentid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgentid PROTO((struct Sentid *)); +#endif /* ! __GNUC__ */ + +#define gentid(xyzxyz) (*Rgentid((struct Sentid *) (xyzxyz))) + +extern entidt mkenttype PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgitentid(struct Senttype *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttype) + fprintf(stderr,"gitentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgitentid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgitentid PROTO((struct Senttype *)); +#endif /* ! __GNUC__ */ + +#define gitentid(xyzxyz) (*Rgitentid((struct Senttype *) (xyzxyz))) + +extern entidt mkenttypeall PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgatentid(struct Senttypeall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttypeall) + fprintf(stderr,"gatentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgatentid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgatentid PROTO((struct Senttypeall *)); +#endif /* ! __GNUC__ */ + +#define gatentid(xyzxyz) (*Rgatentid((struct Senttypeall *) (xyzxyz))) + +extern entidt mkenttypecons PROTO((stringId, list)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgctentid(struct Senttypecons *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttypecons) + fprintf(stderr,"gctentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgctentid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgctentid PROTO((struct Senttypecons *)); +#endif /* ! __GNUC__ */ + +#define gctentid(xyzxyz) (*Rgctentid((struct Senttypecons *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgctentcons(struct Senttypecons *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != enttypecons) + fprintf(stderr,"gctentcons: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgctentcons); +} +#else /* ! __GNUC__ */ +extern list *Rgctentcons PROTO((struct Senttypecons *)); +#endif /* ! __GNUC__ */ + +#define gctentcons(xyzxyz) (*Rgctentcons((struct Senttypecons *) (xyzxyz))) + +extern entidt mkentclass PROTO((stringId, list)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgcentid(struct Sentclass *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != entclass) + fprintf(stderr,"gcentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcentid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgcentid PROTO((struct Sentclass *)); +#endif /* ! __GNUC__ */ + +#define gcentid(xyzxyz) (*Rgcentid((struct Sentclass *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcentops(struct Sentclass *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != entclass) + fprintf(stderr,"gcentops: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcentops); +} +#else /* ! __GNUC__ */ +extern list *Rgcentops PROTO((struct Sentclass *)); +#endif /* ! __GNUC__ */ + +#define gcentops(xyzxyz) (*Rgcentops((struct Sentclass *) (xyzxyz))) + +extern entidt mkentmod PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgmentid(struct Sentmod *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != entmod) + fprintf(stderr,"gmentid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgmentid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgmentid PROTO((struct Sentmod *)); +#endif /* ! __GNUC__ */ + +#define gmentid(xyzxyz) (*Rgmentid((struct Sentmod *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/entidt.ugn b/ghc/compiler/yaccParser/entidt.ugn new file mode 100644 index 0000000..3b3c8f1 --- /dev/null +++ b/ghc/compiler/yaccParser/entidt.ugn @@ -0,0 +1,20 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_entidt where +import UgenUtil +import Util + +import U_list +%}} +type entidt; + entid : < gentid : stringId; >; + enttype : < gitentid : stringId; >; + enttypeall : < gatentid : stringId; >; + enttypecons : < gctentid : stringId; + gctentcons : list; >; + entclass : < gcentid : stringId; + gcentops : list; >; + entmod : < gmentid : stringId; >; +end; diff --git a/ghc/compiler/yaccParser/finfot.c b/ghc/compiler/yaccParser/finfot.c new file mode 100644 index 0000000..d155b2b --- /dev/null +++ b/ghc/compiler/yaccParser/finfot.c @@ -0,0 +1,55 @@ + + +#include "hspincl.h" +#include "yaccParser/finfot.h" + +Tfinfot tfinfot(t) + finfot t; +{ + return(t -> tag); +} + + +/************** nofinfo ******************/ + +finfot mknofinfo() +{ + register struct Snofinfo *pp = + (struct Snofinfo *) malloc(sizeof(struct Snofinfo)); + pp -> tag = nofinfo; + return((finfot)pp); +} + +/************** finfo ******************/ + +finfot mkfinfo(PPfi1, PPfi2) + stringId PPfi1; + stringId PPfi2; +{ + register struct Sfinfo *pp = + (struct Sfinfo *) malloc(sizeof(struct Sfinfo)); + pp -> tag = finfo; + pp -> Xfi1 = PPfi1; + pp -> Xfi2 = PPfi2; + return((finfot)pp); +} + +stringId *Rfi1(t) + struct Sfinfo *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != finfo) + fprintf(stderr,"fi1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xfi1); +} + +stringId *Rfi2(t) + struct Sfinfo *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != finfo) + fprintf(stderr,"fi2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xfi2); +} diff --git a/ghc/compiler/yaccParser/finfot.h b/ghc/compiler/yaccParser/finfot.h new file mode 100644 index 0000000..52e8af0 --- /dev/null +++ b/ghc/compiler/yaccParser/finfot.h @@ -0,0 +1,74 @@ +#ifndef finfot_defined +#define finfot_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + nofinfo, + finfo +} Tfinfot; + +typedef struct { Tfinfot tag; } *finfot; + +#ifdef __GNUC__ +extern __inline__ Tfinfot tfinfot(finfot t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tfinfot tfinfot PROTO((finfot)); +#endif /* ! __GNUC__ */ + +struct Snofinfo { + Tfinfot tag; +}; + +struct Sfinfo { + Tfinfot tag; + stringId Xfi1; + stringId Xfi2; +}; + +extern finfot mknofinfo PROTO(()); + +extern finfot mkfinfo PROTO((stringId, stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rfi1(struct Sfinfo *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != finfo) + fprintf(stderr,"fi1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xfi1); +} +#else /* ! __GNUC__ */ +extern stringId *Rfi1 PROTO((struct Sfinfo *)); +#endif /* ! __GNUC__ */ + +#define fi1(xyzxyz) (*Rfi1((struct Sfinfo *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rfi2(struct Sfinfo *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != finfo) + fprintf(stderr,"fi2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xfi2); +} +#else /* ! __GNUC__ */ +extern stringId *Rfi2 PROTO((struct Sfinfo *)); +#endif /* ! __GNUC__ */ + +#define fi2(xyzxyz) (*Rfi2((struct Sfinfo *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/finfot.ugn b/ghc/compiler/yaccParser/finfot.ugn new file mode 100644 index 0000000..9cf60eb --- /dev/null +++ b/ghc/compiler/yaccParser/finfot.ugn @@ -0,0 +1,12 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_finfot where +import UgenUtil +import Util +%}} +type finfot; + nofinfo : < >; + finfo : < fi1: stringId; fi2: stringId; >; +end; diff --git a/ghc/compiler/yaccParser/hpragma.c b/ghc/compiler/yaccParser/hpragma.c new file mode 100644 index 0000000..11a1115 --- /dev/null +++ b/ghc/compiler/yaccParser/hpragma.c @@ -0,0 +1,701 @@ + + +#include "hspincl.h" +#include "yaccParser/hpragma.h" + +Thpragma thpragma(t) + hpragma t; +{ + return(t -> tag); +} + + +/************** no_pragma ******************/ + +hpragma mkno_pragma() +{ + register struct Sno_pragma *pp = + (struct Sno_pragma *) malloc(sizeof(struct Sno_pragma)); + pp -> tag = no_pragma; + return((hpragma)pp); +} + +/************** idata_pragma ******************/ + +hpragma mkidata_pragma(PPgprag_data_constrs, PPgprag_data_specs) + list PPgprag_data_constrs; + list PPgprag_data_specs; +{ + register struct Sidata_pragma *pp = + (struct Sidata_pragma *) malloc(sizeof(struct Sidata_pragma)); + pp -> tag = idata_pragma; + pp -> Xgprag_data_constrs = PPgprag_data_constrs; + pp -> Xgprag_data_specs = PPgprag_data_specs; + return((hpragma)pp); +} + +list *Rgprag_data_constrs(t) + struct Sidata_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != idata_pragma) + fprintf(stderr,"gprag_data_constrs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_data_constrs); +} + +list *Rgprag_data_specs(t) + struct Sidata_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != idata_pragma) + fprintf(stderr,"gprag_data_specs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_data_specs); +} + +/************** itype_pragma ******************/ + +hpragma mkitype_pragma() +{ + register struct Sitype_pragma *pp = + (struct Sitype_pragma *) malloc(sizeof(struct Sitype_pragma)); + pp -> tag = itype_pragma; + return((hpragma)pp); +} + +/************** iclas_pragma ******************/ + +hpragma mkiclas_pragma(PPgprag_clas) + list PPgprag_clas; +{ + register struct Siclas_pragma *pp = + (struct Siclas_pragma *) malloc(sizeof(struct Siclas_pragma)); + pp -> tag = iclas_pragma; + pp -> Xgprag_clas = PPgprag_clas; + return((hpragma)pp); +} + +list *Rgprag_clas(t) + struct Siclas_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iclas_pragma) + fprintf(stderr,"gprag_clas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_clas); +} + +/************** iclasop_pragma ******************/ + +hpragma mkiclasop_pragma(PPgprag_dsel, PPgprag_defm) + hpragma PPgprag_dsel; + hpragma PPgprag_defm; +{ + register struct Siclasop_pragma *pp = + (struct Siclasop_pragma *) malloc(sizeof(struct Siclasop_pragma)); + pp -> tag = iclasop_pragma; + pp -> Xgprag_dsel = PPgprag_dsel; + pp -> Xgprag_defm = PPgprag_defm; + return((hpragma)pp); +} + +hpragma *Rgprag_dsel(t) + struct Siclasop_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iclasop_pragma) + fprintf(stderr,"gprag_dsel: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dsel); +} + +hpragma *Rgprag_defm(t) + struct Siclasop_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iclasop_pragma) + fprintf(stderr,"gprag_defm: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_defm); +} + +/************** iinst_simpl_pragma ******************/ + +hpragma mkiinst_simpl_pragma(PPgprag_imod_simpl, PPgprag_dfun_simpl) + stringId PPgprag_imod_simpl; + hpragma PPgprag_dfun_simpl; +{ + register struct Siinst_simpl_pragma *pp = + (struct Siinst_simpl_pragma *) malloc(sizeof(struct Siinst_simpl_pragma)); + pp -> tag = iinst_simpl_pragma; + pp -> Xgprag_imod_simpl = PPgprag_imod_simpl; + pp -> Xgprag_dfun_simpl = PPgprag_dfun_simpl; + return((hpragma)pp); +} + +stringId *Rgprag_imod_simpl(t) + struct Siinst_simpl_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_simpl_pragma) + fprintf(stderr,"gprag_imod_simpl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_imod_simpl); +} + +hpragma *Rgprag_dfun_simpl(t) + struct Siinst_simpl_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_simpl_pragma) + fprintf(stderr,"gprag_dfun_simpl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dfun_simpl); +} + +/************** iinst_const_pragma ******************/ + +hpragma mkiinst_const_pragma(PPgprag_imod_const, PPgprag_dfun_const, PPgprag_constms) + stringId PPgprag_imod_const; + hpragma PPgprag_dfun_const; + list PPgprag_constms; +{ + register struct Siinst_const_pragma *pp = + (struct Siinst_const_pragma *) malloc(sizeof(struct Siinst_const_pragma)); + pp -> tag = iinst_const_pragma; + pp -> Xgprag_imod_const = PPgprag_imod_const; + pp -> Xgprag_dfun_const = PPgprag_dfun_const; + pp -> Xgprag_constms = PPgprag_constms; + return((hpragma)pp); +} + +stringId *Rgprag_imod_const(t) + struct Siinst_const_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_const_pragma) + fprintf(stderr,"gprag_imod_const: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_imod_const); +} + +hpragma *Rgprag_dfun_const(t) + struct Siinst_const_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_const_pragma) + fprintf(stderr,"gprag_dfun_const: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dfun_const); +} + +list *Rgprag_constms(t) + struct Siinst_const_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_const_pragma) + fprintf(stderr,"gprag_constms: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_constms); +} + +/************** iinst_spec_pragma ******************/ + +hpragma mkiinst_spec_pragma(PPgprag_imod_spec, PPgprag_dfun_spec, PPgprag_inst_specs) + stringId PPgprag_imod_spec; + hpragma PPgprag_dfun_spec; + list PPgprag_inst_specs; +{ + register struct Siinst_spec_pragma *pp = + (struct Siinst_spec_pragma *) malloc(sizeof(struct Siinst_spec_pragma)); + pp -> tag = iinst_spec_pragma; + pp -> Xgprag_imod_spec = PPgprag_imod_spec; + pp -> Xgprag_dfun_spec = PPgprag_dfun_spec; + pp -> Xgprag_inst_specs = PPgprag_inst_specs; + return((hpragma)pp); +} + +stringId *Rgprag_imod_spec(t) + struct Siinst_spec_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_spec_pragma) + fprintf(stderr,"gprag_imod_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_imod_spec); +} + +hpragma *Rgprag_dfun_spec(t) + struct Siinst_spec_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_spec_pragma) + fprintf(stderr,"gprag_dfun_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dfun_spec); +} + +list *Rgprag_inst_specs(t) + struct Siinst_spec_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_spec_pragma) + fprintf(stderr,"gprag_inst_specs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_specs); +} + +/************** igen_pragma ******************/ + +hpragma mkigen_pragma(PPgprag_arity, PPgprag_update, PPgprag_deforest, PPgprag_strictness, PPgprag_unfolding, PPgprag_specs) + hpragma PPgprag_arity; + hpragma PPgprag_update; + hpragma PPgprag_deforest; + hpragma PPgprag_strictness; + hpragma PPgprag_unfolding; + list PPgprag_specs; +{ + register struct Sigen_pragma *pp = + (struct Sigen_pragma *) malloc(sizeof(struct Sigen_pragma)); + pp -> tag = igen_pragma; + pp -> Xgprag_arity = PPgprag_arity; + pp -> Xgprag_update = PPgprag_update; + pp -> Xgprag_deforest = PPgprag_deforest; + pp -> Xgprag_strictness = PPgprag_strictness; + pp -> Xgprag_unfolding = PPgprag_unfolding; + pp -> Xgprag_specs = PPgprag_specs; + return((hpragma)pp); +} + +hpragma *Rgprag_arity(t) + struct Sigen_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_arity: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_arity); +} + +hpragma *Rgprag_update(t) + struct Sigen_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_update: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_update); +} + +hpragma *Rgprag_deforest(t) + struct Sigen_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_deforest: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_deforest); +} + +hpragma *Rgprag_strictness(t) + struct Sigen_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_strictness: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_strictness); +} + +hpragma *Rgprag_unfolding(t) + struct Sigen_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_unfolding: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfolding); +} + +list *Rgprag_specs(t) + struct Sigen_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_specs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_specs); +} + +/************** iarity_pragma ******************/ + +hpragma mkiarity_pragma(PPgprag_arity_val) + numId PPgprag_arity_val; +{ + register struct Siarity_pragma *pp = + (struct Siarity_pragma *) malloc(sizeof(struct Siarity_pragma)); + pp -> tag = iarity_pragma; + pp -> Xgprag_arity_val = PPgprag_arity_val; + return((hpragma)pp); +} + +numId *Rgprag_arity_val(t) + struct Siarity_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iarity_pragma) + fprintf(stderr,"gprag_arity_val: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_arity_val); +} + +/************** iupdate_pragma ******************/ + +hpragma mkiupdate_pragma(PPgprag_update_val) + stringId PPgprag_update_val; +{ + register struct Siupdate_pragma *pp = + (struct Siupdate_pragma *) malloc(sizeof(struct Siupdate_pragma)); + pp -> tag = iupdate_pragma; + pp -> Xgprag_update_val = PPgprag_update_val; + return((hpragma)pp); +} + +stringId *Rgprag_update_val(t) + struct Siupdate_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iupdate_pragma) + fprintf(stderr,"gprag_update_val: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_update_val); +} + +/************** ideforest_pragma ******************/ + +hpragma mkideforest_pragma() +{ + register struct Sideforest_pragma *pp = + (struct Sideforest_pragma *) malloc(sizeof(struct Sideforest_pragma)); + pp -> tag = ideforest_pragma; + return((hpragma)pp); +} + +/************** istrictness_pragma ******************/ + +hpragma mkistrictness_pragma(PPgprag_strict_spec, PPgprag_strict_wrkr) + hstring PPgprag_strict_spec; + hpragma PPgprag_strict_wrkr; +{ + register struct Sistrictness_pragma *pp = + (struct Sistrictness_pragma *) malloc(sizeof(struct Sistrictness_pragma)); + pp -> tag = istrictness_pragma; + pp -> Xgprag_strict_spec = PPgprag_strict_spec; + pp -> Xgprag_strict_wrkr = PPgprag_strict_wrkr; + return((hpragma)pp); +} + +hstring *Rgprag_strict_spec(t) + struct Sistrictness_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != istrictness_pragma) + fprintf(stderr,"gprag_strict_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_strict_spec); +} + +hpragma *Rgprag_strict_wrkr(t) + struct Sistrictness_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != istrictness_pragma) + fprintf(stderr,"gprag_strict_wrkr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_strict_wrkr); +} + +/************** imagic_unfolding_pragma ******************/ + +hpragma mkimagic_unfolding_pragma(PPgprag_magic_str) + stringId PPgprag_magic_str; +{ + register struct Simagic_unfolding_pragma *pp = + (struct Simagic_unfolding_pragma *) malloc(sizeof(struct Simagic_unfolding_pragma)); + pp -> tag = imagic_unfolding_pragma; + pp -> Xgprag_magic_str = PPgprag_magic_str; + return((hpragma)pp); +} + +stringId *Rgprag_magic_str(t) + struct Simagic_unfolding_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != imagic_unfolding_pragma) + fprintf(stderr,"gprag_magic_str: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_magic_str); +} + +/************** iunfolding_pragma ******************/ + +hpragma mkiunfolding_pragma(PPgprag_unfold_guide, PPgprag_unfold_core) + hpragma PPgprag_unfold_guide; + coresyn PPgprag_unfold_core; +{ + register struct Siunfolding_pragma *pp = + (struct Siunfolding_pragma *) malloc(sizeof(struct Siunfolding_pragma)); + pp -> tag = iunfolding_pragma; + pp -> Xgprag_unfold_guide = PPgprag_unfold_guide; + pp -> Xgprag_unfold_core = PPgprag_unfold_core; + return((hpragma)pp); +} + +hpragma *Rgprag_unfold_guide(t) + struct Siunfolding_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfolding_pragma) + fprintf(stderr,"gprag_unfold_guide: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_guide); +} + +coresyn *Rgprag_unfold_core(t) + struct Siunfolding_pragma *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfolding_pragma) + fprintf(stderr,"gprag_unfold_core: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_core); +} + +/************** iunfold_always ******************/ + +hpragma mkiunfold_always() +{ + register struct Siunfold_always *pp = + (struct Siunfold_always *) malloc(sizeof(struct Siunfold_always)); + pp -> tag = iunfold_always; + return((hpragma)pp); +} + +/************** iunfold_if_args ******************/ + +hpragma mkiunfold_if_args(PPgprag_unfold_if_t_args, PPgprag_unfold_if_v_args, PPgprag_unfold_if_con_args, PPgprag_unfold_if_size) + numId PPgprag_unfold_if_t_args; + numId PPgprag_unfold_if_v_args; + stringId PPgprag_unfold_if_con_args; + numId PPgprag_unfold_if_size; +{ + register struct Siunfold_if_args *pp = + (struct Siunfold_if_args *) malloc(sizeof(struct Siunfold_if_args)); + pp -> tag = iunfold_if_args; + pp -> Xgprag_unfold_if_t_args = PPgprag_unfold_if_t_args; + pp -> Xgprag_unfold_if_v_args = PPgprag_unfold_if_v_args; + pp -> Xgprag_unfold_if_con_args = PPgprag_unfold_if_con_args; + pp -> Xgprag_unfold_if_size = PPgprag_unfold_if_size; + return((hpragma)pp); +} + +numId *Rgprag_unfold_if_t_args(t) + struct Siunfold_if_args *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_t_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_t_args); +} + +numId *Rgprag_unfold_if_v_args(t) + struct Siunfold_if_args *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_v_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_v_args); +} + +stringId *Rgprag_unfold_if_con_args(t) + struct Siunfold_if_args *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_con_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_con_args); +} + +numId *Rgprag_unfold_if_size(t) + struct Siunfold_if_args *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_size: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_size); +} + +/************** iname_pragma_pr ******************/ + +hpragma mkiname_pragma_pr(PPgprag_name_pr1, PPgprag_name_pr2) + unkId PPgprag_name_pr1; + hpragma PPgprag_name_pr2; +{ + register struct Siname_pragma_pr *pp = + (struct Siname_pragma_pr *) malloc(sizeof(struct Siname_pragma_pr)); + pp -> tag = iname_pragma_pr; + pp -> Xgprag_name_pr1 = PPgprag_name_pr1; + pp -> Xgprag_name_pr2 = PPgprag_name_pr2; + return((hpragma)pp); +} + +unkId *Rgprag_name_pr1(t) + struct Siname_pragma_pr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iname_pragma_pr) + fprintf(stderr,"gprag_name_pr1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_name_pr1); +} + +hpragma *Rgprag_name_pr2(t) + struct Siname_pragma_pr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iname_pragma_pr) + fprintf(stderr,"gprag_name_pr2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_name_pr2); +} + +/************** itype_pragma_pr ******************/ + +hpragma mkitype_pragma_pr(PPgprag_type_pr1, PPgprag_type_pr2, PPgprag_type_pr3) + list PPgprag_type_pr1; + numId PPgprag_type_pr2; + hpragma PPgprag_type_pr3; +{ + register struct Sitype_pragma_pr *pp = + (struct Sitype_pragma_pr *) malloc(sizeof(struct Sitype_pragma_pr)); + pp -> tag = itype_pragma_pr; + pp -> Xgprag_type_pr1 = PPgprag_type_pr1; + pp -> Xgprag_type_pr2 = PPgprag_type_pr2; + pp -> Xgprag_type_pr3 = PPgprag_type_pr3; + return((hpragma)pp); +} + +list *Rgprag_type_pr1(t) + struct Sitype_pragma_pr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != itype_pragma_pr) + fprintf(stderr,"gprag_type_pr1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_type_pr1); +} + +numId *Rgprag_type_pr2(t) + struct Sitype_pragma_pr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != itype_pragma_pr) + fprintf(stderr,"gprag_type_pr2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_type_pr2); +} + +hpragma *Rgprag_type_pr3(t) + struct Sitype_pragma_pr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != itype_pragma_pr) + fprintf(stderr,"gprag_type_pr3: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_type_pr3); +} + +/************** iinst_pragma_3s ******************/ + +hpragma mkiinst_pragma_3s(PPgprag_inst_pt1, PPgprag_inst_pt2, PPgprag_inst_pt3, PPgprag_inst_pt4) + list PPgprag_inst_pt1; + numId PPgprag_inst_pt2; + hpragma PPgprag_inst_pt3; + list PPgprag_inst_pt4; +{ + register struct Siinst_pragma_3s *pp = + (struct Siinst_pragma_3s *) malloc(sizeof(struct Siinst_pragma_3s)); + pp -> tag = iinst_pragma_3s; + pp -> Xgprag_inst_pt1 = PPgprag_inst_pt1; + pp -> Xgprag_inst_pt2 = PPgprag_inst_pt2; + pp -> Xgprag_inst_pt3 = PPgprag_inst_pt3; + pp -> Xgprag_inst_pt4 = PPgprag_inst_pt4; + return((hpragma)pp); +} + +list *Rgprag_inst_pt1(t) + struct Siinst_pragma_3s *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt1); +} + +numId *Rgprag_inst_pt2(t) + struct Siinst_pragma_3s *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt2); +} + +hpragma *Rgprag_inst_pt3(t) + struct Siinst_pragma_3s *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt3: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt3); +} + +list *Rgprag_inst_pt4(t) + struct Siinst_pragma_3s *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt4: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt4); +} + +/************** idata_pragma_4s ******************/ + +hpragma mkidata_pragma_4s(PPgprag_data_spec) + list PPgprag_data_spec; +{ + register struct Sidata_pragma_4s *pp = + (struct Sidata_pragma_4s *) malloc(sizeof(struct Sidata_pragma_4s)); + pp -> tag = idata_pragma_4s; + pp -> Xgprag_data_spec = PPgprag_data_spec; + return((hpragma)pp); +} + +list *Rgprag_data_spec(t) + struct Sidata_pragma_4s *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != idata_pragma_4s) + fprintf(stderr,"gprag_data_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_data_spec); +} diff --git a/ghc/compiler/yaccParser/hpragma.h b/ghc/compiler/yaccParser/hpragma.h new file mode 100644 index 0000000..8ba2ed5 --- /dev/null +++ b/ghc/compiler/yaccParser/hpragma.h @@ -0,0 +1,815 @@ +#ifndef hpragma_defined +#define hpragma_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + no_pragma, + idata_pragma, + itype_pragma, + iclas_pragma, + iclasop_pragma, + iinst_simpl_pragma, + iinst_const_pragma, + iinst_spec_pragma, + igen_pragma, + iarity_pragma, + iupdate_pragma, + ideforest_pragma, + istrictness_pragma, + imagic_unfolding_pragma, + iunfolding_pragma, + iunfold_always, + iunfold_if_args, + iname_pragma_pr, + itype_pragma_pr, + iinst_pragma_3s, + idata_pragma_4s +} Thpragma; + +typedef struct { Thpragma tag; } *hpragma; + +#ifdef __GNUC__ +extern __inline__ Thpragma thpragma(hpragma t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Thpragma thpragma PROTO((hpragma)); +#endif /* ! __GNUC__ */ + +struct Sno_pragma { + Thpragma tag; +}; + +struct Sidata_pragma { + Thpragma tag; + list Xgprag_data_constrs; + list Xgprag_data_specs; +}; + +struct Sitype_pragma { + Thpragma tag; +}; + +struct Siclas_pragma { + Thpragma tag; + list Xgprag_clas; +}; + +struct Siclasop_pragma { + Thpragma tag; + hpragma Xgprag_dsel; + hpragma Xgprag_defm; +}; + +struct Siinst_simpl_pragma { + Thpragma tag; + stringId Xgprag_imod_simpl; + hpragma Xgprag_dfun_simpl; +}; + +struct Siinst_const_pragma { + Thpragma tag; + stringId Xgprag_imod_const; + hpragma Xgprag_dfun_const; + list Xgprag_constms; +}; + +struct Siinst_spec_pragma { + Thpragma tag; + stringId Xgprag_imod_spec; + hpragma Xgprag_dfun_spec; + list Xgprag_inst_specs; +}; + +struct Sigen_pragma { + Thpragma tag; + hpragma Xgprag_arity; + hpragma Xgprag_update; + hpragma Xgprag_deforest; + hpragma Xgprag_strictness; + hpragma Xgprag_unfolding; + list Xgprag_specs; +}; + +struct Siarity_pragma { + Thpragma tag; + numId Xgprag_arity_val; +}; + +struct Siupdate_pragma { + Thpragma tag; + stringId Xgprag_update_val; +}; + +struct Sideforest_pragma { + Thpragma tag; +}; + +struct Sistrictness_pragma { + Thpragma tag; + hstring Xgprag_strict_spec; + hpragma Xgprag_strict_wrkr; +}; + +struct Simagic_unfolding_pragma { + Thpragma tag; + stringId Xgprag_magic_str; +}; + +struct Siunfolding_pragma { + Thpragma tag; + hpragma Xgprag_unfold_guide; + coresyn Xgprag_unfold_core; +}; + +struct Siunfold_always { + Thpragma tag; +}; + +struct Siunfold_if_args { + Thpragma tag; + numId Xgprag_unfold_if_t_args; + numId Xgprag_unfold_if_v_args; + stringId Xgprag_unfold_if_con_args; + numId Xgprag_unfold_if_size; +}; + +struct Siname_pragma_pr { + Thpragma tag; + unkId Xgprag_name_pr1; + hpragma Xgprag_name_pr2; +}; + +struct Sitype_pragma_pr { + Thpragma tag; + list Xgprag_type_pr1; + numId Xgprag_type_pr2; + hpragma Xgprag_type_pr3; +}; + +struct Siinst_pragma_3s { + Thpragma tag; + list Xgprag_inst_pt1; + numId Xgprag_inst_pt2; + hpragma Xgprag_inst_pt3; + list Xgprag_inst_pt4; +}; + +struct Sidata_pragma_4s { + Thpragma tag; + list Xgprag_data_spec; +}; + +extern hpragma mkno_pragma PROTO(()); + +extern hpragma mkidata_pragma PROTO((list, list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_data_constrs(struct Sidata_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != idata_pragma) + fprintf(stderr,"gprag_data_constrs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_data_constrs); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_data_constrs PROTO((struct Sidata_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_data_constrs(xyzxyz) (*Rgprag_data_constrs((struct Sidata_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_data_specs(struct Sidata_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != idata_pragma) + fprintf(stderr,"gprag_data_specs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_data_specs); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_data_specs PROTO((struct Sidata_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_data_specs(xyzxyz) (*Rgprag_data_specs((struct Sidata_pragma *) (xyzxyz))) + +extern hpragma mkitype_pragma PROTO(()); + +extern hpragma mkiclas_pragma PROTO((list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_clas(struct Siclas_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iclas_pragma) + fprintf(stderr,"gprag_clas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_clas); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_clas PROTO((struct Siclas_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_clas(xyzxyz) (*Rgprag_clas((struct Siclas_pragma *) (xyzxyz))) + +extern hpragma mkiclasop_pragma PROTO((hpragma, hpragma)); +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_dsel(struct Siclasop_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iclasop_pragma) + fprintf(stderr,"gprag_dsel: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dsel); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_dsel PROTO((struct Siclasop_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_dsel(xyzxyz) (*Rgprag_dsel((struct Siclasop_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_defm(struct Siclasop_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iclasop_pragma) + fprintf(stderr,"gprag_defm: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_defm); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_defm PROTO((struct Siclasop_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_defm(xyzxyz) (*Rgprag_defm((struct Siclasop_pragma *) (xyzxyz))) + +extern hpragma mkiinst_simpl_pragma PROTO((stringId, hpragma)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgprag_imod_simpl(struct Siinst_simpl_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_simpl_pragma) + fprintf(stderr,"gprag_imod_simpl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_imod_simpl); +} +#else /* ! __GNUC__ */ +extern stringId *Rgprag_imod_simpl PROTO((struct Siinst_simpl_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_imod_simpl(xyzxyz) (*Rgprag_imod_simpl((struct Siinst_simpl_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_dfun_simpl(struct Siinst_simpl_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_simpl_pragma) + fprintf(stderr,"gprag_dfun_simpl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dfun_simpl); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_dfun_simpl PROTO((struct Siinst_simpl_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_dfun_simpl(xyzxyz) (*Rgprag_dfun_simpl((struct Siinst_simpl_pragma *) (xyzxyz))) + +extern hpragma mkiinst_const_pragma PROTO((stringId, hpragma, list)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgprag_imod_const(struct Siinst_const_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_const_pragma) + fprintf(stderr,"gprag_imod_const: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_imod_const); +} +#else /* ! __GNUC__ */ +extern stringId *Rgprag_imod_const PROTO((struct Siinst_const_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_imod_const(xyzxyz) (*Rgprag_imod_const((struct Siinst_const_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_dfun_const(struct Siinst_const_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_const_pragma) + fprintf(stderr,"gprag_dfun_const: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dfun_const); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_dfun_const PROTO((struct Siinst_const_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_dfun_const(xyzxyz) (*Rgprag_dfun_const((struct Siinst_const_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_constms(struct Siinst_const_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_const_pragma) + fprintf(stderr,"gprag_constms: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_constms); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_constms PROTO((struct Siinst_const_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_constms(xyzxyz) (*Rgprag_constms((struct Siinst_const_pragma *) (xyzxyz))) + +extern hpragma mkiinst_spec_pragma PROTO((stringId, hpragma, list)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgprag_imod_spec(struct Siinst_spec_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_spec_pragma) + fprintf(stderr,"gprag_imod_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_imod_spec); +} +#else /* ! __GNUC__ */ +extern stringId *Rgprag_imod_spec PROTO((struct Siinst_spec_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_imod_spec(xyzxyz) (*Rgprag_imod_spec((struct Siinst_spec_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_dfun_spec(struct Siinst_spec_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_spec_pragma) + fprintf(stderr,"gprag_dfun_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_dfun_spec); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_dfun_spec PROTO((struct Siinst_spec_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_dfun_spec(xyzxyz) (*Rgprag_dfun_spec((struct Siinst_spec_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_inst_specs(struct Siinst_spec_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_spec_pragma) + fprintf(stderr,"gprag_inst_specs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_specs); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_inst_specs PROTO((struct Siinst_spec_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_inst_specs(xyzxyz) (*Rgprag_inst_specs((struct Siinst_spec_pragma *) (xyzxyz))) + +extern hpragma mkigen_pragma PROTO((hpragma, hpragma, hpragma, hpragma, hpragma, list)); +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_arity(struct Sigen_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_arity: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_arity); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_arity PROTO((struct Sigen_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_arity(xyzxyz) (*Rgprag_arity((struct Sigen_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_update(struct Sigen_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_update: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_update); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_update PROTO((struct Sigen_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_update(xyzxyz) (*Rgprag_update((struct Sigen_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_deforest(struct Sigen_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_deforest: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_deforest); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_deforest PROTO((struct Sigen_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_deforest(xyzxyz) (*Rgprag_deforest((struct Sigen_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_strictness(struct Sigen_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_strictness: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_strictness); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_strictness PROTO((struct Sigen_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_strictness(xyzxyz) (*Rgprag_strictness((struct Sigen_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_unfolding(struct Sigen_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_unfolding: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfolding); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_unfolding PROTO((struct Sigen_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfolding(xyzxyz) (*Rgprag_unfolding((struct Sigen_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_specs(struct Sigen_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != igen_pragma) + fprintf(stderr,"gprag_specs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_specs); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_specs PROTO((struct Sigen_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_specs(xyzxyz) (*Rgprag_specs((struct Sigen_pragma *) (xyzxyz))) + +extern hpragma mkiarity_pragma PROTO((numId)); +#ifdef __GNUC__ + +extern __inline__ numId *Rgprag_arity_val(struct Siarity_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iarity_pragma) + fprintf(stderr,"gprag_arity_val: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_arity_val); +} +#else /* ! __GNUC__ */ +extern numId *Rgprag_arity_val PROTO((struct Siarity_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_arity_val(xyzxyz) (*Rgprag_arity_val((struct Siarity_pragma *) (xyzxyz))) + +extern hpragma mkiupdate_pragma PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgprag_update_val(struct Siupdate_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iupdate_pragma) + fprintf(stderr,"gprag_update_val: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_update_val); +} +#else /* ! __GNUC__ */ +extern stringId *Rgprag_update_val PROTO((struct Siupdate_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_update_val(xyzxyz) (*Rgprag_update_val((struct Siupdate_pragma *) (xyzxyz))) + +extern hpragma mkideforest_pragma PROTO(()); + +extern hpragma mkistrictness_pragma PROTO((hstring, hpragma)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgprag_strict_spec(struct Sistrictness_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != istrictness_pragma) + fprintf(stderr,"gprag_strict_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_strict_spec); +} +#else /* ! __GNUC__ */ +extern hstring *Rgprag_strict_spec PROTO((struct Sistrictness_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_strict_spec(xyzxyz) (*Rgprag_strict_spec((struct Sistrictness_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_strict_wrkr(struct Sistrictness_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != istrictness_pragma) + fprintf(stderr,"gprag_strict_wrkr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_strict_wrkr); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_strict_wrkr PROTO((struct Sistrictness_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_strict_wrkr(xyzxyz) (*Rgprag_strict_wrkr((struct Sistrictness_pragma *) (xyzxyz))) + +extern hpragma mkimagic_unfolding_pragma PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgprag_magic_str(struct Simagic_unfolding_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != imagic_unfolding_pragma) + fprintf(stderr,"gprag_magic_str: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_magic_str); +} +#else /* ! __GNUC__ */ +extern stringId *Rgprag_magic_str PROTO((struct Simagic_unfolding_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_magic_str(xyzxyz) (*Rgprag_magic_str((struct Simagic_unfolding_pragma *) (xyzxyz))) + +extern hpragma mkiunfolding_pragma PROTO((hpragma, coresyn)); +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_unfold_guide(struct Siunfolding_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfolding_pragma) + fprintf(stderr,"gprag_unfold_guide: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_guide); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_unfold_guide PROTO((struct Siunfolding_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfold_guide(xyzxyz) (*Rgprag_unfold_guide((struct Siunfolding_pragma *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ coresyn *Rgprag_unfold_core(struct Siunfolding_pragma *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfolding_pragma) + fprintf(stderr,"gprag_unfold_core: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_core); +} +#else /* ! __GNUC__ */ +extern coresyn *Rgprag_unfold_core PROTO((struct Siunfolding_pragma *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfold_core(xyzxyz) (*Rgprag_unfold_core((struct Siunfolding_pragma *) (xyzxyz))) + +extern hpragma mkiunfold_always PROTO(()); + +extern hpragma mkiunfold_if_args PROTO((numId, numId, stringId, numId)); +#ifdef __GNUC__ + +extern __inline__ numId *Rgprag_unfold_if_t_args(struct Siunfold_if_args *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_t_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_t_args); +} +#else /* ! __GNUC__ */ +extern numId *Rgprag_unfold_if_t_args PROTO((struct Siunfold_if_args *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfold_if_t_args(xyzxyz) (*Rgprag_unfold_if_t_args((struct Siunfold_if_args *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ numId *Rgprag_unfold_if_v_args(struct Siunfold_if_args *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_v_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_v_args); +} +#else /* ! __GNUC__ */ +extern numId *Rgprag_unfold_if_v_args PROTO((struct Siunfold_if_args *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfold_if_v_args(xyzxyz) (*Rgprag_unfold_if_v_args((struct Siunfold_if_args *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgprag_unfold_if_con_args(struct Siunfold_if_args *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_con_args: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_con_args); +} +#else /* ! __GNUC__ */ +extern stringId *Rgprag_unfold_if_con_args PROTO((struct Siunfold_if_args *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfold_if_con_args(xyzxyz) (*Rgprag_unfold_if_con_args((struct Siunfold_if_args *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ numId *Rgprag_unfold_if_size(struct Siunfold_if_args *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iunfold_if_args) + fprintf(stderr,"gprag_unfold_if_size: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_unfold_if_size); +} +#else /* ! __GNUC__ */ +extern numId *Rgprag_unfold_if_size PROTO((struct Siunfold_if_args *)); +#endif /* ! __GNUC__ */ + +#define gprag_unfold_if_size(xyzxyz) (*Rgprag_unfold_if_size((struct Siunfold_if_args *) (xyzxyz))) + +extern hpragma mkiname_pragma_pr PROTO((unkId, hpragma)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgprag_name_pr1(struct Siname_pragma_pr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iname_pragma_pr) + fprintf(stderr,"gprag_name_pr1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_name_pr1); +} +#else /* ! __GNUC__ */ +extern unkId *Rgprag_name_pr1 PROTO((struct Siname_pragma_pr *)); +#endif /* ! __GNUC__ */ + +#define gprag_name_pr1(xyzxyz) (*Rgprag_name_pr1((struct Siname_pragma_pr *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_name_pr2(struct Siname_pragma_pr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iname_pragma_pr) + fprintf(stderr,"gprag_name_pr2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_name_pr2); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_name_pr2 PROTO((struct Siname_pragma_pr *)); +#endif /* ! __GNUC__ */ + +#define gprag_name_pr2(xyzxyz) (*Rgprag_name_pr2((struct Siname_pragma_pr *) (xyzxyz))) + +extern hpragma mkitype_pragma_pr PROTO((list, numId, hpragma)); +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_type_pr1(struct Sitype_pragma_pr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != itype_pragma_pr) + fprintf(stderr,"gprag_type_pr1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_type_pr1); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_type_pr1 PROTO((struct Sitype_pragma_pr *)); +#endif /* ! __GNUC__ */ + +#define gprag_type_pr1(xyzxyz) (*Rgprag_type_pr1((struct Sitype_pragma_pr *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ numId *Rgprag_type_pr2(struct Sitype_pragma_pr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != itype_pragma_pr) + fprintf(stderr,"gprag_type_pr2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_type_pr2); +} +#else /* ! __GNUC__ */ +extern numId *Rgprag_type_pr2 PROTO((struct Sitype_pragma_pr *)); +#endif /* ! __GNUC__ */ + +#define gprag_type_pr2(xyzxyz) (*Rgprag_type_pr2((struct Sitype_pragma_pr *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_type_pr3(struct Sitype_pragma_pr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != itype_pragma_pr) + fprintf(stderr,"gprag_type_pr3: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_type_pr3); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_type_pr3 PROTO((struct Sitype_pragma_pr *)); +#endif /* ! __GNUC__ */ + +#define gprag_type_pr3(xyzxyz) (*Rgprag_type_pr3((struct Sitype_pragma_pr *) (xyzxyz))) + +extern hpragma mkiinst_pragma_3s PROTO((list, numId, hpragma, list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_inst_pt1(struct Siinst_pragma_3s *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt1: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt1); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_inst_pt1 PROTO((struct Siinst_pragma_3s *)); +#endif /* ! __GNUC__ */ + +#define gprag_inst_pt1(xyzxyz) (*Rgprag_inst_pt1((struct Siinst_pragma_3s *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ numId *Rgprag_inst_pt2(struct Siinst_pragma_3s *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt2: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt2); +} +#else /* ! __GNUC__ */ +extern numId *Rgprag_inst_pt2 PROTO((struct Siinst_pragma_3s *)); +#endif /* ! __GNUC__ */ + +#define gprag_inst_pt2(xyzxyz) (*Rgprag_inst_pt2((struct Siinst_pragma_3s *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ hpragma *Rgprag_inst_pt3(struct Siinst_pragma_3s *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt3: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt3); +} +#else /* ! __GNUC__ */ +extern hpragma *Rgprag_inst_pt3 PROTO((struct Siinst_pragma_3s *)); +#endif /* ! __GNUC__ */ + +#define gprag_inst_pt3(xyzxyz) (*Rgprag_inst_pt3((struct Siinst_pragma_3s *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_inst_pt4(struct Siinst_pragma_3s *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != iinst_pragma_3s) + fprintf(stderr,"gprag_inst_pt4: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_inst_pt4); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_inst_pt4 PROTO((struct Siinst_pragma_3s *)); +#endif /* ! __GNUC__ */ + +#define gprag_inst_pt4(xyzxyz) (*Rgprag_inst_pt4((struct Siinst_pragma_3s *) (xyzxyz))) + +extern hpragma mkidata_pragma_4s PROTO((list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgprag_data_spec(struct Sidata_pragma_4s *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != idata_pragma_4s) + fprintf(stderr,"gprag_data_spec: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgprag_data_spec); +} +#else /* ! __GNUC__ */ +extern list *Rgprag_data_spec PROTO((struct Sidata_pragma_4s *)); +#endif /* ! __GNUC__ */ + +#define gprag_data_spec(xyzxyz) (*Rgprag_data_spec((struct Sidata_pragma_4s *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/hpragma.ugn b/ghc/compiler/yaccParser/hpragma.ugn new file mode 100644 index 0000000..c184b43 --- /dev/null +++ b/ghc/compiler/yaccParser/hpragma.ugn @@ -0,0 +1,73 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_hpragma where +import UgenUtil +import Util + +import U_coresyn +import U_list +import U_literal ( U_literal ) -- ditto +import U_ttype ( U_ttype ) -- interface only +%}} +type hpragma; + no_pragma: < > ; + + idata_pragma: < gprag_data_constrs : list; /*of con decls*/ + gprag_data_specs : list; /*specialisations*/ >; + + itype_pragma: < >; + + iclas_pragma: < gprag_clas : list; /*of gen pragmas*/ >; + + iclasop_pragma: < gprag_dsel : hpragma; /* gen pragma: dict selector */ + gprag_defm : hpragma; /* gen pragma: default method */ >; + + iinst_simpl_pragma: < gprag_imod_simpl : stringId; + gprag_dfun_simpl : hpragma; /* gen pragma: of dfun */ >; + + iinst_const_pragma: < gprag_imod_const : stringId; + gprag_dfun_const : hpragma; /* gen pragma: of dfun */ + gprag_constms : list; /* (name, gen pragma) pairs */ >; + + iinst_spec_pragma: < gprag_imod_spec : stringId; + gprag_dfun_spec : hpragma; /* gen pragma: of dfun */ + gprag_inst_specs : list; /* (type, inst_pragma) pairs */ >; + + igen_pragma: < gprag_arity : hpragma; /* arity */ + gprag_update : hpragma; /* update info */ + gprag_deforest : hpragma; /* deforest info */ + gprag_strictness : hpragma; /* strictness info */ + gprag_unfolding : hpragma; /* unfolding */ + gprag_specs : list; /* (type, gen pragma) pairs */ >; + + iarity_pragma: < gprag_arity_val : numId; >; + iupdate_pragma: < gprag_update_val : stringId; >; + ideforest_pragma: < >; + istrictness_pragma: < gprag_strict_spec : hstring; + gprag_strict_wrkr : hpragma; /*about worker*/ >; + imagic_unfolding_pragma: < gprag_magic_str : stringId; >; + + iunfolding_pragma: < gprag_unfold_guide : hpragma; /* guidance */ + gprag_unfold_core : coresyn; >; + + iunfold_always: < >; + iunfold_if_args: < gprag_unfold_if_t_args : numId; + gprag_unfold_if_v_args : numId; + gprag_unfold_if_con_args : stringId; + gprag_unfold_if_size : numId; >; + + iname_pragma_pr: < gprag_name_pr1 : unkId; + gprag_name_pr2 : hpragma; >; + itype_pragma_pr: < gprag_type_pr1 : list; /* of maybe types */ + gprag_type_pr2 : numId; /* # dicts to ignore */ + gprag_type_pr3 : hpragma; >; + iinst_pragma_3s: < gprag_inst_pt1 : list; /* of maybe types */ + gprag_inst_pt2 : numId; + gprag_inst_pt3 : hpragma; + gprag_inst_pt4 : list; >; + + idata_pragma_4s: < gprag_data_spec : list; /* of maybe types */ >; + +end; diff --git a/ghc/compiler/yaccParser/hschooks.c b/ghc/compiler/yaccParser/hschooks.c new file mode 100644 index 0000000..d19f628 --- /dev/null +++ b/ghc/compiler/yaccParser/hschooks.c @@ -0,0 +1,65 @@ +/* +These routines customise the error messages +for various bits of the RTS. They are linked +in instead of the defaults. +*/ +#include + +#define W_ unsigned long int +#define I_ long int + +void +ErrorHdrHook (where) + FILE *where; +{ + fprintf(where, "\n"); /* no "Fail: " */ +} + + +void +OutOfHeapHook (request_size, heap_size) + W_ request_size; /* in bytes */ + W_ heap_size; /* in bytes */ +{ + fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H' option to increase the total heap size.\n", + request_size, + heap_size); +} + +void +StackOverflowHook (stack_size) + I_ stack_size; /* in bytes */ +{ + fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K' option to increase it.\n", stack_size); +} + +#if 0 +/* nothing to add here, really */ +void +MallocFailHook (request_size) + I_ request_size; /* in bytes */ +{ + fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size); +} +#endif /* 0 */ + +void +PatErrorHdrHook (where) + FILE *where; +{ + fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: "); +} + +void +PreTraceHook (where) + FILE *where; +{ + fprintf(where, "\n"); /* not "Trace On" */ +} + +void +PostTraceHook (where) + FILE *where; +{ + fprintf(where, "\n"); /* not "Trace Off" */ +} diff --git a/ghc/compiler/yaccParser/hsclink.c b/ghc/compiler/yaccParser/hsclink.c new file mode 100644 index 0000000..c95e22f --- /dev/null +++ b/ghc/compiler/yaccParser/hsclink.c @@ -0,0 +1,63 @@ +/* This is the "top-level" file for the *linked-into-the-compiler* parser. + See also main.c. (WDP 94/10) +*/ + +#include + +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/********************************************************************** +* * +* * +* The main program * +* * +* * +**********************************************************************/ + +extern long prog_argc; +extern char **prog_argv; + +#define MAX_HSP_ARGS 64 +long hsp_argc; +char *hsp_argv[MAX_HSP_ARGS]; /* sigh */ + +tree +hspmain() +{ + int hsp_i, prog_i; + + Lnil = mklnil(); /* The null list -- used in lsing, etc. */ + all = mklnil(); /* This should be the list of all derivable types */ + + /* copy the args we're interested in (first char: comma) + to hsp_argv; arrange to point after the comma! + */ + hsp_i = 0; + for (prog_i = 0; prog_i < prog_argc; prog_i++) { + if (prog_argv[prog_i][0] == ',') { + hsp_argv[hsp_i] = &(prog_argv[prog_i][1]); + hsp_i++; + } + } + hsp_argc = hsp_i; /* set count */ + + process_args(hsp_argc, hsp_argv); /* HACK */ + + hash_init(); + +#ifdef HSP_DEBUG + fprintf(stderr,"input_file_dir=%s\n",input_file_dir); +#endif + + yyinit(); + + if (yyparse() != 0) { + /* There was a syntax error. */ + printf("\n"); + exit(1); + } + + return(root); +} diff --git a/ghc/compiler/yaccParser/hslexer-DPH.lex b/ghc/compiler/yaccParser/hslexer-DPH.lex new file mode 100644 index 0000000..6f6946f --- /dev/null +++ b/ghc/compiler/yaccParser/hslexer-DPH.lex @@ -0,0 +1,1397 @@ +%{ +/********************************************************************** +* * +* * +* LEX grammar for Haskell. * +* ------------------------ * +* * +* (c) Copyright K. Hammond, University of Glasgow, * +* 10th. February 1989 * +* * +* Modification History * +* -------------------- * +* * +* 22/08/91 kh Initial Haskell 1.1 version. * +* 18/10/91 kh Added 'ccall'. * +* 19/11/91 kh Tidied generally. * +* 04/12/91 kh Added Int#. * +* 31/01/92 kh Haskell 1.2 version. * +* 19/03/92 Jon Hill Added Data Parallel Notation * +* 24/04/92 ps Added 'scc'. * +* 03/06/92 kh Changed Infix/Prelude Handling. * +* * +* * +* Known Problems: * +* * +* None, any more. * +* * +**********************************************************************/ + +#include "include.h" +#include "hsparser-DPH.tab.h" +#include +#include +#include "constants.h" + +char *input_filename = NULL; + +#include "utils.h" + + +/********************************************************************** +* * +* * +* Declarations * +* * +* * +**********************************************************************/ + + +extern int yylineno; +unsigned yylastlineno = 0; /* Line number of previous token */ +unsigned startlineno = 0; /* temp; used to save the line no where something starts */ +int yylastposn = 0; /* Absolute position of last token */ +int yylinestart = 0; /* Absolute position of line start */ + +static int yyposn = 0; + +/* Essential forward declarations */ + +static int readstring(), readasciiname(), readcomment(), + lookupascii(), yynewid() /* OLD:, parse_pragma()*/; +static char escval(); + +static BOOLEAN incomment = FALSE; +static unsigned commentdepth = 0; + +static BOOLEAN indenteof = FALSE; + +/* Pragmas */ +/* OLD: char *pragmatype, *pragmaid, *pragmavalue; */ + +/* Special file handling for IMPORTS */ + +static FILE *yyin_save = NULL; /* Saved File Pointer */ +static char *filename_save; /* File Name */ +static int yylineno_save = 0, /* Line Number */ + yyposn_save = 0, /* This Token */ + yylastposn_save = 0, /* Last Token */ + yyindent_save, /* Indentation */ + yylindent_save, /* Left Indentation */ + yytchar_save = 0, /* Next Input Character */ + icontexts_save = 0; /* Indent Context Level */ +static unsigned yylastlineno_save = 0; /* Line Number of Prev. token */ + +static BOOLEAN leof = FALSE; /* EOF for interfaces */ + + +extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */ +extern BOOLEAN ignoreArityPragmas; /* And various specific flavors... */ +extern BOOLEAN ignoreSpecializePragmas; +extern BOOLEAN ignoreStrictnessPragmas; +extern BOOLEAN ignoreUpdatePragmas; + + + +/********************************************************************** +* * +* * +* Layout Processing * +* * +* * +**********************************************************************/ + + +/* + The following section deals with Haskell Layout conventions + forcing insertion of ; or } as appropriate +*/ + + +static short + yyindent = 0, /* Current indentation */ + yylindent = 0, /* Indentation of the leftmost char in the current lexeme */ + yyslindent = -1, /* Indentation of the leftmost char in a string */ + yytabindent = 0, /* Indentation before a tab in case we have to backtrack */ + forgetindent = FALSE; /* Don't bother applying indentation rules */ + +static int yysttok = -1; /* Stacked Token: + -1 -- no token; + -ve -- ";" inserted before token + +ve -- "}" inserted before token + */ + +short icontexts = 0; /* Which context we're in */ + + + +/* + Table of indentations: right bit indicates whether to use + indentation rules (1 = use rules; 0 = ignore) + + partain: + push one of these "contexts" at every "case" or "where"; the right bit says + whether user supplied braces,etc., or not. pop appropriately (yyendindent). + + ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is + pushed (the "column" for "module", "interface" and EOF). The -1 from the initial + push is shown just below. + +*/ + + +static short indenttab[MAX_CONTEXTS] = { -1 }; + +#define INDENTPT (indenttab[icontexts]>>1) +#define INDENTON (indenttab[icontexts]&1) + + +yyshouldindent() +{ + return(!leof && !forgetindent && INDENTON); +} + + +/* Enter new context and set new indentation level */ +yysetindent() +{ +#ifdef DEBUG + fprintf(stderr,"yysetindent:yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",yyindent,yylindent,icontexts,INDENTPT); +#endif + + /* partain: first chk that new indent won't be less than current one; + this code doesn't make sense to me; yyindent tells the position of the _end_ + of the current token; what that has to do with indenting, I don't know. + */ + + + if(yyindent-1 <= INDENTPT) + { + if (INDENTPT == -1) + return; /* Empty input OK for Haskell 1.1 */ + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"Layout error -- indentation should be > %d cols",INDENTPT); + yyerror(errbuf); + } + } + yyentercontext((yylindent << 1) | 1); +} + + +/* Enter a new context without changing the indentation level */ + +yyincindent() +{ +#ifdef DEBUG + fprintf(stderr,"yyincindent:yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",yyindent,yylindent,icontexts,INDENTPT); +#endif + yyentercontext(indenttab[icontexts] & ~1); +} + + +/* Turn off indentation processing, usually because an explicit "{" has been seen */ + +yyindentoff() +{ + forgetindent = TRUE; +} + + +/* Enter a new layout context. */ + +yyentercontext(indent) +int indent; +{ + /* Enter new context and set indentation as specified */ + if(++icontexts >= MAX_CONTEXTS) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"'wheres' and 'cases' nested too deeply (>%d)", MAX_CONTEXTS-1); + yyerror(errbuf); + } + + forgetindent = FALSE; + indenttab[icontexts] = indent; +#ifdef DEBUG + fprintf(stderr,"yyentercontext:indent=%d,yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",indent,yyindent,yylindent,icontexts,INDENTPT); +#endif +} + + +/* Exit a layout context */ + +yyendindent() +{ + --icontexts; +#ifdef DEBUG + fprintf(stderr,"yyendindent:yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",yyindent,yylindent,icontexts,INDENTPT); +#endif +} + + + + +/* + * Return checks the indentation level and returns ;, } or the specified token. + */ + +#define RETURN(tok) return(Return(tok)) + +Return(tok) +int tok; +{ + if(yyslindent != -1) + { + yylindent = yyslindent; + yyslindent = -1; + } + else + yylindent = yyindent-yyleng; + + if (yyshouldindent()) + { + if (yylindent < INDENTPT) + { +#ifdef DEBUG + fprintf(stderr,"inserted '}' before %d (%d:%d:%d:%d)\n",tok,yylindent,yyindent,yyleng,INDENTPT); +#endif + yysttok=tok; + return(VCCURLY); + } + + else if (yylindent == INDENTPT) + { +#ifdef DEBUG + fprintf(stderr,"inserted ';' before %d (%d:%d)\n",tok,yylindent,INDENTPT); +#endif + yysttok = -tok; + return (SEMI); + } + } + yysttok = -1; + leof = FALSE; +#ifdef DEBUG + fprintf(stderr,"returning %d (%d:%d)\n",tok,yylindent,INDENTPT); +#endif + return(tok); +} + + +/********************************************************************** +* * +* * +* Input Processing for Interfaces * +* * +* * +**********************************************************************/ + + +/* setyyin(file) open file as new yyin */ +/* partain: got rid of .ext stuff */ +setyyin(file) +char *file; +{ + char fbuf[FILENAME_SIZE]; + + strcpy(fbuf,file); + + yyin_save = yyin; + + if((yyin=fopen(fbuf,"r"))==NULL) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"can't read \"%-.50s\"", fbuf); + yyerror(errbuf); + } + + yylineno_save = yylineno; + yylastlineno_save = yylastlineno; + yylineno = yylastlineno = 0; + + yylastposn_save = yylastposn; + yyposn_save = yyposn; + yyposn = yylastposn = -1; + + filename_save = xmalloc(strlen(input_filename)+1); + strcpy(filename_save,input_filename); + new_filename(fbuf); + yyindent_save = yyindent; + yylindent_save = yylindent; + yyindent = yylindent = 0; + yyentercontext(-1); /* partain: changed this from 0 */ + icontexts_save = icontexts; + yytchar_save = yytchar; +#ifdef DEBUG + fprintf(stderr,"yytchar = %c(%d)\n",yytchar,(int)yytchar); +#endif + yysptr = yysbuf; +#ifdef DEBUG + fprintf(stderr,"reading %s (%d:%d:%d)\n",input_filename,yyindent_save,yylindent_save,INDENTPT); +#endif +} + + + +/* + input() is the raw input routine used by yylex() +*/ + +#undef input /* so we can define our own versions to handle layout */ +#undef unput + + +static +input() +{ + if(yytchar==10) + yyindent = 0; /* Avoid problems with backtracking over EOL */ + + yytchar=yytchar==EOF?EOF:(++yyposn,yysptr>yysbuf?U(*--yysptr):getc(yyin)); + + if(yytchar==10) + { + yylinestart = yyposn; + yylineno++; + } + + if (yytchar == '\t') + { + yytabindent = yyindent; /* Remember TAB indentation - only 1, though! */ + yyindent += 8 - (yyindent % 8); /* Tabs stops are 8 columns apart */ + } + else + ++yyindent; + + + /* Special EOF processing inserts all missing '}'s into the input stream */ + + if(yytchar==EOF) + { + if(icontexts>icontexts_save && !incomment) + { + if(INDENTON) + { + indenttab[icontexts] = 0; + indenteof = TRUE; + return('\002'); + } + else + yyerror("missing '}' at end of file"); + } + + else if (yyin_save != NULL) + { + fclose(yyin); + yyin = yyin_save; + yyin_save = NULL; + new_filename(filename_save); + free(filename_save); + yylineno = yylineno_save; + yylastlineno = yylastlineno_save; + yyindent = 0; + yylindent = 0; + yyindent = yyindent_save; + yylindent = yylindent_save; + yyslindent = -1; + icontexts = icontexts_save -1; + icontexts_save = 0; + leof = TRUE; + yyposn = yyposn_save; + yylastposn = yylastposn_save; +#ifdef DEBUG + fprintf(stderr,"finished reading interface (%d:%d:%d)\n",yyindent,yylindent,INDENTPT); +#endif + return('\001'); /* YUCK */ + } + else + return(0); + } + else + return(yytchar); +} + +setstartlineno() +{ + if(yytchar == 10) + startlineno = yylineno -1; + else + startlineno = yylineno; +} + + +/* + * unput() backtracks over a character. With luck it will never backtrack over + * multiple EOLs and TABs (since these are lexical delimiters). + */ + +static +unput(c) +char c; +{ + /* fprintf(stderr,"Unputting %c\n",c); */ + + yytchar= (c); + + if(yytchar=='\n' || yytchar=='\r') + yylineno--; + + *yysptr++=yytchar; + if(c == '\t') + yyindent = yytabindent; + else + --yyindent; + + --yyposn; +} + + +/* + * Redefine yylex to check for stacked tokens, yylex1() is the original yylex() + */ + +yylex() +{ + if(yysttok != -1) + { + if(yysttok < 0) + { + int tok = -yysttok; + yysttok = -1; + return(tok); + } + RETURN(yysttok); + } + else + { + /* not quite right, and should take account of stacking */ + yylastlineno = yylineno; + yylastposn = yyposn; + return(yylex1()); + } +} + +#define yylex() yylex1() +%} + +%start PRIM + +D [0-9] +O [0-7] +H [0-9A-Fa-f] +N {D}+ +S [!#$%&*+./<=>?@\\^|~:] +NS [^!#$%&*+./<=>?@\\^|~:] +SId ({S}|~|-){S}* +Char [ !\"#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~] +L [A-Z] +I [A-Za-z] +i [A-Za-z0-9'_] +Id {I}({i})* +A (NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|SP|DEL) +WS [ \t\n\r\f]* + +%e 1000 +%o 2100 +%a 2100 +%p 3600 +%n 490 +%k 350 + +%% + +^"# ".*[\n\r] { char tempf[FILENAME_SIZE]; + sscanf(yytext+1, "%d \"%[^\"]", &yylineno, tempf); + new_filename(tempf); + } + +^"{-# LINE ".*"-}"[\n\r] { /* partain: pragma-style line directive */ + char tempf[FILENAME_SIZE]; + sscanf(yytext+9, "%d \"%[^\"]", &yylineno, tempf); + new_filename(tempf); + } + +"{-# ARITY " { if ( ignorePragmas || ignoreArityPragmas ) { + incomment = 1; + readcomment(); + incomment = 0; + } else { + RETURN(ARITY_PRAGMA); + } + } +"{-# SPECIALIZE " { if ( ignorePragmas || ignoreSpecializePragmas ) { + incomment = 1; + readcomment(); + incomment = 0; + } else { + RETURN(SPECIALIZE_PRAGMA); + } + } +"{-# STRICTNESS " { if ( ignorePragmas || ignoreStrictnessPragmas ) { + incomment = 1; + readcomment(); + incomment = 0; + } else { + RETURN(STRICTNESS_PRAGMA); + } + } +"{-# UPDATE " { if ( ignorePragmas || ignoreUpdatePragmas ) { + incomment = 1; + readcomment(); + incomment = 0; + } else { + RETURN(UPDATE_PRAGMA); + } + } + +" #-}" { RETURN(END_PRAGMA); } + +"void#" { RETURN(VOIDPRIM); } +{Id}"#" { yynewid(yytext,yyleng); + RETURN(isconstr(yytext)? CONID: VARID); + /* Must appear before keywords -- KH */ + } + +"case" { RETURN(CASE); } +"class" { RETURN(CLASS); } +"data" { RETURN(DATA); } +"default" { RETURN(DEFAULT); } +"deriving" { RETURN(DERIVING); } +"else" { RETURN(ELSE); } +"hiding" { RETURN(HIDING); } +"if" { RETURN(IF); } +"import" { RETURN(IMPORT); } +"infix" { RETURN(INFIX); } +"infixl" { RETURN(INFIXL); } +"infixr" { RETURN(INFIXR); } +"instance" { RETURN(INSTANCE); } +"interface" { RETURN(INTERFACE); } +"module" { RETURN(MODULE); } +"of" { RETURN(OF); } +"renaming" { RETURN(RENAMING); } +"then" { RETURN(THEN); } +"to" { RETURN(TO); } +"type" { RETURN(TYPE); } +"where" { RETURN(WHERE); } +"in" { RETURN(IN); } +"let" { RETURN(LET); } +"ccall" { RETURN(CCALL); } +"veryDangerousCcall" { RETURN(CCALL_DANGEROUS); } +"casm" { RETURN(CASM); } +"veryDangerousCasm" { RETURN(CASM_DANGEROUS); } +"scc" { RETURN(SCC); } + +".." { RETURN(DOTDOT); } +";" { RETURN(SEMI); } +"," { RETURN(COMMA); } +"|" { RETURN(VBAR); } +"=" { RETURN(EQUAL); } +"<-" { RETURN(LARROW); } +"->" { RETURN(RARROW); } +"=>" { RETURN(DARROW); } +"::" { RETURN(DCOLON); } +"(" { RETURN(OPAREN); } +")" { RETURN(CPAREN); } +"[" { RETURN(OBRACK); } +"]" { RETURN(CBRACK); } +"{" { RETURN(OCURLY); } +"}" { RETURN(CCURLY); } +"+" { RETURN(PLUS); } +"@" { RETURN(AT); } +"\\" { RETURN(LAMBDA); } +"_" { RETURN(WILDCARD); } +"`" { RETURN(BQUOTE); } +"<<" { RETURN(OPOD); } +">>" { RETURN(CPOD); } +"(|" { RETURN(OPROC); } +"|)" { RETURN(CPROC); } +"<<-" { RETURN(DRAWNFROM); } +"<<=" { RETURN(INDEXFROM); } + +("-")?{N}"#" { + yytext[yyleng-1] = '\0'; /* clobber the # first */ + yylval.uid = xstrdup(yytext); + RETURN(INTPRIM); + } +{N} { + yylval.uid = xstrdup(yytext); + RETURN(INTEGER); + } + +{N}"."{N}(("e"|"E")("+"|"-")?{N})?"##" { + yytext[yyleng-2] = '\0'; /* clobber the # first */ + yylval.uid = xstrdup(yytext); + RETURN(DOUBLEPRIM); + } + +{N}"."{N}(("e"|"E")("+"|"-")?{N})?"#" { + yytext[yyleng-1] = '\0'; /* clobber the # first */ + yylval.uid = xstrdup(yytext); + RETURN(FLOATPRIM); + } + +{N}"."{N}(("e"|"E")("+"|"-")?{N})? { + yylval.uid = xstrdup(yytext); + RETURN(FLOAT); + } + + +"``"[^']+"''" { yytext[yyleng-2] = '\0'; /* clobber '' first */ + yynewid(yytext+2,yyleng-2); + RETURN(CLITLIT); + } + +{Id} { yynewid(yytext,yyleng); + RETURN(isconstr(yytext)? CONID: VARID); + } + +{SId} { yynewid(yytext,yyleng); + if(yyleng == 1) + if (*yytext == '~') + return( LAZY ); + else if ( *yytext == '-' ) + return( MINUS ); + RETURN(isconstr(yytext)? CONSYM: VARSYM); + } + +"`"{Id}"#`" { yynewid(yytext+1,yyleng-2); + RETURN(isconstr(yytext+1)? CONSYM: VARSYM); + } + +'{Char}' { + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + RETURN(CHAR); + + /* WDP note: + we don't yet return CHARPRIMs + (ToDo) + */ + } + +'\\(a|b|f|n|r|t|v)' { + yytext[1] = escval(yytext[2]); + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + RETURN(CHAR); + } + +'\\(\"|\'|\\)' { + yytext[1] = yytext[2]; + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + RETURN(CHAR); + } + +'\\{A}' { yytext[yyleng-1] = '\0'; + if(strcmp(yytext+2,"DEL")==0) + { + yylval.uid = xstrdup("'\177"); + RETURN(CHAR); + } + else + { + int a = lookupascii(yytext+2); + if(a >= 0) + { + yytext[1] = a; + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + RETURN(CHAR); + } + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"invalid ASCII name in character constant: %s",yytext); + yyerror(errbuf); + } + } + } + +'\\{D}+' { if(convchar(yytext+2,yyleng-3,10)) + RETURN(CHAR); + } + +'\\o{O}+' { if(convchar(yytext+3,yyleng-4,8)) + RETURN(CHAR); + } + +'\\x{H}+' { if(convchar(yytext+3,yyleng-4,16)) + RETURN(CHAR); + } + +'\\\^[A-Z\[\\\]^_]' { yytext[1] = yytext[3]-'A'+ 1; + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + RETURN(CHAR); + } + +'\\\^@' { yytext[1] = '\0'; /* partain: most doubtful... */ + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + RETURN(CHAR); + } + +"\"" { + readstring(); + yylval.uid = installString(yyleng, yytext); + RETURN(STRING); + } + + +"--".*[\n\r] ; /* hm-hm -style comment */ + +"\001" { if (leof) + { + unput(yytchar_save); + RETURN(LEOF); + } + + fprintf(stderr, "illegal char: %c (%d) in line %d\n", + yytext[0], yytext[0], yylineno); + } + +"\002" { if (indenteof) + { + indenteof = FALSE; + RETURN(VCCURLY); + } + + fprintf(stderr, "illegal char: %c (%d) in line %d\n", + yytext[0], yytext[0], yylineno); + } + +[\r\n \t\v\f] ; + +. { fprintf(stderr, "illegal char: %c (%d) in line %d\n", + yytext[0], yytext[0], yylineno); + } + +"{-" { + incomment = 1; + readcomment(); + incomment = 0; + } +%% + + +/********************************************************************** +* * +* * +* YACC/LEX Initialisation etc. * +* * +* * +**********************************************************************/ + + +/* + We initialise input_filename to "". + This allows unnamed sources to be piped into the parser. +*/ + +yyinit() +{ + extern BOOLEAN acceptPrim; + + input_filename = xstrdup(""); + + yytchar = '\n'; + + if(acceptPrim) + BEGIN PRIM; +} + + +new_filename(f) +char *f; +{ + if(input_filename != NULL) + free(input_filename); + input_filename = xstrdup(f); +} + + + +yywrap() +{ + return(1); +} + + +/********************************************************************** +* * +* * +* Comment Handling * +* * +* * +**********************************************************************/ + + + +/* + readcomment() reads Haskell nested comments {- ... -} + Indentation is automatically taken care of since input() is used. + + While in principle this could be done using Lex rules, in + practice it's easier and neater to use special code for this + and for strings. +*/ + +static readcomment() +{ + int c; + + do { + while ((c = input()) != '-' && !eof(c)) + { + if(c=='{') + if ((c=input()) == '-') + readcomment(); + + else if (eof(c)) + { + yyerror("comment not terminated by end of file"); + } + } + + while (c == '-') + c = input(); + + if (c == '}') + break; + + if (eof(c)) + { + yyerror("comment not terminated by end of file"); + } + + } while (1); +} + + +/* + eof(c) Returns TRUE when EOF read. +*/ + +eof(c) +int c; +{ + return (c == 0 || c == 1 && leof); +} + + + +/********************************************************************** +* * +* * +* Identifier Processing * +* * +* * +**********************************************************************/ + + +/* + yynewid Enters an id of length n into the symbol table. +*/ + +static yynewid(yyt,len) +char *yyt; +int len; +{ + char yybuf[1024]; + strcpy(yybuf,yyt); + yybuf[len] = '\0'; + yylval.uid = installid(yybuf); +} + + +/* + isconstr(s) True iff s is a constructor id. +*/ + +isconstr(s) +char *s; +{ + return(*s == ':' || isupper(*s)); +} + + + + +/********************************************************************** +* * +* * +* Character Kind Predicates * +* * +* * +**********************************************************************/ + + +/* + * ishspace(ch) determines whether ch is a valid Haskell space character + */ + + +static int ishspace(ch) +char ch; +{ + return(ch == '\n' || ch == ' ' || ch == '\t' || ch == '\v' || ch == '\f'); +} + + +/* + * isddigit(ch) determines whether ch is a valid Decimal digit + */ + + +static int isddigit(ch) +char ch; +{ + return (isdigit(ch)); +} + + +/* + * ishexdigit(ch) determines whether ch is a valid Hexadecimal digit + */ + + +static int ishexdigit(ch) +char ch; +{ + return (isdigit(ch) || (ch >= 'A' && ch <= 'F') || (ch >= 'a' && ch <= 'f')); +} + +/* + * isodigit(ch) determines whether ch is a valid Octal digit + */ + + +static int isodigit(ch) +char ch; +{ + return ((ch >= '0' && ch <= '7')); +} + + +/********************************************************************** +* * +* * +* Lexical Analysis of Strings -- Gaps and escapes mean that * +* lex isn't (wo)man enough for this job. * +* * +* * +**********************************************************************/ + + +/* + * readstring() reads a string constant and places it in yytext + */ + +static readstring() +{ + int ch, c; + + yyslindent = yyindent-1; + + yyleng = 1; + yytext[1] = '\0'; + + do + { + ch = input(); + + if (ch == '\\') + { + ch = input(); + + if(isdigit(ch)) + ch = readescnum(isddigit,10,ch); + + else if (ch == 'o') + { + ch = input(); + if(isodigit(ch)) + ch = readescnum(isodigit,8,ch); + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"strange Octal character code (%c) in string",ch); + yyerror(errbuf); + } + } + + else if (ch == 'x') + { + ch = input(); + if(ishexdigit(ch)) + ch = readescnum(ishexdigit,16,ch); + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"strange Hexadecimal character code (%c) in string",ch); + yyerror(errbuf); + } + } + + else if(ch == '"' || ch == '\\' || ch == '\'') + /* SKIP */; + + else if (isupper(ch)) + { + if((ch = readasciiname(ch)) == -1) + yyerror("invalid ASCII name in string"); + } + + else if (ch == '^') + { + if(isupper(ch = input()) || (ch >= '[' && ch <= '_')) + ch = ch - 'A' + 1; + else if (ch == '@') + ch = '\0'; + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"strange control sequence (^%c) in string",ch); + yyerror(errbuf); + } + } + + else if (ishspace(ch)) + { + /* partain: we may want clearer error msgs if \v, \f seen */ + + while (ch == '\t' || ch == ' ') + ch = input(); + + if (ch != '\n' && ch != '\r') + yyerror("newline not seen when expected in string gap"); + else + ch = input(); + + while (ch == '\t' || ch == ' ') + ch = input(); + + if(ch != '\\') + yyerror("trailing \\ not seen when expected in string gap"); + + ch = -1; + } + + else if (ch == 'a') + ch = '\007'; + + else if (ch == 'b') + ch = '\b'; + + else if (ch == 'f') + ch = '\f'; + + else if (ch == 'n') + ch = '\n'; + + else if (ch == 'r') + ch = '\r'; + + else if (ch == 't') + ch = '\t'; + + else if (ch == 'v') + ch = '\v'; + + else if (ch == '&') + ch = -1; + + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"invalid escape sequence (\\%c) in string",ch); + yyerror(errbuf); + } + } + + else if (ch == '\n' || ch == '\r' || ch == '\f' || ch == '\v' || ch == 0 || ch == '"') + break; + + else if (!isprint(ch) && !ishspace(ch)) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"invalid character (%c) in string",ch); + yyerror(errbuf); + } + + if((yyleng < YYLMAX-3 && ch != -1) || (yyleng == YYLMAX-3 && (ch == '\t' || ch == '\\'))) + { + /* The LML back-end treats \\ and \t specially in strings... */ + + if(ch == '\t' || ch == '\\') + { + yytext[yyleng++] = '\\'; + if (ch == '\t') + ch = 't'; + } + if(yyleng %d characters)",YYLMAX-3-2); + yyerror(errbuf); + } + } + while(1); + + if (ch != '"') + yyerror("string incorrectly terminated"); + + else + { + yytext[yyleng++] = '"'; + yytext[yyleng] = '\0'; + } +#ifdef DEBUG + fprintf(stderr,"string: %s (%d chars)\n",yytext,yyleng-2); +#endif +} + + + +/********************************************************************** +* * +* * +* Haskell String and Character Escape Codes * +* * +* * +**********************************************************************/ + + +/* Names of ASCII control characters, used in strings and character constants */ + +static char *asciinames[] = + { + "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS", "HT", + "LF", "VT", "FF", "CR", "SO", "SI", "DLE", "DC1", "DC2", "DC3", + "DC4", "NAK", "SYN", "ETB", "CAN", "EM", "SUB", "ESC", "FS", "GS", + "RS", "US", "SP", "DEL" + }; + + +/* + * readasciiname() read ASCII name and translate to an ASCII code + * -1 indicates invalid name + */ + +static int readasciiname(ch) +int ch; +{ + char asciiname[4]; + + asciiname[0] = ch; + if(!isupper(asciiname[1]= input())) + { + unput(asciiname[1]); + return(-1); + } + + if(!isupper(asciiname[2]=input())) + { + /* partain: have to have something extra for DC[1-4] */ + if (asciiname[0] == 'D' && asciiname[1] == 'C' && isdigit(asciiname[2])) { + asciiname[3] = '\0'; + } else { + unput(asciiname[2]); + asciiname[2] = '\0'; + } + } + else + asciiname[3] = '\0'; + + if (strcmp(asciiname,"DEL") == 0) + return('\177'); + + else + return(lookupascii(asciiname)); +} + + +/* + lookupascii(ascii) look up ascii in asciinames[] + + returns -1 if ascii is not found, otherwise its index. +*/ + +static int lookupascii(ascii) +char *ascii; +{ + int i; + for(i='\0'; i <= ' '; ++i) + if(strcmp(ascii,asciinames[i])==0) + return(i); + return(-1); +} + + +/********************************************************************** +* * +* * +* Numeric Escapes in Characters/Strings * +* * +* * +**********************************************************************/ + +int convnum(num,numlen,base) +char *num; +int numlen, base; +{ + int i, res = 0, mul; + + for (i = numlen-1, mul = 1; i >= 0; --i, mul *= base) + { + if(isdigit(num[i])) + res += (num[i] - '0') * mul; + else if (isupper(num[i])) + res += (num[i] - 'A' + 10) * mul; + else if (islower(num[i])) + res += (num[i] - 'a' + 10) * mul; + } + return(res); +} + +convchar(num,numlen,base) +char *num; +int numlen, base; +{ + int n = convnum(num,numlen,base); + if (n <= MAX_ESC_CHAR) + { + yytext[1] = n; + yytext[2] = '\0'; + yylval.uid = xstrdup(yytext); + return(1); + } + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"ASCII code > %d in character constant",MAX_ESC_CHAR); + yyerror(errbuf); + } +} + +readescnum(isadigit,mulbase,ch) +int (*isadigit)(); +int mulbase; +int ch; +{ + char digit[MAX_ESC_DIGITS]; + int digcount; + + digcount = 1; + digit[0] = ch; + + while((*isadigit)(ch=input())) + { + if(digcount < MAX_ESC_DIGITS) + digit[digcount] = ch; + ++digcount; + } + + unput(ch); + + if(digcount > MAX_ESC_DIGITS) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"numeric character code too long (> %d characters) in string",MAX_ESC_DIGITS); + yyerror(errbuf); + } + + ch = convnum(digit,digcount,mulbase); + + if (ch > MAX_ESC_CHAR) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"character code > ASCII %d in string",MAX_ESC_CHAR); + yyerror(errbuf); + } + + return(ch); +} + + +/* + escval(c) return the value of an escaped character. + + \a BELL + \b BACKSPACE + \f FORMFEED + \n NEWLINE + \r CARRIAGE RETURN + \t TAB + \v VERTICAL TAB + + These definitions are standard ANSI C values. +*/ + +static char escval(c) +char c; +{ + return(c == 'a'? '\007': c == 'b'? '\b': c == 'f'? '\f': c == 'n'? '\n': + c == 'r'? '\r': c == 't'? '\t': c == 'v'? '\v': '\0'); +} + +/* + OLD: Lexical analysis for Haskell pragmas. +*/ + +#if 0 +static parse_pragma(s,len) +char *s; +int len; +{ + char pragma_name[1024]; + char identifier[1024]; + char value[1024]; + int i; + + *(s+len) = '\0'; + + while(isspace(*s)) + s++; + + /* Pragma name */ + for(i=0; !isspace(*s); ++i, ++s) + pragma_name[i] = *s; + pragma_name[i] = '\0'; + + while(isspace(*s)) + s++; + + /* Identifier */ + for(i=0; !isspace(*s); ++i, ++s) + identifier[i] = *s; + identifier[i] = '\0'; + + while(isspace(*s)) + s++; + + /* equals */ + s++; + + while(isspace(*s)) + s++; + + /* Value */ + for(i=0; !isspace(*s); ++i, ++s) + value[i] = *s; + value[i] = '\0'; + + pragmatype = installid(pragma_name); + pragmaid = installid(identifier); + pragmavalue = xstrdup(value); +} + +#endif /* 0 */ diff --git a/ghc/compiler/yaccParser/hslexer.c b/ghc/compiler/yaccParser/hslexer.c new file mode 100644 index 0000000..20c54d3 --- /dev/null +++ b/ghc/compiler/yaccParser/hslexer.c @@ -0,0 +1,4116 @@ +/* A lexical scanner generated by flex */ + +/* Scanner skeleton version: + * $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/compiler/yaccParser/Attic/hslexer.c,v 1.1 1996/01/08 20:15:54 partain Exp $ + */ + +#define FLEX_SCANNER + +#include + + +/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ +#ifdef c_plusplus +#ifndef __cplusplus +#define __cplusplus +#endif +#endif + + +#ifdef __cplusplus + +#include +#include + +/* Use prototypes in function declarations. */ +#define YY_USE_PROTOS + +/* The "const" storage-class-modifier is valid. */ +#define YY_USE_CONST + +#else /* ! __cplusplus */ + +#ifdef __STDC__ + +#define YY_USE_PROTOS +#define YY_USE_CONST + +#endif /* __STDC__ */ +#endif /* ! __cplusplus */ + + +#ifdef __TURBOC__ +#define YY_USE_CONST +#endif + + +#ifndef YY_USE_CONST +#ifndef const +#define const +#endif +#endif + + +#ifdef YY_USE_PROTOS +#define YY_PROTO(proto) proto +#else +#define YY_PROTO(proto) () +#endif + +/* Returned upon end-of-file. */ +#define YY_NULL 0 + +/* Promotes a possibly negative, possibly signed char to an unsigned + * integer for use as an array index. If the signed char is negative, + * we want to instead treat it as an 8-bit unsigned char, hence the + * double cast. + */ +#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c) + +/* Enter a start condition. This macro really ought to take a parameter, + * but we do it the disgusting crufty way forced on us by the ()-less + * definition of BEGIN. + */ +#define BEGIN yy_start = 1 + 2 * + +/* Translate the current start state into a value that can be later handed + * to BEGIN to return to the state. + */ +#define YY_START ((yy_start - 1) / 2) + +/* Action number for EOF rule of a given start state. */ +#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1) + +/* Special action meaning "start processing a new file". Now included + * only for backward compatibility with previous versions of flex. + */ +#define YY_NEW_FILE yyrestart( yyin ) + +#define YY_END_OF_BUFFER_CHAR 0 + +/* Size of default input buffer. */ +#define YY_BUF_SIZE 16384 + +typedef struct yy_buffer_state *YY_BUFFER_STATE; + +extern int yyleng; +extern FILE *yyin, *yyout; + +#ifdef __cplusplus +extern "C" { +#endif + extern int yywrap YY_PROTO(( void )); +#ifdef __cplusplus + } +#endif + +#define EOB_ACT_CONTINUE_SCAN 0 +#define EOB_ACT_END_OF_FILE 1 +#define EOB_ACT_LAST_MATCH 2 + +/* The funky do-while in the following #define is used to turn the definition + * int a single C statement (which needs a semi-colon terminator). This + * avoids problems with code like: + * + * if ( condition_holds ) + * yyless( 5 ); + * else + * do_something_else(); + * + * Prior to using the do-while the compiler would get upset at the + * "else" because it interpreted the "if" statement as being all + * done when it reached the ';' after the yyless() call. + */ + +/* Return all but the first 'n' matched characters back to the input stream. */ + +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + *yy_cp = yy_hold_char; \ + yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \ + YY_DO_BEFORE_ACTION; /* set up yytext again */ \ + } \ + while ( 0 ) + +#define unput(c) yyunput( c, yytext_ptr ) + + +struct yy_buffer_state + { + FILE *yy_input_file; + + char *yy_ch_buf; /* input buffer */ + char *yy_buf_pos; /* current position in input buffer */ + + /* Size of input buffer in bytes, not including room for EOB + * characters. + */ + int yy_buf_size; + + /* Number of characters read into yy_ch_buf, not including EOB + * characters. + */ + int yy_n_chars; + + /* Whether this is an "interactive" input source; if so, and + * if we're using stdio for input, then we want to use getc() + * instead of fread(), to make sure we stop fetching input after + * each newline. + */ + int yy_is_interactive; + + /* Whether to try to fill the input buffer when we reach the + * end of it. + */ + int yy_fill_buffer; + + int yy_buffer_status; +#define YY_BUFFER_NEW 0 +#define YY_BUFFER_NORMAL 1 + /* When an EOF's been seen but there's still some text to process + * then we mark the buffer as YY_EOF_PENDING, to indicate that we + * shouldn't try reading from the input source any more. We might + * still have a bunch of tokens to match, though, because of + * possible backing-up. + * + * When we actually see the EOF, we change the status to "new" + * (via yyrestart()), so that the user can continue scanning by + * just pointing yyin at a new input file. + */ +#define YY_BUFFER_EOF_PENDING 2 + }; + +static YY_BUFFER_STATE yy_current_buffer = 0; + +/* We provide macros for accessing buffer states in case in the + * future we want to put the buffer states in a more general + * "scanner state". + */ +#define YY_CURRENT_BUFFER yy_current_buffer + + +/* yy_hold_char holds the character lost when yytext is formed. */ +static char yy_hold_char; + +static int yy_n_chars; /* number of characters read into yy_ch_buf */ + + +int yyleng; + +/* Points to current character in buffer. */ +static char *yy_c_buf_p = (char *) 0; +static int yy_init = 1; /* whether we need to initialize */ +static int yy_start = 0; /* start state number */ + +/* Flag which is used to allow yywrap()'s to do buffer switches + * instead of setting up a fresh yyin. A bit of a hack ... + */ +static int yy_did_buffer_switch_on_eof; + +static void yyunput YY_PROTO(( int c, char *buf_ptr )); +void yyrestart YY_PROTO(( FILE *input_file )); +void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer )); +void yy_load_buffer_state YY_PROTO(( void )); +YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size )); +void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b )); +void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file )); + +static int yy_start_stack_ptr = 0; +static int yy_start_stack_depth = 0; +static int *yy_start_stack = 0; +static void yy_push_state YY_PROTO(( int new_state )); +static void yy_pop_state YY_PROTO(( void )); +static int yy_top_state YY_PROTO(( void )); + +static void *yy_flex_alloc YY_PROTO(( unsigned int )); +static void *yy_flex_realloc YY_PROTO(( void *, unsigned int )); +static void yy_flex_free YY_PROTO(( void * )); + +#define yy_new_buffer yy_create_buffer + +#define INITIAL 0 +#define Char 1 +#define CharEsc 2 +#define Code 3 +#define Comment 4 +#define GlaExt 5 +#define GhcPragma 6 +#define UserPragma 7 +#define String 8 +#define StringEsc 9 +typedef unsigned char YY_CHAR; +typedef int yy_state_type; +FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0; +extern char *yytext; +#define yytext_ptr yytext + +#ifndef yytext_ptr +static void yy_flex_strncpy YY_PROTO(( char *, const char *, int )); +#endif + +#ifdef __cplusplus +static int yyinput YY_PROTO(( void )); +#else +static int input YY_PROTO(( void )); +#endif + +static yy_state_type yy_get_previous_state YY_PROTO(( void )); +static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state )); +static int yy_get_next_buffer YY_PROTO(( void )); +static void yy_fatal_error YY_PROTO(( const char msg[] )); + +/* Done after the current pattern has been matched and before the + * corresponding action - sets up yytext. + */ +#define YY_DO_BEFORE_ACTION \ + yytext_ptr = yy_bp; \ + yyleng = yy_cp - yy_bp; \ + yy_hold_char = *yy_cp; \ + *yy_cp = '\0'; \ + yy_c_buf_p = yy_cp; + +#define YY_END_OF_BUFFER 202 +static const short int yy_accept[838] = + { 0, + 0, 0, 0, 0, 0, 0, 0, 0, 190, 190, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 202, 196, 197, 129, 128, 136, 198, 141, 184, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 139, 198, 150, 152, 160, 156, 198, + 162, 154, 158, 198, 188, 121, 132, 126, 91, 92, + 97, 84, 104, 121, 110, 110, 121, 83, 121, 86, + 98, 120, 93, 99, 94, 101, 102, 120, 120, 120, + 120, 120, 120, 120, 120, 120, 120, 120, 95, 85, + 96, 103, 121, 190, 195, 195, 132, 126, 104, 110, + + 110, 120, 101, 102, 120, 120, 120, 120, 120, 120, + 120, 120, 120, 120, 120, 188, 126, 121, 110, 196, + 120, 120, 120, 120, 120, 95, 121, 121, 121, 196, + 196, 120, 120, 196, 199, 135, 134, 138, 200, 188, + 141, 200, 184, 200, 200, 200, 200, 200, 200, 200, + 200, 200, 200, 200, 200, 200, 200, 140, 200, 150, + 152, 160, 156, 200, 162, 154, 158, 200, 200, 129, + 128, 127, 184, 0, 0, 151, 0, 161, 0, 0, + 0, 174, 0, 0, 0, 0, 159, 177, 178, 153, + 155, 0, 0, 179, 164, 163, 181, 0, 0, 0, + + 180, 157, 183, 185, 186, 188, 121, 132, 131, 126, + 125, 0, 88, 82, 0, 110, 0, 0, 90, 87, + 89, 120, 119, 0, 119, 120, 120, 120, 120, 120, + 120, 60, 120, 74, 120, 120, 68, 120, 120, 71, + 120, 120, 189, 0, 0, 190, 191, 0, 194, 192, + 193, 0, 132, 131, 126, 0, 0, 109, 0, 110, + 0, 0, 118, 120, 119, 0, 0, 120, 120, 120, + 120, 120, 120, 60, 120, 74, 120, 120, 68, 120, + 120, 71, 120, 120, 0, 126, 0, 110, 0, 0, + 0, 119, 119, 119, 119, 119, 119, 119, 119, 119, + + 119, 119, 119, 119, 119, 119, 119, 0, 120, 120, + 74, 120, 68, 189, 0, 120, 135, 134, 133, 137, + 148, 149, 173, 166, 167, 168, 169, 182, 165, 147, + 146, 176, 172, 145, 170, 142, 143, 144, 175, 171, + 126, 124, 0, 187, 187, 113, 106, 108, 119, 119, + 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, + 120, 75, 120, 120, 120, 120, 120, 0, 0, 1, + 1, 0, 130, 124, 0, 0, 113, 106, 108, 119, + 119, 0, 0, 0, 120, 120, 120, 120, 120, 120, + 120, 120, 120, 120, 120, 75, 120, 120, 120, 120, + + 120, 0, 0, 0, 18, 19, 0, 119, 119, 119, + 119, 12, 119, 119, 119, 119, 119, 119, 17, 119, + 15, 119, 119, 119, 11, 119, 119, 6, 119, 119, + 119, 119, 14, 119, 119, 119, 13, 119, 119, 117, + 120, 75, 52, 187, 187, 187, 187, 0, 119, 53, + 120, 55, 120, 120, 58, 120, 120, 120, 120, 120, + 120, 120, 70, 72, 120, 0, 0, 0, 0, 0, + 0, 0, 0, 123, 0, 0, 112, 0, 105, 107, + 119, 119, 122, 0, 53, 120, 55, 120, 120, 58, + 120, 120, 120, 120, 120, 120, 120, 70, 72, 120, + + 46, 0, 100, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 16, 119, + 7, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 117, 53, 0, 113, 80, 54, 120, + 120, 120, 120, 62, 120, 120, 120, 120, 73, 0, + 0, 0, 0, 0, 0, 0, 0, 111, 0, 113, + 119, 119, 114, 54, 120, 120, 120, 120, 62, 120, + 120, 120, 120, 73, 0, 0, 119, 22, 119, 119, + 20, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 115, 119, 119, 119, 119, 119, 119, 119, + + 119, 119, 119, 119, 119, 120, 120, 59, 61, 63, + 64, 120, 120, 67, 120, 0, 0, 0, 0, 0, + 0, 0, 0, 78, 119, 120, 120, 59, 61, 63, + 64, 120, 120, 67, 120, 119, 119, 119, 119, 119, + 119, 35, 119, 36, 119, 119, 119, 119, 34, 119, + 119, 40, 119, 23, 119, 119, 38, 116, 119, 119, + 39, 119, 56, 120, 120, 120, 120, 0, 0, 0, + 0, 0, 0, 0, 0, 2, 2, 119, 76, 56, + 120, 120, 120, 120, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 33, 119, + + 21, 119, 119, 57, 65, 120, 69, 0, 0, 0, + 0, 0, 0, 0, 119, 119, 57, 65, 120, 69, + 119, 119, 41, 119, 32, 37, 119, 119, 119, 119, + 25, 119, 119, 119, 119, 119, 119, 119, 81, 66, + 0, 0, 0, 0, 48, 0, 0, 79, 119, 66, + 119, 119, 29, 119, 30, 31, 42, 43, 44, 45, + 119, 119, 119, 28, 0, 0, 0, 0, 0, 0, + 0, 77, 8, 119, 9, 24, 119, 119, 0, 0, + 51, 50, 0, 0, 119, 119, 119, 0, 3, 3, + 0, 0, 119, 119, 10, 0, 0, 47, 119, 119, + + 0, 0, 27, 119, 5, 0, 119, 0, 0, 119, + 0, 0, 119, 0, 49, 26, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 4, 0 + } ; + +static const int yy_ec[256] = + { 0, + 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, + 2, 2, 4, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 5, 6, 7, 8, 9, 10, 11, 12, 13, + 14, 10, 15, 16, 17, 18, 19, 20, 21, 22, + 23, 24, 25, 25, 25, 26, 26, 27, 28, 29, + 30, 31, 10, 32, 33, 34, 35, 36, 37, 38, + 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, + 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, + 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, + + 69, 70, 71, 72, 73, 74, 74, 75, 76, 77, + 78, 79, 74, 80, 81, 82, 83, 84, 85, 86, + 87, 74, 88, 89, 90, 91, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1 + } ; + +static const int yy_meta[92] = + { 0, + 1, 1, 2, 1, 3, 4, 3, 5, 6, 4, + 4, 7, 3, 3, 4, 3, 8, 4, 4, 9, + 9, 9, 9, 9, 9, 9, 4, 3, 4, 4, + 4, 10, 11, 11, 11, 11, 11, 11, 12, 12, + 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, + 12, 12, 12, 12, 12, 12, 12, 12, 13, 14, + 13, 10, 15, 16, 17, 17, 17, 17, 17, 17, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 19, 4, 20, + 4 + + } ; + +static const short int yy_base[881] = + { 0, + 0, 0, 0, 4, 58, 138, 224, 2192, 0, 1, + 315, 2191, 402, 0, 487, 0, 25, 39, 578, 0, + 2198, 2201, 2201, 2185, 2188, 2201, 2201, 2201, 13, 2160, + 7, 12, 12, 21, 10, 2143, 2141, 2154, 18, 2140, + 69, 2139, 2137, 2201, 0, 2201, 2201, 2201, 2201, 0, + 2201, 2201, 2201, 0, 50, 0, 2181, 2175, 2201, 2201, + 0, 2201, 46, 2168, 131, 415, 2158, 2201, 2167, 2152, + 0, 0, 2201, 0, 2201, 6, 2201, 11, 36, 2107, + 2108, 30, 2111, 2101, 2108, 2108, 47, 2104, 2158, 0, + 2201, 0, 52, 0, 13, 2, 2167, 2161, 425, 662, + + 506, 2164, 66, 2107, 66, 452, 105, 2, 129, 124, + 107, 131, 138, 663, 42, 407, 0, 148, 515, 745, + 5, 158, 421, 449, 455, 2153, 0, 2152, 2137, 2104, + 2102, 122, 135, 2148, 2201, 2157, 2155, 2151, 2201, 192, + 2201, 2144, 652, 2125, 132, 169, 417, 497, 370, 2108, + 2106, 2119, 137, 2105, 648, 2104, 2102, 2201, 0, 2201, + 2201, 2201, 2201, 686, 2201, 2201, 2201, 0, 2136, 2140, + 2143, 2201, 692, 2107, 2105, 2201, 2102, 2201, 669, 2103, + 2109, 2201, 2096, 2092, 2108, 410, 2201, 2201, 2201, 2201, + 2201, 2099, 2097, 2201, 2201, 2100, 2201, 2083, 2104, 2091, + + 2201, 2201, 2201, 699, 0, 723, 0, 2129, 2201, 2123, + 2201, 207, 0, 0, 734, 745, 709, 0, 0, 2201, + 0, 0, 0, 2071, 2066, 2051, 2066, 2048, 373, 2048, + 2060, 0, 2048, 464, 2044, 2057, 0, 2047, 2054, 0, + 2043, 2052, 2112, 210, 2046, 0, 0, 2101, 2201, 0, + 2201, 2029, 2109, 2107, 2102, 796, 815, 2201, 822, 841, + 722, 0, 2201, 2105, 114, 2104, 0, 140, 488, 410, + 729, 483, 454, 2103, 424, 691, 489, 493, 2102, 728, + 451, 2101, 673, 741, 2091, 2095, 830, 863, 2043, 2042, + 2044, 846, 519, 838, 2040, 2064, 2038, 2063, 738, 766, + + 2049, 2048, 856, 517, 711, 2047, 2018, 0, 549, 730, + 689, 695, 776, 2201, 2005, 492, 2087, 2085, 2201, 2201, + 2201, 2201, 2201, 2201, 2201, 2201, 2201, 2201, 2201, 2201, + 2201, 2201, 2201, 2201, 2201, 2201, 2201, 2201, 2201, 2201, + 2080, 2201, 791, 893, 898, 890, 900, 0, 0, 2024, + 2021, 2008, 2023, 2022, 2013, 2016, 2011, 2005, 2009, 1999, + 2011, 0, 1996, 2013, 2000, 2007, 1995, 903, 799, 2201, + 821, 1997, 2201, 2065, 908, 0, 941, 948, 2064, 1990, + 2005, 2005, 2060, 2055, 824, 779, 861, 869, 862, 849, + 864, 860, 870, 865, 932, 2058, 909, 933, 934, 937, + + 938, 1975, 2056, 999, 2201, 2201, 2000, 2011, 935, 2013, + 2008, 0, 2021, 2012, 2019, 2003, 2020, 2006, 0, 1990, + 0, 2000, 1999, 1987, 0, 913, 925, 0, 2008, 790, + 1997, 2010, 0, 1998, 2012, 2007, 0, 2000, 1962, 0, + 943, 972, 2201, 980, 991, 1000, 1011, 1017, 1978, 0, + 1959, 0, 1956, 1954, 0, 1960, 1956, 1949, 1969, 1953, + 1957, 1955, 0, 0, 1961, 1024, 1043, 1995, 1991, 1981, + 1993, 1977, 1955, 2201, 1075, 2015, 2014, 1086, 2201, 2201, + 1945, 1945, 2201, 2007, 2010, 950, 2009, 947, 774, 2008, + 978, 969, 981, 952, 979, 983, 1001, 2007, 2006, 992, + + 2201, 1098, 2201, 1961, 1949, 1948, 1977, 1946, 1961, 1944, + 1955, 783, 1959, 1952, 1967, 1969, 1951, 1960, 0, 1936, + 0, 1961, 1961, 1957, 1951, 1949, 1956, 1957, 1928, 1942, + 1939, 1938, 1922, 0, 1042, 1105, 1112, 0, 0, 1911, + 1912, 1913, 1901, 991, 1905, 1911, 1911, 1906, 0, 1938, + 1936, 1925, 1937, 1930, 1934, 1935, 1966, 2201, 1119, 1138, + 1907, 1894, 2201, 1960, 989, 1000, 991, 1066, 1072, 1025, + 498, 1036, 1044, 1959, 1145, 1164, 1916, 0, 1929, 1907, + 0, 1900, 1927, 1909, 1897, 1909, 1895, 1894, 1893, 1905, + 1917, 1890, 0, 1904, 1914, 1887, 1896, 1885, 1903, 1015, + + 1153, 1898, 1882, 1881, 1868, 1860, 1864, 0, 0, 0, + 0, 1873, 1874, 0, 1861, 1902, 1890, 1883, 1887, 1892, + 1891, 1896, 1050, 1891, 1866, 1073, 1027, 1920, 1919, 1918, + 1917, 1082, 1085, 1916, 1077, 1890, 1881, 1870, 1885, 1884, + 1873, 0, 1880, 0, 1881, 1880, 1875, 1878, 0, 1849, + 1873, 0, 1874, 0, 1846, 1875, 0, 1171, 1844, 1871, + 0, 1830, 0, 1833, 1834, 1835, 1830, 1837, 1862, 1848, + 1847, 1850, 1860, 1853, 1088, 2201, 1153, 1858, 1853, 1883, + 1143, 1172, 1145, 1173, 1855, 1854, 1807, 1811, 1781, 1780, + 1789, 1803, 1795, 1765, 1751, 1157, 1769, 1773, 0, 1764, + + 0, 1756, 1719, 0, 0, 1711, 0, 1731, 1771, 1741, + 1735, 1727, 1679, 1691, 1652, 1669, 1666, 1664, 1174, 1663, + 1616, 1614, 0, 1599, 0, 0, 1608, 1596, 1593, 1591, + 0, 1563, 1545, 1531, 1540, 1528, 1547, 1523, 0, 0, + 1526, 1552, 1526, 1509, 2201, 1506, 1510, 0, 1489, 1543, + 1485, 1495, 0, 1481, 0, 0, 0, 0, 0, 0, + 1473, 1482, 1435, 0, 1433, 1438, 1166, 1393, 1391, 1396, + 1396, 0, 0, 1372, 0, 0, 1393, 1394, 1390, 1196, + 2201, 2201, 1383, 1012, 1368, 1355, 1326, 1343, 2201, 1369, + 1338, 1347, 1333, 1203, 0, 1221, 1209, 2201, 1189, 1200, + + 1245, 1213, 0, 1185, 1206, 1205, 1210, 1196, 1192, 1202, + 1184, 1196, 1143, 1164, 2201, 0, 1066, 1076, 1056, 1051, + 1035, 948, 896, 797, 756, 728, 661, 647, 633, 450, + 1195, 1204, 408, 396, 96, 2201, 2201, 1256, 1276, 1296, + 1316, 1336, 1354, 1365, 1193, 1377, 1389, 1407, 1421, 1429, + 1447, 1467, 1487, 1504, 1522, 1538, 1546, 1562, 1578, 1594, + 1612, 1632, 1194, 1646, 1658, 1676, 1696, 1716, 1734, 1750, + 1222, 1766, 1784, 1205, 1800, 1816, 1223, 1830, 1848, 1868 + } ; + +static const short int yy_def[881] = + { 0, + 838, 838, 839, 839, 840, 840, 837, 7, 841, 841, + 837, 11, 11, 13, 11, 15, 842, 842, 837, 19, + 837, 837, 837, 843, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 844, 837, 837, 837, 837, 837, + 837, 837, 837, 845, 837, 846, 847, 848, 837, 837, + 846, 837, 846, 846, 837, 837, 846, 837, 846, 846, + 846, 849, 837, 846, 837, 850, 837, 849, 849, 849, + 849, 849, 849, 849, 849, 849, 849, 849, 837, 846, + 837, 846, 846, 851, 852, 853, 854, 855, 846, 837, + + 837, 856, 850, 857, 856, 856, 856, 856, 856, 856, + 856, 856, 856, 856, 856, 837, 858, 99, 837, 850, + 859, 859, 859, 859, 859, 837, 846, 846, 846, 850, + 857, 856, 856, 837, 837, 860, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 844, 837, + 837, 837, 837, 837, 837, 837, 837, 845, 837, 843, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + + 837, 837, 837, 837, 845, 837, 846, 847, 837, 861, + 837, 862, 846, 846, 837, 837, 837, 863, 846, 837, + 846, 864, 865, 850, 865, 864, 864, 864, 864, 864, + 864, 864, 864, 864, 864, 864, 864, 864, 864, 864, + 864, 864, 837, 866, 837, 867, 868, 868, 837, 869, + 837, 869, 870, 837, 861, 837, 837, 837, 837, 837, + 837, 871, 837, 856, 865, 872, 873, 856, 856, 856, + 856, 856, 856, 856, 856, 856, 856, 856, 856, 856, + 856, 856, 856, 856, 837, 861, 837, 837, 837, 837, + 837, 865, 865, 865, 865, 865, 865, 865, 865, 865, + + 865, 865, 865, 865, 865, 865, 865, 874, 875, 875, + 875, 875, 875, 837, 837, 856, 876, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 861, 837, 862, 837, 862, 837, 837, 863, 865, 865, + 864, 864, 864, 864, 864, 864, 864, 864, 864, 864, + 864, 864, 864, 864, 864, 864, 864, 837, 866, 837, + 866, 837, 837, 837, 837, 877, 837, 837, 871, 865, + 865, 837, 872, 873, 856, 856, 856, 856, 856, 856, + 856, 856, 856, 856, 856, 856, 856, 856, 856, 856, + + 856, 837, 837, 837, 837, 837, 837, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 878, + 875, 875, 837, 837, 862, 837, 862, 837, 865, 864, + 864, 864, 864, 864, 864, 864, 864, 864, 864, 864, + 864, 864, 864, 864, 864, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 877, 837, 837, 837, 837, + 865, 865, 837, 837, 856, 856, 856, 856, 856, 856, + 856, 856, 856, 856, 856, 856, 856, 856, 856, 856, + + 837, 837, 837, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 878, 875, 837, 837, 865, 864, 864, + 864, 864, 864, 864, 864, 864, 864, 864, 864, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 865, 865, 837, 856, 856, 856, 856, 856, 856, 856, + 856, 856, 856, 856, 837, 837, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + + 865, 865, 865, 865, 865, 864, 864, 864, 864, 864, + 864, 864, 864, 864, 864, 837, 837, 837, 837, 837, + 837, 837, 879, 865, 865, 856, 856, 856, 856, 856, + 856, 856, 856, 856, 856, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 864, 864, 864, 864, 864, 837, 837, 837, + 837, 837, 837, 837, 879, 837, 879, 865, 865, 856, + 856, 856, 856, 856, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + + 865, 865, 865, 864, 864, 864, 864, 837, 837, 837, + 837, 837, 837, 837, 865, 865, 856, 856, 856, 856, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 864, + 837, 880, 837, 837, 837, 837, 837, 865, 865, 856, + 865, 865, 865, 865, 865, 865, 865, 865, 865, 865, + 865, 865, 865, 865, 837, 880, 880, 837, 837, 837, + 837, 865, 865, 865, 865, 865, 865, 865, 837, 880, + 837, 837, 837, 837, 865, 865, 865, 837, 837, 880, + 837, 837, 865, 865, 865, 837, 837, 837, 865, 865, + + 837, 837, 865, 865, 837, 837, 865, 837, 837, 865, + 837, 837, 865, 837, 837, 865, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 0, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837 + } ; + +static const short int yy_nxt[2293] = + { 0, + 23, 23, 23, 23, 23, 23, 23, 23, 837, 263, + 837, 25, 263, 308, 837, 25, 95, 95, 251, 204, + 204, 204, 204, 204, 204, 135, 135, 135, 135, 248, + 837, 137, 173, 173, 173, 173, 173, 173, 173, 135, + 135, 135, 135, 175, 177, 137, 179, 187, 180, 263, + 192, 206, 206, 206, 206, 181, 244, 176, 837, 26, + 188, 178, 212, 26, 28, 182, 183, 184, 224, 28, + 193, 185, 186, 263, 273, 226, 213, 29, 29, 29, + 29, 29, 29, 29, 138, 227, 225, 96, 96, 252, + 30, 31, 32, 33, 34, 35, 36, 37, 138, 232, + + 228, 38, 249, 39, 229, 233, 234, 40, 41, 195, + 42, 43, 263, 284, 263, 196, 197, 44, 239, 45, + 198, 199, 46, 47, 240, 200, 245, 48, 224, 263, + 268, 263, 265, 241, 49, 50, 263, 51, 263, 52, + 269, 53, 263, 54, 28, 263, 225, 263, 215, 28, + 216, 216, 216, 216, 216, 216, 216, 29, 29, 29, + 29, 29, 29, 29, 837, 263, 308, 257, 175, 192, + 30, 31, 32, 33, 34, 35, 36, 37, 380, 272, + 381, 38, 176, 39, 278, 836, 270, 40, 41, 193, + 42, 43, 277, 206, 206, 206, 206, 44, 274, 45, + + 279, 177, 46, 47, 275, 276, 280, 48, 217, 344, + 345, 316, 370, 371, 49, 50, 218, 51, 178, 52, + 385, 53, 310, 54, 22, 55, 55, 55, 55, 56, + 57, 56, 56, 56, 56, 58, 59, 60, 61, 62, + 63, 64, 56, 65, 66, 66, 66, 66, 66, 66, + 67, 68, 69, 70, 56, 71, 72, 72, 72, 72, + 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + 72, 72, 73, 74, 75, 56, 76, 77, 72, 72, + 78, 79, 80, 72, 72, 81, 82, 72, 83, 84, + + 72, 85, 72, 86, 72, 87, 72, 72, 88, 72, + 72, 89, 90, 91, 92, 22, 55, 55, 55, 55, + 56, 97, 56, 56, 56, 56, 98, 59, 60, 61, + 62, 99, 64, 56, 100, 101, 101, 101, 101, 101, + 101, 67, 68, 69, 70, 56, 71, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 73, 74, 75, 56, 103, 104, 102, + 102, 105, 106, 107, 102, 102, 108, 109, 102, 110, + 111, 102, 112, 102, 113, 102, 114, 102, 102, 115, + + 102, 102, 89, 90, 91, 92, 116, 187, 206, 206, + 206, 206, 835, 117, 285, 834, 56, 263, 118, 56, + 188, 119, 119, 119, 119, 119, 119, 119, 263, 308, + 56, 263, 215, 56, 216, 216, 216, 216, 216, 216, + 216, 212, 354, 333, 256, 257, 257, 257, 257, 257, + 257, 179, 355, 180, 831, 213, 263, 308, 263, 263, + 181, 263, 263, 308, 120, 334, 121, 121, 122, 121, + 121, 121, 121, 121, 123, 121, 124, 121, 121, 125, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 126, + 263, 387, 127, 22, 128, 263, 263, 311, 22, 263, + + 263, 56, 392, 129, 56, 263, 22, 22, 22, 22, + 22, 22, 22, 258, 22, 56, 270, 312, 56, 399, + 271, 391, 258, 259, 313, 260, 260, 260, 260, 260, + 260, 260, 287, 359, 288, 288, 288, 288, 288, 288, + 288, 182, 183, 184, 360, 361, 56, 185, 186, 130, + 131, 413, 386, 102, 132, 102, 263, 308, 102, 133, + 397, 102, 102, 390, 102, 414, 102, 633, 102, 434, + 396, 102, 394, 435, 134, 56, 22, 127, 139, 140, + 140, 140, 140, 139, 141, 139, 139, 139, 139, 141, + 139, 139, 139, 139, 142, 139, 139, 143, 143, 143, + + 143, 143, 143, 143, 139, 139, 139, 139, 139, 139, + 144, 145, 146, 147, 148, 149, 150, 151, 139, 139, + 139, 152, 139, 153, 139, 139, 139, 154, 155, 139, + 156, 157, 139, 139, 139, 139, 139, 158, 139, 159, + 139, 139, 160, 161, 139, 139, 139, 162, 139, 139, + 139, 139, 139, 139, 163, 164, 139, 165, 139, 166, + 139, 167, 139, 168, 139, 169, 139, 139, 139, 258, + 263, 173, 173, 173, 173, 173, 173, 173, 830, 259, + 263, 260, 260, 260, 260, 260, 260, 260, 195, 324, + 325, 326, 327, 829, 196, 197, 263, 308, 263, 198, + + 199, 828, 263, 308, 200, 204, 204, 204, 204, 204, + 204, 173, 173, 173, 173, 173, 173, 173, 204, 204, + 204, 204, 204, 204, 206, 206, 206, 206, 347, 347, + 347, 347, 347, 347, 281, 263, 263, 263, 308, 261, + 282, 378, 378, 378, 378, 378, 378, 262, 263, 283, + 289, 400, 290, 346, 346, 346, 346, 346, 346, 346, + 393, 436, 215, 291, 216, 216, 216, 216, 216, 216, + 216, 394, 395, 437, 423, 424, 442, 292, 827, 293, + 294, 263, 295, 263, 308, 296, 263, 297, 298, 299, + 300, 301, 302, 344, 345, 303, 304, 305, 388, 306, + + 425, 370, 371, 258, 398, 826, 426, 224, 389, 401, + 441, 265, 427, 287, 307, 257, 257, 257, 257, 257, + 257, 257, 258, 370, 371, 225, 525, 585, 428, 586, + 526, 263, 287, 825, 257, 257, 257, 257, 257, 257, + 257, 377, 377, 377, 377, 377, 377, 377, 258, 404, + 404, 404, 404, 404, 404, 404, 263, 566, 259, 486, + 260, 260, 260, 260, 260, 260, 260, 263, 263, 263, + 258, 263, 263, 375, 415, 416, 263, 263, 417, 408, + 287, 376, 288, 288, 288, 288, 288, 288, 288, 409, + 418, 431, 485, 410, 444, 444, 444, 444, 411, 445, + + 446, 447, 445, 432, 466, 466, 466, 467, 412, 346, + 346, 346, 346, 346, 346, 346, 263, 490, 433, 347, + 347, 347, 347, 347, 347, 487, 448, 475, 475, 475, + 475, 475, 475, 488, 489, 468, 491, 492, 469, 263, + 263, 263, 493, 470, 263, 263, 494, 471, 477, 824, + 263, 308, 823, 472, 263, 479, 520, 263, 448, 263, + 377, 377, 377, 377, 377, 377, 377, 378, 378, 378, + 378, 378, 378, 505, 522, 521, 263, 478, 506, 263, + 308, 444, 444, 444, 444, 263, 263, 523, 263, 507, + 263, 496, 445, 446, 447, 445, 263, 497, 263, 263, + + 495, 444, 444, 444, 444, 499, 477, 263, 263, 478, + 498, 535, 445, 446, 447, 445, 570, 500, 404, 404, + 404, 404, 404, 404, 404, 466, 466, 466, 466, 565, + 564, 536, 263, 536, 263, 502, 537, 537, 537, 537, + 537, 537, 537, 263, 466, 466, 466, 466, 568, 263, + 308, 263, 676, 677, 567, 656, 468, 572, 571, 469, + 574, 628, 792, 626, 470, 610, 569, 502, 471, 792, + 611, 822, 627, 263, 472, 468, 573, 657, 469, 263, + 263, 550, 479, 470, 263, 821, 551, 471, 820, 263, + 676, 677, 263, 472, 475, 475, 475, 475, 475, 475, + + 559, 632, 559, 681, 634, 560, 560, 560, 560, 560, + 560, 560, 575, 819, 575, 818, 635, 576, 576, 576, + 576, 576, 576, 576, 537, 537, 537, 537, 537, 537, + 537, 537, 537, 537, 537, 537, 537, 537, 560, 560, + 560, 560, 560, 560, 560, 477, 630, 629, 682, 683, + 263, 631, 263, 684, 680, 676, 677, 560, 560, 560, + 560, 560, 560, 560, 576, 576, 576, 576, 576, 576, + 576, 477, 658, 658, 658, 658, 658, 658, 658, 263, + 263, 263, 767, 576, 576, 576, 576, 576, 576, 576, + 658, 658, 658, 658, 658, 658, 658, 732, 789, 790, + + 817, 205, 348, 205, 348, 816, 733, 734, 833, 205, + 348, 719, 767, 717, 832, 832, 832, 832, 832, 832, + 832, 440, 440, 832, 832, 832, 832, 832, 832, 832, + 379, 476, 379, 476, 815, 814, 813, 812, 379, 476, + 718, 811, 750, 720, 810, 809, 808, 807, 806, 805, + 804, 803, 802, 801, 800, 780, 22, 22, 22, 22, + 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, + 22, 22, 22, 22, 22, 22, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, + 24, 24, 24, 24, 24, 24, 27, 27, 27, 27, + + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 27, 27, 94, 94, 94, 94, + 94, 94, 94, 94, 94, 94, 94, 94, 94, 94, + 94, 94, 94, 94, 94, 94, 136, 136, 136, 136, + 136, 136, 136, 136, 136, 136, 136, 136, 136, 136, + 136, 136, 136, 136, 136, 136, 170, 170, 170, 170, + 170, 170, 170, 170, 170, 170, 170, 799, 170, 170, + 170, 170, 170, 170, 203, 203, 203, 203, 203, 203, + 207, 207, 207, 798, 797, 767, 207, 796, 795, 794, + 207, 208, 208, 208, 208, 208, 208, 208, 208, 208, + + 208, 208, 793, 208, 208, 208, 208, 208, 208, 210, + 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, + 791, 210, 210, 210, 210, 210, 210, 222, 788, 222, + 787, 222, 222, 786, 785, 222, 784, 222, 222, 223, + 223, 783, 782, 223, 781, 223, 223, 246, 246, 246, + 246, 246, 246, 246, 767, 246, 246, 246, 246, 246, + 246, 246, 246, 246, 246, 779, 246, 247, 247, 247, + 247, 247, 247, 247, 247, 247, 247, 247, 247, 247, + 247, 247, 247, 247, 247, 778, 247, 250, 250, 250, + 250, 250, 250, 250, 250, 250, 250, 250, 250, 250, + + 250, 250, 250, 250, 250, 250, 253, 253, 253, 253, + 253, 253, 253, 253, 253, 253, 253, 777, 253, 253, + 253, 253, 253, 253, 255, 255, 255, 255, 255, 255, + 255, 255, 255, 255, 255, 776, 255, 255, 255, 255, + 255, 255, 264, 775, 264, 774, 264, 773, 264, 264, + 263, 772, 264, 771, 264, 264, 266, 266, 770, 769, + 768, 266, 266, 266, 286, 286, 286, 286, 767, 286, + 286, 286, 286, 286, 286, 765, 286, 286, 286, 286, + 286, 286, 309, 309, 309, 764, 309, 763, 309, 309, + 762, 761, 309, 760, 309, 309, 317, 317, 317, 317, + + 317, 317, 317, 317, 317, 317, 317, 759, 317, 317, + 317, 317, 317, 317, 341, 341, 341, 341, 341, 341, + 341, 341, 341, 341, 341, 758, 341, 341, 341, 341, + 341, 341, 343, 343, 343, 343, 343, 343, 343, 343, + 343, 343, 343, 343, 343, 343, 343, 343, 343, 343, + 343, 343, 222, 757, 222, 756, 222, 222, 755, 754, + 222, 753, 222, 222, 349, 752, 349, 751, 349, 349, + 263, 263, 349, 263, 349, 349, 369, 369, 369, 369, + 369, 369, 369, 369, 369, 369, 369, 369, 369, 369, + 369, 369, 369, 369, 369, 369, 246, 246, 246, 246, + + 246, 246, 246, 749, 246, 246, 246, 246, 246, 246, + 246, 246, 246, 246, 748, 246, 247, 247, 247, 247, + 247, 247, 247, 747, 247, 247, 247, 247, 247, 247, + 247, 247, 247, 247, 250, 250, 250, 250, 250, 250, + 250, 746, 250, 250, 250, 250, 250, 250, 250, 250, + 250, 250, 253, 253, 253, 253, 253, 253, 253, 253, + 253, 253, 253, 745, 253, 253, 253, 253, 253, 253, + 383, 744, 383, 743, 383, 742, 383, 383, 741, 740, + 383, 739, 383, 383, 384, 384, 384, 384, 384, 384, + 738, 384, 384, 384, 384, 384, 384, 384, 384, 384, + + 384, 384, 384, 384, 309, 309, 309, 737, 309, 736, + 309, 309, 735, 731, 309, 730, 309, 309, 317, 317, + 317, 317, 317, 317, 317, 317, 317, 317, 317, 729, + 317, 317, 317, 317, 317, 317, 534, 728, 534, 727, + 534, 534, 726, 725, 534, 724, 534, 534, 675, 675, + 675, 675, 675, 675, 675, 675, 675, 675, 675, 675, + 675, 675, 675, 675, 675, 675, 675, 675, 766, 723, + 766, 766, 766, 766, 766, 766, 766, 766, 766, 766, + 766, 766, 766, 766, 766, 766, 766, 766, 722, 721, + 263, 716, 715, 714, 713, 712, 711, 710, 709, 708, + + 707, 706, 705, 704, 703, 702, 701, 700, 699, 698, + 697, 696, 695, 694, 693, 692, 691, 690, 689, 688, + 687, 686, 685, 263, 263, 263, 263, 263, 679, 678, + 674, 673, 672, 671, 670, 669, 668, 667, 666, 665, + 664, 663, 662, 661, 660, 659, 655, 654, 653, 652, + 651, 650, 649, 648, 647, 646, 645, 644, 643, 642, + 641, 640, 639, 638, 637, 636, 263, 263, 625, 624, + 623, 622, 621, 620, 619, 618, 617, 616, 615, 614, + 613, 612, 609, 608, 607, 606, 605, 604, 603, 602, + 601, 600, 599, 598, 597, 596, 595, 594, 593, 592, + + 591, 590, 589, 588, 587, 584, 583, 582, 581, 580, + 579, 578, 577, 263, 263, 263, 263, 263, 563, 562, + 561, 558, 480, 557, 556, 555, 554, 553, 552, 549, + 548, 547, 546, 545, 544, 543, 542, 541, 540, 539, + 538, 533, 532, 531, 530, 529, 528, 527, 524, 519, + 518, 517, 516, 515, 514, 513, 512, 511, 510, 509, + 508, 504, 503, 474, 501, 263, 484, 382, 483, 482, + 481, 480, 474, 473, 465, 464, 463, 462, 461, 460, + 459, 458, 457, 456, 455, 454, 453, 452, 451, 450, + 449, 837, 319, 318, 443, 439, 438, 430, 429, 422, + + 421, 420, 419, 407, 406, 405, 403, 402, 263, 263, + 263, 382, 263, 374, 373, 254, 252, 248, 372, 368, + 367, 366, 365, 364, 363, 362, 358, 357, 356, 353, + 352, 351, 350, 224, 342, 209, 340, 339, 338, 337, + 336, 335, 332, 331, 330, 329, 328, 323, 322, 321, + 172, 171, 314, 202, 201, 194, 191, 190, 189, 174, + 212, 320, 319, 318, 314, 837, 224, 213, 315, 314, + 267, 263, 211, 254, 243, 242, 238, 237, 236, 235, + 231, 230, 221, 220, 219, 214, 211, 209, 202, 201, + 194, 191, 190, 189, 174, 172, 171, 837, 93, 93, + + 21, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837 + + } ; + +static const short int yy_chk[2293] = + { 0, + 3, 3, 3, 3, 4, 4, 4, 4, 0, 108, + 0, 3, 121, 121, 0, 4, 9, 10, 96, 50, + 50, 50, 50, 50, 50, 17, 17, 17, 17, 95, + 0, 17, 29, 29, 29, 29, 29, 29, 29, 18, + 18, 18, 18, 31, 32, 18, 33, 35, 33, 115, + 39, 55, 55, 55, 55, 33, 93, 31, 0, 3, + 35, 32, 63, 4, 5, 34, 34, 34, 76, 5, + 39, 34, 34, 105, 108, 78, 63, 5, 5, 5, + 5, 5, 5, 5, 17, 78, 76, 9, 10, 96, + 5, 5, 5, 5, 5, 5, 5, 5, 18, 82, + + 79, 5, 95, 5, 79, 82, 82, 5, 5, 41, + 5, 5, 107, 115, 111, 41, 41, 5, 87, 5, + 41, 41, 5, 5, 87, 41, 93, 5, 103, 132, + 105, 110, 103, 87, 5, 5, 109, 5, 112, 5, + 105, 5, 133, 5, 6, 113, 103, 268, 65, 6, + 65, 65, 65, 65, 65, 65, 65, 6, 6, 6, + 6, 6, 6, 6, 118, 122, 122, 118, 145, 153, + 6, 6, 6, 6, 6, 6, 6, 6, 265, 107, + 265, 6, 145, 6, 111, 835, 132, 6, 6, 153, + 6, 6, 110, 140, 140, 140, 140, 6, 109, 6, + + 112, 146, 6, 6, 109, 109, 113, 6, 65, 212, + 212, 133, 244, 244, 6, 6, 65, 6, 146, 6, + 268, 6, 122, 6, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + + 11, 11, 11, 11, 11, 11, 13, 149, 116, 116, + 116, 116, 834, 13, 116, 833, 13, 270, 13, 13, + 149, 13, 13, 13, 13, 13, 13, 13, 123, 123, + 13, 275, 66, 13, 66, 66, 66, 66, 66, 66, + 66, 99, 229, 186, 99, 99, 99, 99, 99, 99, + 99, 147, 229, 147, 830, 99, 124, 124, 281, 106, + 147, 273, 125, 125, 13, 186, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 272, 270, 13, 15, 15, 269, 277, 123, 15, 316, + + 278, 15, 275, 15, 15, 571, 15, 15, 15, 15, + 15, 15, 15, 101, 15, 15, 106, 124, 15, 281, + 106, 273, 119, 101, 125, 101, 101, 101, 101, 101, + 101, 101, 119, 234, 119, 119, 119, 119, 119, 119, + 119, 148, 148, 148, 234, 234, 15, 148, 148, 15, + 15, 293, 269, 15, 15, 15, 309, 309, 15, 15, + 278, 15, 15, 272, 15, 293, 15, 571, 15, 304, + 277, 15, 316, 304, 15, 15, 15, 15, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, + 19, 19, 19, 19, 19, 19, 19, 19, 19, 100, + 114, 143, 143, 143, 143, 143, 143, 143, 829, 100, + 283, 100, 100, 100, 100, 100, 100, 100, 155, 179, + 179, 179, 179, 828, 155, 155, 311, 311, 276, 155, + + 155, 827, 312, 312, 155, 164, 164, 164, 164, 164, + 164, 173, 173, 173, 173, 173, 173, 173, 204, 204, + 204, 204, 204, 204, 206, 206, 206, 206, 217, 217, + 217, 217, 217, 217, 114, 280, 271, 310, 310, 100, + 114, 261, 261, 261, 261, 261, 261, 100, 284, 114, + 120, 283, 120, 215, 215, 215, 215, 215, 215, 215, + 276, 305, 216, 120, 216, 216, 216, 216, 216, 216, + 216, 276, 276, 305, 299, 299, 312, 120, 826, 120, + 120, 489, 120, 313, 313, 120, 386, 120, 120, 120, + 120, 120, 120, 343, 343, 120, 120, 120, 271, 120, + + 299, 369, 369, 256, 280, 825, 300, 120, 271, 284, + 310, 120, 300, 256, 120, 256, 256, 256, 256, 256, + 256, 256, 257, 371, 371, 120, 430, 512, 300, 512, + 430, 385, 257, 824, 257, 257, 257, 257, 257, 257, + 257, 259, 259, 259, 259, 259, 259, 259, 260, 287, + 287, 287, 287, 287, 287, 287, 390, 489, 260, 386, + 260, 260, 260, 260, 260, 260, 260, 392, 387, 389, + 288, 391, 394, 256, 294, 294, 388, 393, 294, 292, + 288, 256, 288, 288, 288, 288, 288, 288, 288, 292, + 294, 303, 385, 292, 344, 344, 344, 344, 292, 345, + + 345, 345, 345, 303, 368, 368, 368, 368, 292, 346, + 346, 346, 346, 346, 346, 346, 397, 390, 303, 347, + 347, 347, 347, 347, 347, 387, 346, 375, 375, 375, + 375, 375, 375, 388, 389, 368, 391, 392, 368, 395, + 398, 399, 393, 368, 400, 401, 394, 368, 377, 823, + 441, 441, 822, 368, 488, 378, 426, 486, 346, 494, + 377, 377, 377, 377, 377, 377, 377, 378, 378, 378, + 378, 378, 378, 409, 427, 426, 492, 377, 409, 442, + 442, 444, 444, 444, 444, 491, 495, 427, 493, 409, + 496, 397, 445, 445, 445, 445, 565, 398, 567, 500, + + 395, 446, 446, 446, 446, 400, 404, 566, 497, 377, + 399, 441, 447, 447, 447, 447, 494, 401, 404, 404, + 404, 404, 404, 404, 404, 466, 466, 466, 466, 488, + 486, 448, 570, 448, 627, 404, 448, 448, 448, 448, + 448, 448, 448, 572, 467, 467, 467, 467, 492, 535, + 535, 573, 623, 623, 491, 600, 466, 496, 495, 466, + 500, 567, 784, 565, 466, 544, 493, 404, 466, 784, + 544, 821, 566, 568, 466, 467, 497, 600, 467, 569, + 626, 467, 475, 467, 635, 820, 467, 467, 819, 632, + 675, 675, 633, 467, 475, 475, 475, 475, 475, 475, + + 478, 570, 478, 627, 572, 478, 478, 478, 478, 478, + 478, 478, 502, 818, 502, 817, 573, 502, 502, 502, + 502, 502, 502, 502, 536, 536, 536, 536, 536, 536, + 536, 537, 537, 537, 537, 537, 537, 537, 559, 559, + 559, 559, 559, 559, 559, 560, 569, 568, 632, 633, + 681, 569, 683, 635, 626, 677, 677, 560, 560, 560, + 560, 560, 560, 560, 575, 575, 575, 575, 575, 575, + 575, 576, 601, 601, 601, 601, 601, 601, 601, 682, + 684, 719, 767, 576, 576, 576, 576, 576, 576, 576, + 658, 658, 658, 658, 658, 658, 658, 696, 780, 780, + + 814, 845, 863, 845, 863, 813, 696, 696, 832, 845, + 863, 683, 780, 681, 831, 831, 831, 831, 831, 831, + 831, 874, 874, 832, 832, 832, 832, 832, 832, 832, + 871, 877, 871, 877, 812, 811, 810, 809, 871, 877, + 682, 808, 719, 684, 807, 806, 805, 804, 802, 801, + 800, 799, 797, 796, 794, 767, 838, 838, 838, 838, + 838, 838, 838, 838, 838, 838, 838, 838, 838, 838, + 838, 838, 838, 838, 838, 838, 839, 839, 839, 839, + 839, 839, 839, 839, 839, 839, 839, 839, 839, 839, + 839, 839, 839, 839, 839, 839, 840, 840, 840, 840, + + 840, 840, 840, 840, 840, 840, 840, 840, 840, 840, + 840, 840, 840, 840, 840, 840, 841, 841, 841, 841, + 841, 841, 841, 841, 841, 841, 841, 841, 841, 841, + 841, 841, 841, 841, 841, 841, 842, 842, 842, 842, + 842, 842, 842, 842, 842, 842, 842, 842, 842, 842, + 842, 842, 842, 842, 842, 842, 843, 843, 843, 843, + 843, 843, 843, 843, 843, 843, 843, 793, 843, 843, + 843, 843, 843, 843, 844, 844, 844, 844, 844, 844, + 846, 846, 846, 792, 791, 790, 846, 788, 787, 786, + 846, 847, 847, 847, 847, 847, 847, 847, 847, 847, + + 847, 847, 785, 847, 847, 847, 847, 847, 847, 848, + 848, 848, 848, 848, 848, 848, 848, 848, 848, 848, + 783, 848, 848, 848, 848, 848, 848, 849, 779, 849, + 778, 849, 849, 777, 774, 849, 771, 849, 849, 850, + 850, 770, 769, 850, 768, 850, 850, 851, 851, 851, + 851, 851, 851, 851, 766, 851, 851, 851, 851, 851, + 851, 851, 851, 851, 851, 765, 851, 852, 852, 852, + 852, 852, 852, 852, 852, 852, 852, 852, 852, 852, + 852, 852, 852, 852, 852, 763, 852, 853, 853, 853, + 853, 853, 853, 853, 853, 853, 853, 853, 853, 853, + + 853, 853, 853, 853, 853, 853, 854, 854, 854, 854, + 854, 854, 854, 854, 854, 854, 854, 762, 854, 854, + 854, 854, 854, 854, 855, 855, 855, 855, 855, 855, + 855, 855, 855, 855, 855, 761, 855, 855, 855, 855, + 855, 855, 856, 754, 856, 752, 856, 751, 856, 856, + 750, 749, 856, 747, 856, 856, 857, 857, 746, 744, + 743, 857, 857, 857, 858, 858, 858, 858, 742, 858, + 858, 858, 858, 858, 858, 741, 858, 858, 858, 858, + 858, 858, 859, 859, 859, 738, 859, 737, 859, 859, + 736, 735, 859, 734, 859, 859, 860, 860, 860, 860, + + 860, 860, 860, 860, 860, 860, 860, 733, 860, 860, + 860, 860, 860, 860, 861, 861, 861, 861, 861, 861, + 861, 861, 861, 861, 861, 732, 861, 861, 861, 861, + 861, 861, 862, 862, 862, 862, 862, 862, 862, 862, + 862, 862, 862, 862, 862, 862, 862, 862, 862, 862, + 862, 862, 864, 730, 864, 729, 864, 864, 728, 727, + 864, 724, 864, 864, 865, 722, 865, 721, 865, 865, + 720, 718, 865, 717, 865, 865, 866, 866, 866, 866, + 866, 866, 866, 866, 866, 866, 866, 866, 866, 866, + 866, 866, 866, 866, 866, 866, 867, 867, 867, 867, + + 867, 867, 867, 716, 867, 867, 867, 867, 867, 867, + 867, 867, 867, 867, 715, 867, 868, 868, 868, 868, + 868, 868, 868, 714, 868, 868, 868, 868, 868, 868, + 868, 868, 868, 868, 869, 869, 869, 869, 869, 869, + 869, 713, 869, 869, 869, 869, 869, 869, 869, 869, + 869, 869, 870, 870, 870, 870, 870, 870, 870, 870, + 870, 870, 870, 712, 870, 870, 870, 870, 870, 870, + 872, 711, 872, 710, 872, 709, 872, 872, 708, 706, + 872, 703, 872, 872, 873, 873, 873, 873, 873, 873, + 702, 873, 873, 873, 873, 873, 873, 873, 873, 873, + + 873, 873, 873, 873, 875, 875, 875, 700, 875, 698, + 875, 875, 697, 695, 875, 694, 875, 875, 876, 876, + 876, 876, 876, 876, 876, 876, 876, 876, 876, 693, + 876, 876, 876, 876, 876, 876, 878, 692, 878, 691, + 878, 878, 690, 689, 878, 688, 878, 878, 879, 879, + 879, 879, 879, 879, 879, 879, 879, 879, 879, 879, + 879, 879, 879, 879, 879, 879, 879, 879, 880, 687, + 880, 880, 880, 880, 880, 880, 880, 880, 880, 880, + 880, 880, 880, 880, 880, 880, 880, 880, 686, 685, + 680, 679, 678, 674, 673, 672, 671, 670, 669, 668, + + 667, 666, 665, 664, 662, 660, 659, 656, 655, 653, + 651, 650, 648, 647, 646, 645, 643, 641, 640, 639, + 638, 637, 636, 634, 631, 630, 629, 628, 625, 624, + 622, 621, 620, 619, 618, 617, 616, 615, 613, 612, + 607, 606, 605, 604, 603, 602, 599, 598, 597, 596, + 595, 594, 592, 591, 590, 589, 588, 587, 586, 585, + 584, 583, 582, 580, 579, 577, 574, 564, 562, 561, + 557, 556, 555, 554, 553, 552, 551, 550, 548, 547, + 546, 545, 543, 542, 541, 540, 533, 532, 531, 530, + 529, 528, 527, 526, 525, 524, 523, 522, 520, 518, + + 517, 516, 515, 514, 513, 511, 510, 509, 508, 507, + 506, 505, 504, 499, 498, 490, 487, 485, 484, 482, + 481, 477, 476, 473, 472, 471, 470, 469, 468, 465, + 462, 461, 460, 459, 458, 457, 456, 454, 453, 451, + 449, 439, 438, 436, 435, 434, 432, 431, 429, 424, + 423, 422, 420, 418, 417, 416, 415, 414, 413, 411, + 410, 408, 407, 403, 402, 396, 384, 383, 382, 381, + 380, 379, 374, 372, 367, 366, 365, 364, 363, 361, + 360, 359, 358, 357, 356, 355, 354, 353, 352, 351, + 350, 341, 318, 317, 315, 307, 306, 302, 301, 298, + + 297, 296, 295, 291, 290, 289, 286, 285, 282, 279, + 274, 266, 264, 255, 254, 253, 252, 248, 245, 243, + 242, 241, 239, 238, 236, 235, 233, 231, 230, 228, + 227, 226, 225, 224, 210, 208, 200, 199, 198, 196, + 193, 192, 185, 184, 183, 181, 180, 177, 175, 174, + 171, 170, 169, 157, 156, 154, 152, 151, 150, 144, + 142, 138, 137, 136, 134, 131, 130, 129, 128, 126, + 104, 102, 98, 97, 89, 88, 86, 85, 84, 83, + 81, 80, 70, 69, 67, 64, 58, 57, 43, 42, + 40, 38, 37, 36, 30, 25, 24, 21, 12, 8, + + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837, 837, 837, 837, 837, 837, 837, 837, 837, + 837, 837 + + } ; + +static yy_state_type yy_last_accepting_state; +static char *yy_last_accepting_cpos; + +/* The intent behind this definition is that it'll catch + * any uses of REJECT which flex missed. + */ +#define REJECT reject_used_but_not_detected +#define yymore() yymore_used_but_not_detected +#define YY_MORE_ADJ 0 +char *yytext; +# line 1 "yaccParser/hslexer.flex" +# line 2 "yaccParser/hslexer.flex" +/********************************************************************** +* * +* * +* LEX grammar for Haskell. * +* ------------------------ * +* * +* (c) Copyright K. Hammond, University of Glasgow, * +* 10th. February 1989 * +* * +* Modification History * +* -------------------- * +* * +* 22/08/91 kh Initial Haskell 1.1 version. * +* 18/10/91 kh Added 'ccall'. * +* 19/11/91 kh Tidied generally. * +* 04/12/91 kh Added Int#. * +* 31/01/92 kh Haskell 1.2 version. * +* 24/04/92 ps Added 'scc'. * +* 03/06/92 kh Changed Infix/Prelude Handling. * +* 23/08/93 jsm Changed to support flex * +* * +* * +* Known Problems: * +* * +* None, any more. * +* * +**********************************************************************/ + +#include "../../includes/config.h" + +#include + +#if defined(STDC_HEADERS) || defined(HAVE_STRING_H) +#include +/* An ANSI string.h and pre-ANSI memory.h might conflict. */ +#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H) +#include +#endif /* not STDC_HEADERS and HAVE_MEMORY_H */ +#define index strchr +#define rindex strrchr +#define bcopy(s, d, n) memcpy ((d), (s), (n)) +#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n)) +#define bzero(s, n) memset ((s), 0, (n)) +#else /* not STDC_HEADERS and not HAVE_STRING_H */ +#include +/* memory.h and strings.h conflict on some systems. */ +#endif /* not STDC_HEADERS and not HAVE_STRING_H */ + +#include "hspincl.h" +#include "hsparser.tab.h" +#include "constants.h" +#include "utils.h" + +/* Our substitute for */ + +#define NCHARS 256 +#define _S 0x1 +#define _D 0x2 +#define _H 0x4 +#define _O 0x8 +#define _C 0x10 + +#define _isconstr(s) (CharTable[*s]&(_C)) +BOOLEAN isconstr PROTO((char *)); /* fwd decl */ + +unsigned char CharTable[NCHARS] = { +/* nul */ 0, 0, 0, 0, 0, 0, 0, 0, +/* bs */ 0, _S, _S, _S, _S, 0, 0, 0, +/* dle */ 0, 0, 0, 0, 0, 0, 0, 0, +/* can */ 0, 0, 0, 0, 0, 0, 0, 0, +/* sp */ _S, 0, 0, 0, 0, 0, 0, 0, +/* '(' */ 0, 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, 0, 0, 0, 0, 0, +/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0, +/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0, +/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0, +/* 'x' */ 0, 0, 0, 0, 0, 0, 0, 0, + +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +}; + +/********************************************************************** +* * +* * +* Declarations * +* * +* * +**********************************************************************/ + +char *input_filename = NULL; /* Always points to a dynamically allocated string */ + +/* + * For my own sanity, things that are not part of the flex skeleton + * have been renamed as hsXXXXX rather than yyXXXXX. --JSM + */ + +int hslineno = 0; /* Line number at end of token */ +int hsplineno = 0; /* Line number at end of previous token */ + +int hscolno = 0; /* Column number at end of token */ +int hspcolno = 0; /* Column number at end of previous token */ +int hsmlcolno = 0; /* Column number for multiple-rule lexemes */ + +int startlineno = 0; /* The line number where something starts */ +int endlineno = 0; /* The line number where something ends */ + +static BOOLEAN noGap = TRUE; /* For checking string gaps */ +static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules */ + +static int nested_comments; /* For counting comment nesting depth */ + +/* Hacky definition of yywrap: see flex doc. + + If we don't do this, then we'll have to get the default + yywrap from the flex library, which is often something + we are not good at locating. This avoids that difficulty. + (Besides which, this is the way old flexes (pre 2.4.x) did it.) + WDP 94/09/05 +*/ +#define yywrap() 1 + +/* Essential forward declarations */ + +static VOID hsnewid PROTO((char *, int)); +static VOID layout_input PROTO((char *, int)); +static VOID cleartext (NO_ARGS); +static VOID addtext PROTO((char *, unsigned)); +static VOID addchar PROTO((char)); +static char *fetchtext PROTO((unsigned *)); + +/* Special file handling for IMPORTS */ +/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */ + +static YY_BUFFER_STATE hsbuf_save = NULL; /* Saved input buffer */ +static char *filename_save; /* File Name */ +static int hslineno_save = 0, /* Line Number */ + hsplineno_save = 0, /* Line Number of Prev. token */ + hscolno_save = 0, /* Indentation */ + hspcolno_save = 0; /* Left Indentation */ +static short icontexts_save = 0; /* Indent Context Level */ + +static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */ +extern BOOLEAN etags; /* that which is saved */ + +extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */ + +static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */ + +extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */ +extern int minAcceptablePragmaVersion; /* see documentation in main.c */ +extern int maxAcceptablePragmaVersion; +extern int thisIfacePragmaVersion; + +static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";" + * inserted before token +ve -- "}" inserted before + * token */ + +short icontexts = 0; /* Which context we're in */ + + + +/* + Table of indentations: right bit indicates whether to use + indentation rules (1 = use rules; 0 = ignore) + + partain: + push one of these "contexts" at every "case" or "where"; the right bit says + whether user supplied braces, etc., or not. pop appropriately (hsendindent). + + ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is + pushed (the "column" for "module", "interface" and EOF). The -1 from the initial + push is shown just below. + +*/ + + +static short indenttab[MAX_CONTEXTS] = {-1}; + +#define INDENTPT (indenttab[icontexts]>>1) +#define INDENTON (indenttab[icontexts]&1) + +#define RETURN(tok) return(Return(tok)) + +#undef YY_DECL +#define YY_DECL int yylex1() + +/* We should not peek at yy_act, but flex calls us even for the internal action + triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but + to support older versions of flex, we'll continue to peek for now. + */ +#define YY_USER_ACTION \ + if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng); + +#if 0/*debug*/ +#undef YY_BREAK +#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break; +#endif + +/* Each time we enter a new start state, we push it onto the state stack. + Note that the rules do not allow us to underflow or overflow the stack. + (At least, they shouldn't.) The maximum expected depth is 4: + 0: Code -> 1: String -> 2: StringEsc -> 3: Comment +*/ +static int StateStack[5]; +static int StateDepth = -1; + +#ifdef HSP_DEBUG +#define PUSH_STATE(n) do {\ + fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\ + StateStack[++StateDepth] = (n); BEGIN(n);} while(0) +#define POP_STATE do {--StateDepth;\ + fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\ + BEGIN(StateStack[StateDepth]);} while(0) +#else +#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0) +#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0) +#endif + +/* The start states are: + Code -- normal Haskell code (principal lexer) + GlaExt -- Haskell code with Glasgow extensions + Comment -- Nested comment processing + String -- Inside a string literal with backslashes + StringEsc -- Immediately following a backslash in a string literal + Char -- Inside a character literal with backslashes + CharEsc -- Immediately following a backslash in a character literal + + Note that the INITIAL state is unused. Also note that these states + are _exclusive_. All rules should be prefixed with an appropriate + list of start states. + */ + +/* Macros after this point can all be overridden by user definitions in + * section 1. + */ + +#ifdef YY_MALLOC_DECL +YY_MALLOC_DECL +#else +#if __STDC__ +#ifndef __cplusplus +#include +#endif +#else +/* Just try to get by without declaring the routines. This will fail + * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int) + * or sizeof(void*) != sizeof(int). + */ +#endif +#endif + +/* Amount of stuff to slurp up with each read. */ +#ifndef YY_READ_BUF_SIZE +#define YY_READ_BUF_SIZE 8192 +#endif + +/* Copy whatever the last rule matched to the standard output. */ + +#ifndef ECHO +/* This used to be an fputs(), but since the string might contain NUL's, + * we now use fwrite(). + */ +#define ECHO (void) fwrite( yytext, yyleng, 1, yyout ) +#endif + +/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL, + * is returned in "result". + */ +#ifndef YY_INPUT +#define YY_INPUT(buf,result,max_size) \ + if ( yy_current_buffer->yy_is_interactive ) \ + { \ + int c = getc( yyin ); \ + result = c == EOF ? 0 : 1; \ + buf[0] = (char) c; \ + } \ + else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \ + && ferror( yyin ) ) \ + YY_FATAL_ERROR( "input in flex scanner failed" ); +#endif + +/* No semi-colon after return; correct usage is to write "yyterminate();" - + * we don't want an extra ';' after the "return" because that will cause + * some compilers to complain about unreachable statements. + */ +#ifndef yyterminate +#define yyterminate() return YY_NULL +#endif + +/* Number of entries by which start-condition stack grows. */ +#ifndef YY_START_STACK_INCR +#define YY_START_STACK_INCR 25 +#endif + +/* Report a fatal error. */ +#ifndef YY_FATAL_ERROR +#define YY_FATAL_ERROR(msg) yy_fatal_error( msg ) +#endif + +/* Default declaration of generated scanner - a define so the user can + * easily add parameters. + */ +#ifndef YY_DECL +#define YY_DECL int yylex YY_PROTO(( void )) +#endif + +/* Code executed at the beginning of each rule, after yytext and yyleng + * have been set up. + */ +#ifndef YY_USER_ACTION +#define YY_USER_ACTION +#endif + +/* Code executed at the end of each rule. */ +#ifndef YY_BREAK +#define YY_BREAK break; +#endif + +YY_DECL + { + register yy_state_type yy_current_state; + register char *yy_cp, *yy_bp; + register int yy_act; + +# line 274 "yaccParser/hslexer.flex" + + + + /* + * Special GHC pragma rules. Do we need a start state for interface files, + * so these won't be matched in source files? --JSM + */ + + + + if ( yy_init ) + { +#ifdef YY_USER_INIT + YY_USER_INIT; +#endif + + if ( ! yy_start ) + yy_start = 1; /* first start state */ + + if ( ! yyin ) + yyin = stdin; + + if ( ! yyout ) + yyout = stdout; + + if ( yy_current_buffer ) + yy_init_buffer( yy_current_buffer, yyin ); + else + yy_current_buffer = + yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_load_buffer_state(); + + yy_init = 0; + } + + while ( 1 ) /* loops until end-of-file is reached */ + { + yy_cp = yy_c_buf_p; + + /* Support of yytext. */ + *yy_cp = yy_hold_char; + + /* yy_bp points to the position in yy_ch_buf of the start of + * the current run. + */ + yy_bp = yy_cp; + + yy_current_state = yy_start; + if ( yy_bp[-1] == '\n' ) + ++yy_current_state; +yy_match: + do + { + register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)]; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 838 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + ++yy_cp; + } + while ( yy_base[yy_current_state] != 2201 ); + +yy_find_action: + yy_act = yy_accept[yy_current_state]; + + YY_DO_BEFORE_ACTION; + + +do_action: /* This label is used only to access EOF actions. */ + + + switch ( yy_act ) + { /* beginning of action switch */ + case 0: /* must back up */ + /* undo the effects of YY_DO_BEFORE_ACTION */ + *yy_cp = yy_hold_char; + yy_cp = yy_last_accepting_cpos; + yy_current_state = yy_last_accepting_state; + goto yy_find_action; + +case 1: +YY_USER_ACTION +# line 283 "yaccParser/hslexer.flex" +{ + char tempf[FILENAME_SIZE]; + sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf); + new_filename(tempf); + hsplineno = hslineno; hscolno = 0; hspcolno = 0; + } + YY_BREAK +case 2: +YY_USER_ACTION +# line 290 "yaccParser/hslexer.flex" +{ + char tempf[FILENAME_SIZE]; + sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf); + new_filename(tempf); + hsplineno = hslineno; hscolno = 0; hspcolno = 0; + } + YY_BREAK +case 3: +YY_USER_ACTION +# line 297 "yaccParser/hslexer.flex" +{ + /* partain: pragma-style line directive */ + char tempf[FILENAME_SIZE]; + sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf); + new_filename(tempf); + hsplineno = hslineno; hscolno = 0; hspcolno = 0; + } + YY_BREAK +case 4: +YY_USER_ACTION +# line 304 "yaccParser/hslexer.flex" +{ + sscanf(yytext+33,"%d ",&thisIfacePragmaVersion); + } + YY_BREAK +case 5: +YY_USER_ACTION +# line 307 "yaccParser/hslexer.flex" +{ + if ( ignorePragmas || + thisIfacePragmaVersion < minAcceptablePragmaVersion || + thisIfacePragmaVersion > maxAcceptablePragmaVersion) { + nested_comments = 1; + PUSH_STATE(Comment); + } else { + PUSH_STATE(GhcPragma); + RETURN(GHC_PRAGMA); + } + } + YY_BREAK +case 6: +YY_USER_ACTION +# line 318 "yaccParser/hslexer.flex" +{ RETURN(NO_PRAGMA); } + YY_BREAK +case 7: +YY_USER_ACTION +# line 319 "yaccParser/hslexer.flex" +{ RETURN(NOINFO_PRAGMA); } + YY_BREAK +case 8: +YY_USER_ACTION +# line 320 "yaccParser/hslexer.flex" +{ RETURN(ABSTRACT_PRAGMA); } + YY_BREAK +case 9: +YY_USER_ACTION +# line 321 "yaccParser/hslexer.flex" +{ RETURN(DEFOREST_PRAGMA); } + YY_BREAK +case 10: +YY_USER_ACTION +# line 322 "yaccParser/hslexer.flex" +{ RETURN(SPECIALISE_PRAGMA); } + YY_BREAK +case 11: +YY_USER_ACTION +# line 323 "yaccParser/hslexer.flex" +{ RETURN(MODNAME_PRAGMA); } + YY_BREAK +case 12: +YY_USER_ACTION +# line 324 "yaccParser/hslexer.flex" +{ RETURN(ARITY_PRAGMA); } + YY_BREAK +case 13: +YY_USER_ACTION +# line 325 "yaccParser/hslexer.flex" +{ RETURN(UPDATE_PRAGMA); } + YY_BREAK +case 14: +YY_USER_ACTION +# line 326 "yaccParser/hslexer.flex" +{ RETURN(STRICTNESS_PRAGMA); } + YY_BREAK +case 15: +YY_USER_ACTION +# line 327 "yaccParser/hslexer.flex" +{ RETURN(KIND_PRAGMA); } + YY_BREAK +case 16: +YY_USER_ACTION +# line 328 "yaccParser/hslexer.flex" +{ RETURN(MAGIC_UNFOLDING_PRAGMA); } + YY_BREAK +case 17: +YY_USER_ACTION +# line 329 "yaccParser/hslexer.flex" +{ RETURN(UNFOLDING_PRAGMA); } + YY_BREAK +case 18: +YY_USER_ACTION +# line 331 "yaccParser/hslexer.flex" +{ RETURN(COCON); } + YY_BREAK +case 19: +YY_USER_ACTION +# line 332 "yaccParser/hslexer.flex" +{ RETURN(COPRIM); } + YY_BREAK +case 20: +YY_USER_ACTION +# line 333 "yaccParser/hslexer.flex" +{ RETURN(COAPP); } + YY_BREAK +case 21: +YY_USER_ACTION +# line 334 "yaccParser/hslexer.flex" +{ RETURN(COTYAPP); } + YY_BREAK +case 22: +YY_USER_ACTION +# line 335 "yaccParser/hslexer.flex" +{ RETURN(CO_ALG_ALTS); } + YY_BREAK +case 23: +YY_USER_ACTION +# line 336 "yaccParser/hslexer.flex" +{ RETURN(CO_PRIM_ALTS); } + YY_BREAK +case 24: +YY_USER_ACTION +# line 337 "yaccParser/hslexer.flex" +{ RETURN(CO_NO_DEFAULT); } + YY_BREAK +case 25: +YY_USER_ACTION +# line 338 "yaccParser/hslexer.flex" +{ RETURN(CO_LETREC); } + YY_BREAK +case 26: +YY_USER_ACTION +# line 340 "yaccParser/hslexer.flex" +{ RETURN(CO_PRELUDE_DICTS_CC); } + YY_BREAK +case 27: +YY_USER_ACTION +# line 341 "yaccParser/hslexer.flex" +{ RETURN(CO_ALL_DICTS_CC); } + YY_BREAK +case 28: +YY_USER_ACTION +# line 342 "yaccParser/hslexer.flex" +{ RETURN(CO_USER_CC); } + YY_BREAK +case 29: +YY_USER_ACTION +# line 343 "yaccParser/hslexer.flex" +{ RETURN(CO_AUTO_CC); } + YY_BREAK +case 30: +YY_USER_ACTION +# line 344 "yaccParser/hslexer.flex" +{ RETURN(CO_DICT_CC); } + YY_BREAK +case 31: +YY_USER_ACTION +# line 346 "yaccParser/hslexer.flex" +{ RETURN(CO_DUPD_CC); } + YY_BREAK +case 32: +YY_USER_ACTION +# line 347 "yaccParser/hslexer.flex" +{ RETURN(CO_CAF_CC); } + YY_BREAK +case 33: +YY_USER_ACTION +# line 349 "yaccParser/hslexer.flex" +{ RETURN(CO_SDSEL_ID); } + YY_BREAK +case 34: +YY_USER_ACTION +# line 350 "yaccParser/hslexer.flex" +{ RETURN(CO_METH_ID); } + YY_BREAK +case 35: +YY_USER_ACTION +# line 351 "yaccParser/hslexer.flex" +{ RETURN(CO_DEFM_ID); } + YY_BREAK +case 36: +YY_USER_ACTION +# line 352 "yaccParser/hslexer.flex" +{ RETURN(CO_DFUN_ID); } + YY_BREAK +case 37: +YY_USER_ACTION +# line 353 "yaccParser/hslexer.flex" +{ RETURN(CO_CONSTM_ID); } + YY_BREAK +case 38: +YY_USER_ACTION +# line 354 "yaccParser/hslexer.flex" +{ RETURN(CO_SPEC_ID); } + YY_BREAK +case 39: +YY_USER_ACTION +# line 355 "yaccParser/hslexer.flex" +{ RETURN(CO_WRKR_ID); } + YY_BREAK +case 40: +YY_USER_ACTION +# line 356 "yaccParser/hslexer.flex" +{ RETURN(CO_ORIG_NM); /* fully-qualified original name*/ } + YY_BREAK +case 41: +YY_USER_ACTION +# line 358 "yaccParser/hslexer.flex" +{ RETURN(UNFOLD_ALWAYS); } + YY_BREAK +case 42: +YY_USER_ACTION +# line 359 "yaccParser/hslexer.flex" +{ RETURN(UNFOLD_IF_ARGS); } + YY_BREAK +case 43: +YY_USER_ACTION +# line 361 "yaccParser/hslexer.flex" +{ RETURN(NOREP_INTEGER); } + YY_BREAK +case 44: +YY_USER_ACTION +# line 362 "yaccParser/hslexer.flex" +{ RETURN(NOREP_RATIONAL); } + YY_BREAK +case 45: +YY_USER_ACTION +# line 363 "yaccParser/hslexer.flex" +{ RETURN(NOREP_STRING); } + YY_BREAK +case 46: +YY_USER_ACTION +# line 365 "yaccParser/hslexer.flex" +{ POP_STATE; RETURN(END_PRAGMA); } + YY_BREAK +case 47: +YY_USER_ACTION +# line 367 "yaccParser/hslexer.flex" +{ + PUSH_STATE(UserPragma); + RETURN(SPECIALISE_UPRAGMA); + } + YY_BREAK +case 48: +YY_USER_ACTION +# line 371 "yaccParser/hslexer.flex" +{ + PUSH_STATE(UserPragma); + RETURN(INLINE_UPRAGMA); + } + YY_BREAK +case 49: +YY_USER_ACTION +# line 375 "yaccParser/hslexer.flex" +{ + PUSH_STATE(UserPragma); + RETURN(MAGIC_UNFOLDING_UPRAGMA); + } + YY_BREAK +case 50: +YY_USER_ACTION +# line 379 "yaccParser/hslexer.flex" +{ + PUSH_STATE(UserPragma); + RETURN(DEFOREST_UPRAGMA); + } + YY_BREAK +case 51: +YY_USER_ACTION +# line 383 "yaccParser/hslexer.flex" +{ + PUSH_STATE(UserPragma); + RETURN(ABSTRACT_UPRAGMA); + } + YY_BREAK +case 52: +YY_USER_ACTION +# line 387 "yaccParser/hslexer.flex" +{ POP_STATE; RETURN(END_UPRAGMA); } + YY_BREAK + + /* + * Haskell keywords. `scc' is actually a Glasgow extension, but it is + * intentionally accepted as a keyword even for normal . + */ + +case 53: +YY_USER_ACTION +# line 396 "yaccParser/hslexer.flex" +{ RETURN(CASE); } + YY_BREAK +case 54: +YY_USER_ACTION +# line 397 "yaccParser/hslexer.flex" +{ RETURN(CLASS); } + YY_BREAK +case 55: +YY_USER_ACTION +# line 398 "yaccParser/hslexer.flex" +{ RETURN(DATA); } + YY_BREAK +case 56: +YY_USER_ACTION +# line 399 "yaccParser/hslexer.flex" +{ RETURN(DEFAULT); } + YY_BREAK +case 57: +YY_USER_ACTION +# line 400 "yaccParser/hslexer.flex" +{ RETURN(DERIVING); } + YY_BREAK +case 58: +YY_USER_ACTION +# line 401 "yaccParser/hslexer.flex" +{ RETURN(ELSE); } + YY_BREAK +case 59: +YY_USER_ACTION +# line 402 "yaccParser/hslexer.flex" +{ RETURN(HIDING); } + YY_BREAK +case 60: +YY_USER_ACTION +# line 403 "yaccParser/hslexer.flex" +{ RETURN(IF); } + YY_BREAK +case 61: +YY_USER_ACTION +# line 404 "yaccParser/hslexer.flex" +{ RETURN(IMPORT); } + YY_BREAK +case 62: +YY_USER_ACTION +# line 405 "yaccParser/hslexer.flex" +{ RETURN(INFIX); } + YY_BREAK +case 63: +YY_USER_ACTION +# line 406 "yaccParser/hslexer.flex" +{ RETURN(INFIXL); } + YY_BREAK +case 64: +YY_USER_ACTION +# line 407 "yaccParser/hslexer.flex" +{ RETURN(INFIXR); } + YY_BREAK +case 65: +YY_USER_ACTION +# line 408 "yaccParser/hslexer.flex" +{ RETURN(INSTANCE); } + YY_BREAK +case 66: +YY_USER_ACTION +# line 409 "yaccParser/hslexer.flex" +{ RETURN(INTERFACE); } + YY_BREAK +case 67: +YY_USER_ACTION +# line 410 "yaccParser/hslexer.flex" +{ RETURN(MODULE); } + YY_BREAK +case 68: +YY_USER_ACTION +# line 411 "yaccParser/hslexer.flex" +{ RETURN(OF); } + YY_BREAK +case 69: +YY_USER_ACTION +# line 412 "yaccParser/hslexer.flex" +{ RETURN(RENAMING); } + YY_BREAK +case 70: +YY_USER_ACTION +# line 413 "yaccParser/hslexer.flex" +{ RETURN(THEN); } + YY_BREAK +case 71: +YY_USER_ACTION +# line 414 "yaccParser/hslexer.flex" +{ RETURN(TO); } + YY_BREAK +case 72: +YY_USER_ACTION +# line 415 "yaccParser/hslexer.flex" +{ RETURN(TYPE); } + YY_BREAK +case 73: +YY_USER_ACTION +# line 416 "yaccParser/hslexer.flex" +{ RETURN(WHERE); } + YY_BREAK +case 74: +YY_USER_ACTION +# line 417 "yaccParser/hslexer.flex" +{ RETURN(IN); } + YY_BREAK +case 75: +YY_USER_ACTION +# line 418 "yaccParser/hslexer.flex" +{ RETURN(LET); } + YY_BREAK +case 76: +YY_USER_ACTION +# line 419 "yaccParser/hslexer.flex" +{ RETURN(CCALL); } + YY_BREAK +case 77: +YY_USER_ACTION +# line 420 "yaccParser/hslexer.flex" +{ RETURN(CCALL_GC); } + YY_BREAK +case 78: +YY_USER_ACTION +# line 421 "yaccParser/hslexer.flex" +{ RETURN(CASM); } + YY_BREAK +case 79: +YY_USER_ACTION +# line 422 "yaccParser/hslexer.flex" +{ RETURN(CASM_GC); } + YY_BREAK +case 80: +YY_USER_ACTION +# line 423 "yaccParser/hslexer.flex" +{ RETURN(SCC); } + YY_BREAK +case 81: +YY_USER_ACTION +# line 424 "yaccParser/hslexer.flex" +{ RETURN(FORALL); } + YY_BREAK + + /* + * Haskell operators. Nothing special about these. + */ + +case 82: +YY_USER_ACTION +# line 432 "yaccParser/hslexer.flex" +{ RETURN(DOTDOT); } + YY_BREAK +case 83: +YY_USER_ACTION +# line 433 "yaccParser/hslexer.flex" +{ RETURN(SEMI); } + YY_BREAK +case 84: +YY_USER_ACTION +# line 434 "yaccParser/hslexer.flex" +{ RETURN(COMMA); } + YY_BREAK +case 85: +YY_USER_ACTION +# line 435 "yaccParser/hslexer.flex" +{ RETURN(VBAR); } + YY_BREAK +case 86: +YY_USER_ACTION +# line 436 "yaccParser/hslexer.flex" +{ RETURN(EQUAL); } + YY_BREAK +case 87: +YY_USER_ACTION +# line 437 "yaccParser/hslexer.flex" +{ RETURN(LARROW); } + YY_BREAK +case 88: +YY_USER_ACTION +# line 438 "yaccParser/hslexer.flex" +{ RETURN(RARROW); } + YY_BREAK +case 89: +YY_USER_ACTION +# line 439 "yaccParser/hslexer.flex" +{ RETURN(DARROW); } + YY_BREAK +case 90: +YY_USER_ACTION +# line 440 "yaccParser/hslexer.flex" +{ RETURN(DCOLON); } + YY_BREAK +case 91: +YY_USER_ACTION +# line 441 "yaccParser/hslexer.flex" +{ RETURN(OPAREN); } + YY_BREAK +case 92: +YY_USER_ACTION +# line 442 "yaccParser/hslexer.flex" +{ RETURN(CPAREN); } + YY_BREAK +case 93: +YY_USER_ACTION +# line 443 "yaccParser/hslexer.flex" +{ RETURN(OBRACK); } + YY_BREAK +case 94: +YY_USER_ACTION +# line 444 "yaccParser/hslexer.flex" +{ RETURN(CBRACK); } + YY_BREAK +case 95: +YY_USER_ACTION +# line 445 "yaccParser/hslexer.flex" +{ RETURN(OCURLY); } + YY_BREAK +case 96: +YY_USER_ACTION +# line 446 "yaccParser/hslexer.flex" +{ RETURN(CCURLY); } + YY_BREAK +case 97: +YY_USER_ACTION +# line 447 "yaccParser/hslexer.flex" +{ RETURN(PLUS); } + YY_BREAK +case 98: +YY_USER_ACTION +# line 448 "yaccParser/hslexer.flex" +{ RETURN(AT); } + YY_BREAK +case 99: +YY_USER_ACTION +# line 449 "yaccParser/hslexer.flex" +{ RETURN(LAMBDA); } + YY_BREAK +case 100: +YY_USER_ACTION +# line 450 "yaccParser/hslexer.flex" +{ RETURN(TYLAMBDA); } + YY_BREAK +case 101: +YY_USER_ACTION +# line 451 "yaccParser/hslexer.flex" +{ RETURN(WILDCARD); } + YY_BREAK +case 102: +YY_USER_ACTION +# line 452 "yaccParser/hslexer.flex" +{ RETURN(BQUOTE); } + YY_BREAK +case 103: +YY_USER_ACTION +# line 453 "yaccParser/hslexer.flex" +{ RETURN(LAZY); } + YY_BREAK +case 104: +YY_USER_ACTION +# line 454 "yaccParser/hslexer.flex" +{ RETURN(MINUS); } + YY_BREAK + + /* + * Integers and (for Glasgow extensions) primitive integers. Note that + * we pass all of the text on to the parser, because flex/C can't handle + * arbitrary precision numbers. + */ + +case 105: +YY_USER_ACTION +# line 464 "yaccParser/hslexer.flex" +{ /* octal */ + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(INTPRIM); + } + YY_BREAK +case 106: +YY_USER_ACTION +# line 468 "yaccParser/hslexer.flex" +{ /* octal */ + yylval.uid = xstrndup(yytext, yyleng); + RETURN(INTEGER); + } + YY_BREAK +case 107: +YY_USER_ACTION +# line 472 "yaccParser/hslexer.flex" +{ /* hexadecimal */ + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(INTPRIM); + } + YY_BREAK +case 108: +YY_USER_ACTION +# line 476 "yaccParser/hslexer.flex" +{ /* hexadecimal */ + yylval.uid = xstrndup(yytext, yyleng); + RETURN(INTEGER); + } + YY_BREAK +case 109: +YY_USER_ACTION +# line 480 "yaccParser/hslexer.flex" +{ + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(INTPRIM); + } + YY_BREAK +case 110: +YY_USER_ACTION +# line 484 "yaccParser/hslexer.flex" +{ + yylval.uid = xstrndup(yytext, yyleng); + RETURN(INTEGER); + } + YY_BREAK + + /* + * Floats and (for Glasgow extensions) primitive floats/doubles. + */ + +case 111: +YY_USER_ACTION +# line 495 "yaccParser/hslexer.flex" +{ + yylval.uid = xstrndup(yytext, yyleng - 2); + RETURN(DOUBLEPRIM); + } + YY_BREAK +case 112: +YY_USER_ACTION +# line 499 "yaccParser/hslexer.flex" +{ + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(FLOATPRIM); + } + YY_BREAK +case 113: +YY_USER_ACTION +# line 503 "yaccParser/hslexer.flex" +{ + yylval.uid = xstrndup(yytext, yyleng); + RETURN(FLOAT); + } + YY_BREAK + + /* + * Funky ``foo'' style C literals for Glasgow extensions + */ + +case 114: +YY_USER_ACTION +# line 514 "yaccParser/hslexer.flex" +{ + hsnewid(yytext + 2, yyleng - 4); + RETURN(CLITLIT); + } + YY_BREAK + + /* + * Identifiers, both variables and operators. The trailing hash is allowed + * for Glasgow extensions. + */ + +case 115: +YY_USER_ACTION +# line 526 "yaccParser/hslexer.flex" +{ hsnewid(yytext, yyleng); RETURN(CONID); } + YY_BREAK +case 116: +YY_USER_ACTION +# line 527 "yaccParser/hslexer.flex" +{ hsnewid(yytext, yyleng); RETURN(CONID); } + YY_BREAK +case 117: +YY_USER_ACTION +# line 528 "yaccParser/hslexer.flex" +{ hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); } + YY_BREAK +case 118: +YY_USER_ACTION +# line 530 "yaccParser/hslexer.flex" +{ + hsnewid(yytext, yyleng); + RETURN(_isconstr(yytext) ? CONID : VARID); + } + YY_BREAK + +/* This SHOULDNAE work in "Code" (sigh) */ + +case 119: +YY_USER_ACTION +# line 537 "yaccParser/hslexer.flex" +{ + if (! (nonstandardFlag || in_interface)) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext); + hsperror(errbuf); + } + hsnewid(yytext, yyleng); + RETURN(isconstr(yytext) ? CONID : VARID); + /* NB: ^^^^^^^^ : not the macro! */ + } + YY_BREAK +case 120: +YY_USER_ACTION +# line 547 "yaccParser/hslexer.flex" +{ + hsnewid(yytext, yyleng); + RETURN(_isconstr(yytext) ? CONID : VARID); + } + YY_BREAK +case 121: +YY_USER_ACTION +# line 551 "yaccParser/hslexer.flex" +{ + hsnewid(yytext, yyleng); + RETURN(_isconstr(yytext) ? CONSYM : VARSYM); + } + YY_BREAK + + /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */ + + /* Because we can make the former well-behaved (we defined them). + + Sadly, the latter is defined by Haskell, which allows such + la-la land constructs as `{-a 900-line comment-} foo`. (WDP 94/12) + */ + +case 122: +YY_USER_ACTION +# line 566 "yaccParser/hslexer.flex" +{ + hsnewid(yytext + 1, yyleng - 2); + RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM); + } + YY_BREAK + + /* + * Character literals. The first form is the quick form, for character + * literals that don't contain backslashes. Literals with backslashes are + * lexed through multiple rules. First, we match the open ' and as many + * normal characters as possible. This puts us into the state, where + * a backslash is legal. Then, we match the backslash and move into the + * state. When we drop out of , we collect more normal + * characters and the close '. We may end up with too many characters, but + * this allows us to easily share the lex rules with strings. Excess characters + * are ignored with a warning. + */ + +case 123: +YY_USER_ACTION +# line 585 "yaccParser/hslexer.flex" +{ + yylval.uhstring = installHstring(1, yytext+1); + RETURN(CHARPRIM); + } + YY_BREAK +case 124: +YY_USER_ACTION +# line 589 "yaccParser/hslexer.flex" +{ + yylval.uhstring = installHstring(1, yytext+1); + RETURN(CHAR); + } + YY_BREAK +case 125: +YY_USER_ACTION +# line 593 "yaccParser/hslexer.flex" +{char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "'' is not a valid character (or string) literal\n"); + hsperror(errbuf); + } + YY_BREAK +case 126: +YY_USER_ACTION +# line 597 "yaccParser/hslexer.flex" +{ + hsmlcolno = hspcolno; + cleartext(); + addtext(yytext+1, yyleng-1); + PUSH_STATE(Char); + } + YY_BREAK +case 127: +YY_USER_ACTION +# line 603 "yaccParser/hslexer.flex" +{ + unsigned length; + char *text; + + addtext(yytext, yyleng - 2); + text = fetchtext(&length); + + if (! (nonstandardFlag || in_interface)) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text); + hsperror(errbuf); + } + + if (length > 1) { + fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) text, length); + fputs("' too long\n", stderr); + hsperror(""); + } + yylval.uhstring = installHstring(1, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(CHARPRIM); + } + YY_BREAK +case 128: +YY_USER_ACTION +# line 628 "yaccParser/hslexer.flex" +{ + unsigned length; + char *text; + + addtext(yytext, yyleng - 1); + text = fetchtext(&length); + + if (length > 1) { + fprintf(stderr, "\"%s\", line %d, column %d: Character literal '", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) text, length); + fputs("' too long\n", stderr); + hsperror(""); + } + yylval.uhstring = installHstring(1, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(CHAR); + } + YY_BREAK +case 129: +YY_USER_ACTION +# line 647 "yaccParser/hslexer.flex" +{ addtext(yytext, yyleng); } + YY_BREAK + + /* + * String literals. The first form is the quick form, for string literals + * that don't contain backslashes. Literals with backslashes are lexed + * through multiple rules. First, we match the open " and as many normal + * characters as possible. This puts us into the state, where + * a backslash is legal. Then, we match the backslash and move into the + * state. When we drop out of , we collect more normal + * characters, moving back and forth between and as more + * backslashes are encountered. (We may even digress into mode if we + * find a comment in a gap between backslashes.) Finally, we read the last chunk + * of normal characters and the close ". + */ + +case 130: +YY_USER_ACTION +# line 665 "yaccParser/hslexer.flex" +{ + yylval.uhstring = installHstring(yyleng-3, yytext+1); + /* the -3 accounts for the " on front, "# on the end */ + RETURN(STRINGPRIM); + } + YY_BREAK +case 131: +YY_USER_ACTION +# line 670 "yaccParser/hslexer.flex" +{ + yylval.uhstring = installHstring(yyleng-2, yytext+1); + RETURN(STRING); + } + YY_BREAK +case 132: +YY_USER_ACTION +# line 674 "yaccParser/hslexer.flex" +{ + hsmlcolno = hspcolno; + cleartext(); + addtext(yytext+1, yyleng-1); + PUSH_STATE(String); + } + YY_BREAK +case 133: +YY_USER_ACTION +# line 680 "yaccParser/hslexer.flex" +{ + unsigned length; + char *text; + + addtext(yytext, yyleng-2); + text = fetchtext(&length); + + if (! (nonstandardFlag || in_interface)) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text); + hsperror(errbuf); + } + + yylval.uhstring = installHstring(length, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(STRINGPRIM); + } + YY_BREAK +case 134: +YY_USER_ACTION +# line 698 "yaccParser/hslexer.flex" +{ + unsigned length; + char *text; + + addtext(yytext, yyleng-1); + text = fetchtext(&length); + + yylval.uhstring = installHstring(length, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(STRING); + } + YY_BREAK +case 135: +YY_USER_ACTION +# line 710 "yaccParser/hslexer.flex" +{ addtext(yytext, yyleng); } + YY_BREAK + + /* + * Character and string escapes are roughly the same, but strings have the + * extra `\&' sequence which is not allowed for characters. Also, comments + * are allowed in the state. (See the comment section much + * further down.) + * + * NB: Backslashes and tabs are stored in strings as themselves. + * But if we print them (in printtree.c), they must go out as + * "\\\\" and "\\t" respectively. (This is because of the bogus + * intermediate format that the parser produces. It uses '\t' fpr end of + * string, so it needs to be able to escape tabs, which means that it + * also needs to be able to escape the escape character ('\\'). Sigh. + */ + +case 136: +YY_USER_ACTION +# line 728 "yaccParser/hslexer.flex" +{ PUSH_STATE(CharEsc); } + YY_BREAK +case 137: +YY_USER_ACTION +# line 729 "yaccParser/hslexer.flex" +/* Ignore */ ; + YY_BREAK +case 138: +YY_USER_ACTION +# line 730 "yaccParser/hslexer.flex" +{ PUSH_STATE(StringEsc); noGap = TRUE; } + YY_BREAK +case 139: +YY_USER_ACTION +# line 732 "yaccParser/hslexer.flex" +{ addchar(*yytext); POP_STATE; } + YY_BREAK +case 140: +YY_USER_ACTION +# line 733 "yaccParser/hslexer.flex" +{ if (noGap) { addchar(*yytext); } POP_STATE; } + YY_BREAK +case 141: +YY_USER_ACTION +# line 735 "yaccParser/hslexer.flex" +{ addchar(*yytext); POP_STATE; } + YY_BREAK +case 142: +YY_USER_ACTION +# line 736 "yaccParser/hslexer.flex" +{ addchar('\000'); POP_STATE; } + YY_BREAK +case 143: +YY_USER_ACTION +# line 737 "yaccParser/hslexer.flex" +{ addchar('\001'); POP_STATE; } + YY_BREAK +case 144: +YY_USER_ACTION +# line 738 "yaccParser/hslexer.flex" +{ addchar('\002'); POP_STATE; } + YY_BREAK +case 145: +YY_USER_ACTION +# line 739 "yaccParser/hslexer.flex" +{ addchar('\003'); POP_STATE; } + YY_BREAK +case 146: +YY_USER_ACTION +# line 740 "yaccParser/hslexer.flex" +{ addchar('\004'); POP_STATE; } + YY_BREAK +case 147: +YY_USER_ACTION +# line 741 "yaccParser/hslexer.flex" +{ addchar('\005'); POP_STATE; } + YY_BREAK +case 148: +YY_USER_ACTION +# line 742 "yaccParser/hslexer.flex" +{ addchar('\006'); POP_STATE; } + YY_BREAK +case 149: +# line 744 "yaccParser/hslexer.flex" +case 150: +YY_USER_ACTION +# line 744 "yaccParser/hslexer.flex" +{ addchar('\007'); POP_STATE; } + YY_BREAK +case 151: +# line 746 "yaccParser/hslexer.flex" +case 152: +YY_USER_ACTION +# line 746 "yaccParser/hslexer.flex" +{ addchar('\010'); POP_STATE; } + YY_BREAK +case 153: +# line 748 "yaccParser/hslexer.flex" +case 154: +YY_USER_ACTION +# line 748 "yaccParser/hslexer.flex" +{ addchar('\011'); POP_STATE; } + YY_BREAK +case 155: +# line 750 "yaccParser/hslexer.flex" +case 156: +YY_USER_ACTION +# line 750 "yaccParser/hslexer.flex" +{ addchar('\012'); POP_STATE; } + YY_BREAK +case 157: +# line 752 "yaccParser/hslexer.flex" +case 158: +YY_USER_ACTION +# line 752 "yaccParser/hslexer.flex" +{ addchar('\013'); POP_STATE; } + YY_BREAK +case 159: +# line 754 "yaccParser/hslexer.flex" +case 160: +YY_USER_ACTION +# line 754 "yaccParser/hslexer.flex" +{ addchar('\014'); POP_STATE; } + YY_BREAK +case 161: +# line 756 "yaccParser/hslexer.flex" +case 162: +YY_USER_ACTION +# line 756 "yaccParser/hslexer.flex" +{ addchar('\015'); POP_STATE; } + YY_BREAK +case 163: +YY_USER_ACTION +# line 757 "yaccParser/hslexer.flex" +{ addchar('\016'); POP_STATE; } + YY_BREAK +case 164: +YY_USER_ACTION +# line 758 "yaccParser/hslexer.flex" +{ addchar('\017'); POP_STATE; } + YY_BREAK +case 165: +YY_USER_ACTION +# line 759 "yaccParser/hslexer.flex" +{ addchar('\020'); POP_STATE; } + YY_BREAK +case 166: +YY_USER_ACTION +# line 760 "yaccParser/hslexer.flex" +{ addchar('\021'); POP_STATE; } + YY_BREAK +case 167: +YY_USER_ACTION +# line 761 "yaccParser/hslexer.flex" +{ addchar('\022'); POP_STATE; } + YY_BREAK +case 168: +YY_USER_ACTION +# line 762 "yaccParser/hslexer.flex" +{ addchar('\023'); POP_STATE; } + YY_BREAK +case 169: +YY_USER_ACTION +# line 763 "yaccParser/hslexer.flex" +{ addchar('\024'); POP_STATE; } + YY_BREAK +case 170: +YY_USER_ACTION +# line 764 "yaccParser/hslexer.flex" +{ addchar('\025'); POP_STATE; } + YY_BREAK +case 171: +YY_USER_ACTION +# line 765 "yaccParser/hslexer.flex" +{ addchar('\026'); POP_STATE; } + YY_BREAK +case 172: +YY_USER_ACTION +# line 766 "yaccParser/hslexer.flex" +{ addchar('\027'); POP_STATE; } + YY_BREAK +case 173: +YY_USER_ACTION +# line 767 "yaccParser/hslexer.flex" +{ addchar('\030'); POP_STATE; } + YY_BREAK +case 174: +YY_USER_ACTION +# line 768 "yaccParser/hslexer.flex" +{ addchar('\031'); POP_STATE; } + YY_BREAK +case 175: +YY_USER_ACTION +# line 769 "yaccParser/hslexer.flex" +{ addchar('\032'); POP_STATE; } + YY_BREAK +case 176: +YY_USER_ACTION +# line 770 "yaccParser/hslexer.flex" +{ addchar('\033'); POP_STATE; } + YY_BREAK +case 177: +YY_USER_ACTION +# line 771 "yaccParser/hslexer.flex" +{ addchar('\034'); POP_STATE; } + YY_BREAK +case 178: +YY_USER_ACTION +# line 772 "yaccParser/hslexer.flex" +{ addchar('\035'); POP_STATE; } + YY_BREAK +case 179: +YY_USER_ACTION +# line 773 "yaccParser/hslexer.flex" +{ addchar('\036'); POP_STATE; } + YY_BREAK +case 180: +YY_USER_ACTION +# line 774 "yaccParser/hslexer.flex" +{ addchar('\037'); POP_STATE; } + YY_BREAK +case 181: +YY_USER_ACTION +# line 775 "yaccParser/hslexer.flex" +{ addchar('\040'); POP_STATE; } + YY_BREAK +case 182: +YY_USER_ACTION +# line 776 "yaccParser/hslexer.flex" +{ addchar('\177'); POP_STATE; } + YY_BREAK +case 183: +YY_USER_ACTION +# line 777 "yaccParser/hslexer.flex" +{ char c = yytext[1] - '@'; addchar(c); POP_STATE; } + YY_BREAK +case 184: +YY_USER_ACTION +# line 778 "yaccParser/hslexer.flex" +{ + int i = strtol(yytext, NULL, 10); + if (i < NCHARS) { + addchar((char) i); + } else { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", + yytext); + hsperror(errbuf); + } + POP_STATE; + } + YY_BREAK +case 185: +YY_USER_ACTION +# line 790 "yaccParser/hslexer.flex" +{ + int i = strtol(yytext + 1, NULL, 8); + if (i < NCHARS) { + addchar((char) i); + } else { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", + yytext); + hsperror(errbuf); + } + POP_STATE; + } + YY_BREAK +case 186: +YY_USER_ACTION +# line 802 "yaccParser/hslexer.flex" +{ + int i = strtol(yytext + 1, NULL, 16); + if (i < NCHARS) { + addchar((char) i); + } else { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", + yytext); + hsperror(errbuf); + } + POP_STATE; + } + YY_BREAK + + /* + * Simple comments and whitespace. Normally, we would just ignore these, but + * in case we're processing a string escape, we need to note that we've seen + * a gap. + */ + +case 187: +# line 824 "yaccParser/hslexer.flex" +case 188: +YY_USER_ACTION +# line 824 "yaccParser/hslexer.flex" +{ noGap = FALSE; } + YY_BREAK + + /* + * Nested comments. The major complication here is in trying to match the + * longest lexemes possible, for better performance. (See the flex document.) + * That's why the rules look so bizarre. + */ + +case 189: +YY_USER_ACTION +# line 834 "yaccParser/hslexer.flex" +{ + noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment); + } + YY_BREAK +case 190: +# line 839 "yaccParser/hslexer.flex" +case 191: +# line 840 "yaccParser/hslexer.flex" +case 192: +YY_USER_ACTION +# line 840 "yaccParser/hslexer.flex" +; + YY_BREAK +case 193: +YY_USER_ACTION +# line 841 "yaccParser/hslexer.flex" +{ nested_comments++; } + YY_BREAK +case 194: +YY_USER_ACTION +# line 842 "yaccParser/hslexer.flex" +{ if (--nested_comments == 0) POP_STATE; } + YY_BREAK +case 195: +YY_USER_ACTION +# line 843 "yaccParser/hslexer.flex" +; + YY_BREAK + + /* + * Illegal characters. This used to be a single rule, but we might as well + * pass on as much information as we have, so now we indicate our state in + * the error message. + */ + +case 196: +YY_USER_ACTION +# line 853 "yaccParser/hslexer.flex" +{ + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("'\n", stderr); + hsperror(""); + } + YY_BREAK +case 197: +YY_USER_ACTION +# line 860 "yaccParser/hslexer.flex" +{ + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("' in a character literal\n", stderr); + hsperror(""); + } + YY_BREAK +case 198: +YY_USER_ACTION +# line 867 "yaccParser/hslexer.flex" +{ + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("'\n", stderr); + hsperror(""); + } + YY_BREAK +case 199: +YY_USER_ACTION +# line 874 "yaccParser/hslexer.flex" +{ if (nonstandardFlag) { + addtext(yytext, yyleng); + } else { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("' in a string literal\n", stderr); + hsperror(""); + } + } + YY_BREAK +case 200: +YY_USER_ACTION +# line 884 "yaccParser/hslexer.flex" +{ + if (noGap) { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("'\n", stderr); + hsperror(""); + } else { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("' in a string gap\n", stderr); + hsperror(""); + } + } + YY_BREAK + + /* + * End of file. In any sub-state, this is an error. However, for the primary + * and states, this is perfectly normal. We just return an EOF + * and let the yylex() wrapper deal with whatever has to be done next (e.g. + * adding virtual close curlies, or closing an interface and returning to the + * primary source file. + * + * Note that flex does not call YY_USER_ACTION for <> rules. Hence the + * line/column advancement has to be done by hand. + */ + +case YY_STATE_EOF(Char): +case YY_STATE_EOF(CharEsc): +# line 913 "yaccParser/hslexer.flex" +{ + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated character literal"); + } + YY_BREAK +case YY_STATE_EOF(Comment): +# line 917 "yaccParser/hslexer.flex" +{ + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated comment"); + } + YY_BREAK +case YY_STATE_EOF(String): +case YY_STATE_EOF(StringEsc): +# line 921 "yaccParser/hslexer.flex" +{ + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated string literal"); + } + YY_BREAK +case YY_STATE_EOF(GhcPragma): +# line 925 "yaccParser/hslexer.flex" +{ + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated interface pragma"); + } + YY_BREAK +case YY_STATE_EOF(UserPragma): +# line 929 "yaccParser/hslexer.flex" +{ + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated user-specified pragma"); + } + YY_BREAK +case YY_STATE_EOF(Code): +case YY_STATE_EOF(GlaExt): +# line 933 "yaccParser/hslexer.flex" +{ hsplineno = hslineno; hspcolno = hscolno; return(EOF); } + YY_BREAK +case 201: +YY_USER_ACTION +# line 935 "yaccParser/hslexer.flex" +YY_FATAL_ERROR( "flex scanner jammed" ); + YY_BREAK +case YY_STATE_EOF(INITIAL): + yyterminate(); + + case YY_END_OF_BUFFER: + { + /* Amount of text matched not including the EOB char. */ + int yy_amount_of_matched_text = yy_cp - yytext_ptr - 1; + + /* Undo the effects of YY_DO_BEFORE_ACTION. */ + *yy_cp = yy_hold_char; + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW ) + { + /* We're scanning a new file or input source. It's + * possible that this happened because the user + * just pointed yyin at a new source and called + * yylex(). If so, then we have to assure + * consistency between yy_current_buffer and our + * globals. Here is the right place to do so, because + * this is the first action (other than possibly a + * back-up) that will match for the new input source. + */ + yy_n_chars = yy_current_buffer->yy_n_chars; + yy_current_buffer->yy_input_file = yyin; + yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL; + } + + /* Note that here we test for yy_c_buf_p "<=" to the position + * of the first EOB in the buffer, since yy_c_buf_p will + * already have been incremented past the NUL character + * (since all states make transitions on EOB to the + * end-of-buffer state). Contrast this with the test + * in input(). + */ + if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + { /* This was really a NUL. */ + yy_state_type yy_next_state; + + yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + /* Okay, we're now positioned to make the NUL + * transition. We couldn't have + * yy_get_previous_state() go ahead and do it + * for us because it doesn't know how to deal + * with the possibility of jamming (and we don't + * want to build jamming into it because then it + * will run more slowly). + */ + + yy_next_state = yy_try_NUL_trans( yy_current_state ); + + yy_bp = yytext_ptr + YY_MORE_ADJ; + + if ( yy_next_state ) + { + /* Consume the NUL. */ + yy_cp = ++yy_c_buf_p; + yy_current_state = yy_next_state; + goto yy_match; + } + + else + { + yy_cp = yy_c_buf_p; + goto yy_find_action; + } + } + + else switch ( yy_get_next_buffer() ) + { + case EOB_ACT_END_OF_FILE: + { + yy_did_buffer_switch_on_eof = 0; + + if ( yywrap() ) + { + /* Note: because we've taken care in + * yy_get_next_buffer() to have set up + * yytext, we can now set up + * yy_c_buf_p so that if some total + * hoser (like flex itself) wants to + * call the scanner after we return the + * YY_NULL, it'll still work - another + * YY_NULL will get returned. + */ + yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; + + yy_act = YY_STATE_EOF(YY_START); + goto do_action; + } + + else + { + if ( ! yy_did_buffer_switch_on_eof ) + YY_NEW_FILE; + } + break; + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = + yytext_ptr + yy_amount_of_matched_text; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_match; + + case EOB_ACT_LAST_MATCH: + yy_c_buf_p = + &yy_current_buffer->yy_ch_buf[yy_n_chars]; + + yy_current_state = yy_get_previous_state(); + + yy_cp = yy_c_buf_p; + yy_bp = yytext_ptr + YY_MORE_ADJ; + goto yy_find_action; + } + break; + } + + default: + YY_FATAL_ERROR( + "fatal flex scanner internal error--no action found" ); + } /* end of action switch */ + } /* end of scanning one token */ + } /* end of yylex */ + + +/* yy_get_next_buffer - try to read in a new buffer + * + * Returns a code representing an action: + * EOB_ACT_LAST_MATCH - + * EOB_ACT_CONTINUE_SCAN - continue scanning from current position + * EOB_ACT_END_OF_FILE - end of file + */ + +static int yy_get_next_buffer() + { + register char *dest = yy_current_buffer->yy_ch_buf; + register char *source = yytext_ptr - 1; /* copy prev. char, too */ + register int number_to_move, i; + int ret_val; + + if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] ) + YY_FATAL_ERROR( + "fatal flex scanner internal error--end of buffer missed" ); + + if ( yy_current_buffer->yy_fill_buffer == 0 ) + { /* Don't try to fill the buffer, so this is an EOF. */ + if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 ) + { + /* We matched a singled characater, the EOB, so + * treat this as a final EOF. + */ + return EOB_ACT_END_OF_FILE; + } + + else + { + /* We matched some text prior to the EOB, first + * process it. + */ + return EOB_ACT_LAST_MATCH; + } + } + + /* Try to read more data. */ + + /* First move last chars to start of buffer. */ + number_to_move = yy_c_buf_p - yytext_ptr; + + for ( i = 0; i < number_to_move; ++i ) + *(dest++) = *(source++); + + if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING ) + /* don't do the read, it's not guaranteed to return an EOF, + * just force an EOF + */ + yy_n_chars = 0; + + else + { + int num_to_read = + yy_current_buffer->yy_buf_size - number_to_move - 1; + + while ( num_to_read <= 0 ) + { /* Not enough room in the buffer - grow it. */ +#ifdef YY_USES_REJECT + YY_FATAL_ERROR( +"input buffer overflow, can't enlarge buffer because scanner uses REJECT" ); +#else + + /* just a shorter name for the current buffer */ + YY_BUFFER_STATE b = yy_current_buffer; + + int yy_c_buf_p_offset = yy_c_buf_p - b->yy_ch_buf; + + b->yy_buf_size *= 2; + b->yy_ch_buf = (char *) + yy_flex_realloc( (void *) b->yy_ch_buf, + b->yy_buf_size ); + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( + "fatal error - scanner input buffer overflow" ); + + yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset]; + + num_to_read = yy_current_buffer->yy_buf_size - + number_to_move - 1; +#endif + } + + if ( num_to_read > YY_READ_BUF_SIZE ) + num_to_read = YY_READ_BUF_SIZE; + + /* Read in more data. */ + YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]), + yy_n_chars, num_to_read ); + } + + if ( yy_n_chars == 0 ) + { + if ( number_to_move - YY_MORE_ADJ == 1 ) + { + ret_val = EOB_ACT_END_OF_FILE; + yyrestart( yyin ); + } + + else + { + ret_val = EOB_ACT_LAST_MATCH; + yy_current_buffer->yy_buffer_status = + YY_BUFFER_EOF_PENDING; + } + } + + else + ret_val = EOB_ACT_CONTINUE_SCAN; + + yy_n_chars += number_to_move; + yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; + yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; + + /* yytext begins at the second character in yy_ch_buf; the first + * character is the one which preceded it before reading in the latest + * buffer; it needs to be kept around in case it's a newline, so + * yy_get_previous_state() will have with '^' rules active. + */ + + yytext_ptr = &yy_current_buffer->yy_ch_buf[1]; + + return ret_val; + } + + +/* yy_get_previous_state - get the state just before the EOB char was reached */ + +static yy_state_type yy_get_previous_state() + { + register yy_state_type yy_current_state; + register char *yy_cp; + + register char *yy_bp = yytext_ptr; + + yy_current_state = yy_start; + if ( yy_bp[-1] == '\n' ) + ++yy_current_state; + + for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp ) + { + register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1); + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 838 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + } + + return yy_current_state; + } + + +/* yy_try_NUL_trans - try to make a transition on the NUL character + * + * synopsis + * next_state = yy_try_NUL_trans( current_state ); + */ + +#ifdef YY_USE_PROTOS +static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state ) +#else +static yy_state_type yy_try_NUL_trans( yy_current_state ) +yy_state_type yy_current_state; +#endif + { + register int yy_is_jam; + register char *yy_cp = yy_c_buf_p; + + register YY_CHAR yy_c = 1; + if ( yy_accept[yy_current_state] ) + { + yy_last_accepting_state = yy_current_state; + yy_last_accepting_cpos = yy_cp; + } + while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state ) + { + yy_current_state = (int) yy_def[yy_current_state]; + if ( yy_current_state >= 838 ) + yy_c = yy_meta[(unsigned int) yy_c]; + } + yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c]; + yy_is_jam = (yy_current_state == 837); + + return yy_is_jam ? 0 : yy_current_state; + } + + +#ifdef YY_USE_PROTOS +static void yyunput( int c, register char *yy_bp ) +#else +static void yyunput( c, yy_bp ) +int c; +register char *yy_bp; +#endif + { + register char *yy_cp = yy_c_buf_p; + + /* undo effects of setting up yytext */ + *yy_cp = yy_hold_char; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + { /* need to shift things up to make room */ + /* +2 for EOB chars. */ + register int number_to_move = yy_n_chars + 2; + register char *dest = &yy_current_buffer->yy_ch_buf[ + yy_current_buffer->yy_buf_size + 2]; + register char *source = + &yy_current_buffer->yy_ch_buf[number_to_move]; + + while ( source > yy_current_buffer->yy_ch_buf ) + *--dest = *--source; + + yy_cp += dest - source; + yy_bp += dest - source; + yy_n_chars = yy_current_buffer->yy_buf_size; + + if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 ) + YY_FATAL_ERROR( "flex scanner push-back overflow" ); + } + + if ( yy_cp > yy_bp && yy_cp[-1] == '\n' ) + yy_cp[-2] = '\n'; + + *--yy_cp = (char) c; + + + /* Note: the formal parameter *must* be called "yy_bp" for this + * macro to now work correctly. + */ + YY_DO_BEFORE_ACTION; /* set up yytext again */ + } + + +#ifdef __cplusplus +static int yyinput() +#else +static int input() +#endif + { + int c; + + *yy_c_buf_p = yy_hold_char; + + if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) + { + /* yy_c_buf_p now points to the character we want to return. + * If this occurs *before* the EOB characters, then it's a + * valid NUL; if not, then we've hit the end of the buffer. + */ + if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] ) + /* This was really a NUL. */ + *yy_c_buf_p = '\0'; + + else + { /* need more input */ + yytext_ptr = yy_c_buf_p; + ++yy_c_buf_p; + + switch ( yy_get_next_buffer() ) + { + case EOB_ACT_END_OF_FILE: + { + if ( yywrap() ) + { + yy_c_buf_p = + yytext_ptr + YY_MORE_ADJ; + return EOF; + } + + YY_NEW_FILE; +#ifdef __cplusplus + return yyinput(); +#else + return input(); +#endif + } + + case EOB_ACT_CONTINUE_SCAN: + yy_c_buf_p = yytext_ptr + YY_MORE_ADJ; + break; + + case EOB_ACT_LAST_MATCH: +#ifdef __cplusplus + YY_FATAL_ERROR( + "unexpected last match in yyinput()" ); +#else + YY_FATAL_ERROR( + "unexpected last match in input()" ); +#endif + } + } + } + + c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */ + *yy_c_buf_p = '\0'; /* preserve yytext */ + yy_hold_char = *++yy_c_buf_p; + + return c; + } + + +#ifdef YY_USE_PROTOS +void yyrestart( FILE *input_file ) +#else +void yyrestart( input_file ) +FILE *input_file; +#endif + { + if ( ! yy_current_buffer ) + yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); + + yy_init_buffer( yy_current_buffer, input_file ); + yy_load_buffer_state(); + } + + +#ifdef YY_USE_PROTOS +void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer ) +#else +void yy_switch_to_buffer( new_buffer ) +YY_BUFFER_STATE new_buffer; +#endif + { + if ( yy_current_buffer == new_buffer ) + return; + + if ( yy_current_buffer ) + { + /* Flush out information for old buffer. */ + *yy_c_buf_p = yy_hold_char; + yy_current_buffer->yy_buf_pos = yy_c_buf_p; + yy_current_buffer->yy_n_chars = yy_n_chars; + } + + yy_current_buffer = new_buffer; + yy_load_buffer_state(); + + /* We don't actually know whether we did this switch during + * EOF (yywrap()) processing, but the only time this flag + * is looked at is after yywrap() is called, so it's safe + * to go ahead and always set it. + */ + yy_did_buffer_switch_on_eof = 1; + } + + +#ifdef YY_USE_PROTOS +void yy_load_buffer_state( void ) +#else +void yy_load_buffer_state() +#endif + { + yy_n_chars = yy_current_buffer->yy_n_chars; + yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos; + yyin = yy_current_buffer->yy_input_file; + yy_hold_char = *yy_c_buf_p; + } + + +#ifdef YY_USE_PROTOS +YY_BUFFER_STATE yy_create_buffer( FILE *file, int size ) +#else +YY_BUFFER_STATE yy_create_buffer( file, size ) +FILE *file; +int size; +#endif + { + YY_BUFFER_STATE b; + + b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) ); + + if ( ! b ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + b->yy_buf_size = size; + + /* yy_ch_buf has to be 2 characters longer than the size given because + * we need to put in 2 end-of-buffer characters. + */ + b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 ); + + if ( ! b->yy_ch_buf ) + YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" ); + + yy_init_buffer( b, file ); + + return b; + } + + +#ifdef YY_USE_PROTOS +void yy_delete_buffer( YY_BUFFER_STATE b ) +#else +void yy_delete_buffer( b ) +YY_BUFFER_STATE b; +#endif + { + if ( b == yy_current_buffer ) + yy_current_buffer = (YY_BUFFER_STATE) 0; + + yy_flex_free( (void *) b->yy_ch_buf ); + yy_flex_free( (void *) b ); + } + + +#ifdef YY_USE_PROTOS +void yy_init_buffer( YY_BUFFER_STATE b, FILE *file ) +#else +void yy_init_buffer( b, file ) +YY_BUFFER_STATE b; +FILE *file; +#endif + { + b->yy_input_file = file; + + /* We put in the '\n' and start reading from [1] so that an + * initial match-at-newline will be true. + */ + + b->yy_ch_buf[0] = '\n'; + b->yy_n_chars = 1; + + /* We always need two end-of-buffer characters. The first causes + * a transition to the end-of-buffer state. The second causes + * a jam in that state. + */ + b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR; + b->yy_ch_buf[2] = YY_END_OF_BUFFER_CHAR; + + b->yy_buf_pos = &b->yy_ch_buf[1]; + + b->yy_is_interactive = file ? isatty( fileno(file) ) : 0; + + b->yy_fill_buffer = 1; + + b->yy_buffer_status = YY_BUFFER_NEW; + } + + +#ifdef YY_USE_PROTOS +static void yy_push_state( int new_state ) +#else +static void yy_push_state( new_state ) +int new_state; +#endif + { + if ( yy_start_stack_ptr >= yy_start_stack_depth ) + { + int new_size; + + yy_start_stack_depth += YY_START_STACK_INCR; + new_size = yy_start_stack_depth * sizeof( int ); + + if ( ! yy_start_stack ) + yy_start_stack = (int *) yy_flex_alloc( new_size ); + + else + yy_start_stack = (int *) yy_flex_realloc( + (void *) yy_start_stack, new_size ); + + if ( ! yy_start_stack ) + YY_FATAL_ERROR( + "out of memory expanding start-condition stack" ); + } + + yy_start_stack[yy_start_stack_ptr++] = YY_START; + + BEGIN(new_state); + } + + +static void yy_pop_state() + { + if ( --yy_start_stack_ptr < 0 ) + YY_FATAL_ERROR( "start-condition stack underflow" ); + + BEGIN(yy_start_stack[yy_start_stack_ptr]); + } + + +static int yy_top_state() + { + return yy_start_stack[yy_start_stack_ptr - 1]; + } + + +#ifdef YY_USE_PROTOS +static void yy_fatal_error( const char msg[] ) +#else +static void yy_fatal_error( msg ) +char msg[]; +#endif + { + (void) fprintf( stderr, "%s\n", msg ); + exit( 1 ); + } + + + +/* Redefine yyless() so it works in section 3 code. */ + +#undef yyless +#define yyless(n) \ + do \ + { \ + /* Undo effects of setting up yytext. */ \ + yytext[yyleng] = yy_hold_char; \ + yy_c_buf_p = yytext + n - YY_MORE_ADJ; \ + yy_hold_char = *yy_c_buf_p; \ + *yy_c_buf_p = '\0'; \ + yyleng = n; \ + } \ + while ( 0 ) + + +/* Internal utility routines. */ + +#ifndef yytext_ptr +#ifdef YY_USE_PROTOS +static void yy_flex_strncpy( char *s1, const char *s2, int n ) +#else +static void yy_flex_strncpy( s1, s2, n ) +char *s1; +const char *s2; +int n; +#endif + { + register int i; + for ( i = 0; i < n; ++i ) + s1[i] = s2[i]; + } +#endif + + +#ifdef YY_USE_PROTOS +static void *yy_flex_alloc( unsigned int size ) +#else +static void *yy_flex_alloc( size ) +unsigned int size; +#endif + { + return (void *) malloc( size ); + } + +#ifdef YY_USE_PROTOS +static void *yy_flex_realloc( void *ptr, unsigned int size ) +#else +static void *yy_flex_realloc( ptr, size ) +void *ptr; +unsigned int size; +#endif + { + return (void *) realloc( ptr, size ); + } + +#ifdef YY_USE_PROTOS +static void yy_flex_free( void *ptr ) +#else +static void yy_flex_free( ptr ) +void *ptr; +#endif + { + free( ptr ); + } +# line 935 "yaccParser/hslexer.flex" + + +/********************************************************************** +* * +* * +* YACC/LEX Initialisation etc. * +* * +* * +**********************************************************************/ + +/* + We initialise input_filename to "". + This allows unnamed sources to be piped into the parser. +*/ + +void +yyinit() +{ + extern BOOLEAN acceptPrim; + + input_filename = xstrdup(""); + + /* We must initialize the input buffer _now_, because we call + setyyin _before_ calling yylex for the first time! */ + yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE)); + + if (acceptPrim) + PUSH_STATE(GlaExt); + else + PUSH_STATE(Code); +} + +void +new_filename(f) /* This looks pretty dodgy to me (WDP) */ + char *f; +{ + if (input_filename != NULL) + free(input_filename); + input_filename = xstrdup(f); +} + +/********************************************************************** +* * +* * +* Layout Processing * +* * +* * +**********************************************************************/ + +/* + The following section deals with Haskell Layout conventions + forcing insertion of ; or } as appropriate +*/ + +BOOLEAN +hsshouldindent() +{ + return (!forgetindent && INDENTON); +} + + +/* Enter new context and set new indentation level */ +void +hssetindent() +{ +#ifdef HSP_DEBUG + fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT); +#endif + + /* + * partain: first chk that new indent won't be less than current one; this code + * doesn't make sense to me; hscolno tells the position of the _end_ of the + * current token; what that has to do with indenting, I don't know. + */ + + + if (hscolno - 1 <= INDENTPT) { + if (INDENTPT == -1) + return; /* Empty input OK for Haskell 1.1 */ + else { + char errbuf[ERR_BUF_SIZE]; + + sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT); + hsperror(errbuf); + } + } + hsentercontext((hspcolno << 1) | 1); +} + + +/* Enter a new context without changing the indentation level */ +void +hsincindent() +{ +#ifdef HSP_DEBUG + fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT); +#endif + hsentercontext(indenttab[icontexts] & ~1); +} + + +/* Turn off indentation processing, usually because an explicit "{" has been seen */ +void +hsindentoff() +{ + forgetindent = TRUE; +} + + +/* Enter a new layout context. */ +void +hsentercontext(indent) + int indent; +{ + /* Enter new context and set indentation as specified */ + if (++icontexts >= MAX_CONTEXTS) { + char errbuf[ERR_BUF_SIZE]; + + sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1); + hsperror(errbuf); + } + forgetindent = FALSE; + indenttab[icontexts] = indent; +#ifdef HSP_DEBUG + fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT); +#endif +} + + +/* Exit a layout context */ +void +hsendindent() +{ + --icontexts; +#ifdef HSP_DEBUG + fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT); +#endif +} + +/* + * Return checks the indentation level and returns ;, } or the specified token. + */ + +int +Return(tok) + int tok; +{ +#ifdef HSP_DEBUG + extern int yyleng; +#endif + + if (hsshouldindent()) { + if (hspcolno < INDENTPT) { +#ifdef HSP_DEBUG + fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT); +#endif + hssttok = tok; + return (VCCURLY); + } else if (hspcolno == INDENTPT) { +#ifdef HSP_DEBUG + fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT); +#endif + hssttok = -tok; + return (SEMI); + } + } + hssttok = -1; +#ifdef HSP_DEBUG + fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT); +#endif + return (tok); +} + + +/* + * Redefine yylex to check for stacked tokens, yylex1() is the original yylex() + */ +int +yylex() +{ + int tok; + static BOOLEAN eof = FALSE; + + if (!eof) { + if (hssttok != -1) { + if (hssttok < 0) { + tok = -hssttok; + hssttok = -1; + return tok; + } + RETURN(hssttok); + } else { + endlineno = hslineno; + if ((tok = yylex1()) != EOF) + return tok; + else + eof = TRUE; + } + } + if (icontexts > icontexts_save) { + if (INDENTON) { + eof = TRUE; + indenttab[icontexts] = 0; + return (VCCURLY); + } else + hsperror("missing '}' at end of file"); + } else if (hsbuf_save != NULL) { + fclose(yyin); + yy_delete_buffer(YY_CURRENT_BUFFER); + yy_switch_to_buffer(hsbuf_save); + hsbuf_save = NULL; + new_filename(filename_save); + free(filename_save); + hslineno = hslineno_save; + hsplineno = hsplineno_save; + hscolno = hscolno_save; + hspcolno = hspcolno_save; + etags = etags_save; + in_interface = FALSE; + icontexts = icontexts_save - 1; + icontexts_save = 0; +#ifdef HSP_DEBUG + fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT); +#endif + eof = FALSE; + RETURN(LEOF); + } else { + yyterminate(); + } + abort(); /* should never get here! */ + return(0); +} + +/********************************************************************** +* * +* * +* Input Processing for Interfaces * +* * +* * +**********************************************************************/ + +/* setyyin(file) open file as new lex input buffer */ +void +setyyin(file) + char *file; +{ + extern FILE *yyin; + + hsbuf_save = YY_CURRENT_BUFFER; + if ((yyin = fopen(file, "r")) == NULL) { + char errbuf[ERR_BUF_SIZE]; + + sprintf(errbuf, "can't read \"%-.50s\"", file); + hsperror(errbuf); + } + yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE)); + + hslineno_save = hslineno; + hsplineno_save = hsplineno; + hslineno = hsplineno = 1; + + filename_save = input_filename; + input_filename = NULL; + new_filename(file); + hscolno_save = hscolno; + hspcolno_save = hspcolno; + hscolno = hspcolno = 0; + in_interface = TRUE; + etags_save = etags; /* do not do "etags" stuff in interfaces */ + etags = 0; /* We remember whether we are doing it in + the module, so we can restore it later [WDP 94/09] */ + hsentercontext(-1); /* partain: changed this from 0 */ + icontexts_save = icontexts; +#ifdef HSP_DEBUG + fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT); +#endif +} + +static VOID +layout_input(text, len) +char *text; +int len; +{ +#ifdef HSP_DEBUG + fprintf(stderr, "Scanning \"%s\"\n", text); +#endif + + hsplineno = hslineno; + hspcolno = hscolno; + + while (len-- > 0) { + switch (*text++) { + case '\n': + case '\r': + case '\f': + hslineno++; + hscolno = 0; + break; + case '\t': + hscolno += 8 - (hscolno % 8); /* Tabs stops are 8 columns apart */ + break; + case '\v': + break; + default: + ++hscolno; + break; + } + } +} + +void +setstartlineno() +{ + startlineno = hsplineno; +#if 1/*etags*/ +#else + if (etags) + fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno); +#endif +} + +/********************************************************************** +* * +* * +* Text Caching * +* * +* * +**********************************************************************/ + +#define CACHE_SIZE YY_BUF_SIZE + +static struct { + unsigned allocated; + unsigned next; + char *text; +} textcache = { 0, 0, NULL }; + +static VOID +cleartext() +{ +/* fprintf(stderr, "cleartext\n"); */ + textcache.next = 0; + if (textcache.allocated == 0) { + textcache.allocated = CACHE_SIZE; + textcache.text = xmalloc(CACHE_SIZE); + } +} + +static VOID +addtext(text, length) +char *text; +unsigned length; +{ +/* fprintf(stderr, "addtext: %d %s\n", length, text); */ + + if (length == 0) + return; + + if (textcache.next + length + 1 >= textcache.allocated) { + textcache.allocated += length + CACHE_SIZE; + textcache.text = xrealloc(textcache.text, textcache.allocated); + } + bcopy(text, textcache.text + textcache.next, length); + textcache.next += length; +} + +static VOID +#ifdef __STDC__ +addchar(char c) +#else +addchar(c) + char c; +#endif +{ +/* fprintf(stderr, "addchar: %c\n", c); */ + + if (textcache.next + 2 >= textcache.allocated) { + textcache.allocated += CACHE_SIZE; + textcache.text = xrealloc(textcache.text, textcache.allocated); + } + textcache.text[textcache.next++] = c; +} + +static char * +fetchtext(length) +unsigned *length; +{ +/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */ + + *length = textcache.next; + textcache.text[textcache.next] = '\0'; + return textcache.text; +} + +/********************************************************************** +* * +* * +* Identifier Processing * +* * +* * +**********************************************************************/ + +/* + hsnewid Enters an id of length n into the symbol table. +*/ + +static VOID +hsnewid(name, length) +char *name; +int length; +{ + char save = name[length]; + + name[length] = '\0'; + yylval.uid = installid(name); + name[length] = save; +} + +BOOLEAN +isconstr(s) /* walks past leading underscores before using the macro */ + char *s; +{ + char *temp = s; + + for ( ; temp != NULL && *temp == '_' ; temp++ ); + + return _isconstr(temp); +} diff --git a/ghc/compiler/yaccParser/hslexer.flex b/ghc/compiler/yaccParser/hslexer.flex new file mode 100644 index 0000000..7d0ce0f --- /dev/null +++ b/ghc/compiler/yaccParser/hslexer.flex @@ -0,0 +1,1362 @@ +%{ +/********************************************************************** +* * +* * +* LEX grammar for Haskell. * +* ------------------------ * +* * +* (c) Copyright K. Hammond, University of Glasgow, * +* 10th. February 1989 * +* * +* Modification History * +* -------------------- * +* * +* 22/08/91 kh Initial Haskell 1.1 version. * +* 18/10/91 kh Added 'ccall'. * +* 19/11/91 kh Tidied generally. * +* 04/12/91 kh Added Int#. * +* 31/01/92 kh Haskell 1.2 version. * +* 24/04/92 ps Added 'scc'. * +* 03/06/92 kh Changed Infix/Prelude Handling. * +* 23/08/93 jsm Changed to support flex * +* * +* * +* Known Problems: * +* * +* None, any more. * +* * +**********************************************************************/ + +#include "../../includes/config.h" + +#include + +#if defined(STDC_HEADERS) || defined(HAVE_STRING_H) +#include +/* An ANSI string.h and pre-ANSI memory.h might conflict. */ +#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H) +#include +#endif /* not STDC_HEADERS and HAVE_MEMORY_H */ +#define index strchr +#define rindex strrchr +#define bcopy(s, d, n) memcpy ((d), (s), (n)) +#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n)) +#define bzero(s, n) memset ((s), 0, (n)) +#else /* not STDC_HEADERS and not HAVE_STRING_H */ +#include +/* memory.h and strings.h conflict on some systems. */ +#endif /* not STDC_HEADERS and not HAVE_STRING_H */ + +#include "hspincl.h" +#include "hsparser.tab.h" +#include "constants.h" +#include "utils.h" + +/* Our substitute for */ + +#define NCHARS 256 +#define _S 0x1 +#define _D 0x2 +#define _H 0x4 +#define _O 0x8 +#define _C 0x10 + +#define _isconstr(s) (CharTable[*s]&(_C)) +BOOLEAN isconstr PROTO((char *)); /* fwd decl */ + +unsigned char CharTable[NCHARS] = { +/* nul */ 0, 0, 0, 0, 0, 0, 0, 0, +/* bs */ 0, _S, _S, _S, _S, 0, 0, 0, +/* dle */ 0, 0, 0, 0, 0, 0, 0, 0, +/* can */ 0, 0, 0, 0, 0, 0, 0, 0, +/* sp */ _S, 0, 0, 0, 0, 0, 0, 0, +/* '(' */ 0, 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, 0, 0, 0, 0, 0, +/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0, +/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0, +/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0, +/* 'x' */ 0, 0, 0, 0, 0, 0, 0, 0, + +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +/* */ 0, 0, 0, 0, 0, 0, 0, 0, +}; + +/********************************************************************** +* * +* * +* Declarations * +* * +* * +**********************************************************************/ + +char *input_filename = NULL; /* Always points to a dynamically allocated string */ + +/* + * For my own sanity, things that are not part of the flex skeleton + * have been renamed as hsXXXXX rather than yyXXXXX. --JSM + */ + +int hslineno = 0; /* Line number at end of token */ +int hsplineno = 0; /* Line number at end of previous token */ + +int hscolno = 0; /* Column number at end of token */ +int hspcolno = 0; /* Column number at end of previous token */ +int hsmlcolno = 0; /* Column number for multiple-rule lexemes */ + +int startlineno = 0; /* The line number where something starts */ +int endlineno = 0; /* The line number where something ends */ + +static BOOLEAN noGap = TRUE; /* For checking string gaps */ +static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules */ + +static int nested_comments; /* For counting comment nesting depth */ + +/* Hacky definition of yywrap: see flex doc. + + If we don't do this, then we'll have to get the default + yywrap from the flex library, which is often something + we are not good at locating. This avoids that difficulty. + (Besides which, this is the way old flexes (pre 2.4.x) did it.) + WDP 94/09/05 +*/ +#define yywrap() 1 + +/* Essential forward declarations */ + +static VOID hsnewid PROTO((char *, int)); +static VOID layout_input PROTO((char *, int)); +static VOID cleartext (NO_ARGS); +static VOID addtext PROTO((char *, unsigned)); +static VOID addchar PROTO((char)); +static char *fetchtext PROTO((unsigned *)); + +/* Special file handling for IMPORTS */ +/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */ + +static YY_BUFFER_STATE hsbuf_save = NULL; /* Saved input buffer */ +static char *filename_save; /* File Name */ +static int hslineno_save = 0, /* Line Number */ + hsplineno_save = 0, /* Line Number of Prev. token */ + hscolno_save = 0, /* Indentation */ + hspcolno_save = 0; /* Left Indentation */ +static short icontexts_save = 0; /* Indent Context Level */ + +static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */ +extern BOOLEAN etags; /* that which is saved */ + +extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */ + +static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */ + +extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */ +extern int minAcceptablePragmaVersion; /* see documentation in main.c */ +extern int maxAcceptablePragmaVersion; +extern int thisIfacePragmaVersion; + +static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";" + * inserted before token +ve -- "}" inserted before + * token */ + +short icontexts = 0; /* Which context we're in */ + + + +/* + Table of indentations: right bit indicates whether to use + indentation rules (1 = use rules; 0 = ignore) + + partain: + push one of these "contexts" at every "case" or "where"; the right bit says + whether user supplied braces, etc., or not. pop appropriately (hsendindent). + + ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is + pushed (the "column" for "module", "interface" and EOF). The -1 from the initial + push is shown just below. + +*/ + + +static short indenttab[MAX_CONTEXTS] = {-1}; + +#define INDENTPT (indenttab[icontexts]>>1) +#define INDENTON (indenttab[icontexts]&1) + +#define RETURN(tok) return(Return(tok)) + +#undef YY_DECL +#define YY_DECL int yylex1() + +/* We should not peek at yy_act, but flex calls us even for the internal action + triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but + to support older versions of flex, we'll continue to peek for now. + */ +#define YY_USER_ACTION \ + if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng); + +#if 0/*debug*/ +#undef YY_BREAK +#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break; +#endif + +/* Each time we enter a new start state, we push it onto the state stack. + Note that the rules do not allow us to underflow or overflow the stack. + (At least, they shouldn't.) The maximum expected depth is 4: + 0: Code -> 1: String -> 2: StringEsc -> 3: Comment +*/ +static int StateStack[5]; +static int StateDepth = -1; + +#ifdef HSP_DEBUG +#define PUSH_STATE(n) do {\ + fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\ + StateStack[++StateDepth] = (n); BEGIN(n);} while(0) +#define POP_STATE do {--StateDepth;\ + fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\ + BEGIN(StateStack[StateDepth]);} while(0) +#else +#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0) +#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0) +#endif + +%} + +/* The start states are: + Code -- normal Haskell code (principal lexer) + GlaExt -- Haskell code with Glasgow extensions + Comment -- Nested comment processing + String -- Inside a string literal with backslashes + StringEsc -- Immediately following a backslash in a string literal + Char -- Inside a character literal with backslashes + CharEsc -- Immediately following a backslash in a character literal + + Note that the INITIAL state is unused. Also note that these states + are _exclusive_. All rules should be prefixed with an appropriate + list of start states. + */ + +%x Char CharEsc Code Comment GlaExt GhcPragma UserPragma String StringEsc + +D [0-9] +O [0-7] +H [0-9A-Fa-f] +N {D}+ +F {N}"."{N}(("e"|"E")("+"|"-")?{N})? +S [!#$%&*+./<=>?@\\^|~:] +SId ({S}|~|-){S}* +CHAR [ !#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~] +L [A-Z] +I [A-Za-z] +i [A-Za-z0-9'_] +Id {I}({i})* +WS [ \t\n\r\f\v] +CNTRL [@A-Z\[\\\]^_] +NL [\n\r] + +%% + +%{ + /* + * Special GHC pragma rules. Do we need a start state for interface files, + * so these won't be matched in source files? --JSM + */ +%} + +^"# ".*{NL} { + char tempf[FILENAME_SIZE]; + sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf); + new_filename(tempf); + hsplineno = hslineno; hscolno = 0; hspcolno = 0; + } + +^"#line ".*{NL} { + char tempf[FILENAME_SIZE]; + sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf); + new_filename(tempf); + hsplineno = hslineno; hscolno = 0; hspcolno = 0; + } + +"{-# LINE ".*"-}"{NL} { + /* partain: pragma-style line directive */ + char tempf[FILENAME_SIZE]; + sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf); + new_filename(tempf); + hsplineno = hslineno; hscolno = 0; hspcolno = 0; + } +"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}" { + sscanf(yytext+33,"%d ",&thisIfacePragmaVersion); + } +"{-# GHC_PRAGMA " { + if ( ignorePragmas || + thisIfacePragmaVersion < minAcceptablePragmaVersion || + thisIfacePragmaVersion > maxAcceptablePragmaVersion) { + nested_comments = 1; + PUSH_STATE(Comment); + } else { + PUSH_STATE(GhcPragma); + RETURN(GHC_PRAGMA); + } + } +"_N_" { RETURN(NO_PRAGMA); } +"_NI_" { RETURN(NOINFO_PRAGMA); } +"_ABSTRACT_" { RETURN(ABSTRACT_PRAGMA); } +"_DEFOREST_" { RETURN(DEFOREST_PRAGMA); } +"_SPECIALISE_" { RETURN(SPECIALISE_PRAGMA); } +"_M_" { RETURN(MODNAME_PRAGMA); } +"_A_" { RETURN(ARITY_PRAGMA); } +"_U_" { RETURN(UPDATE_PRAGMA); } +"_S_" { RETURN(STRICTNESS_PRAGMA); } +"_K_" { RETURN(KIND_PRAGMA); } +"_MF_" { RETURN(MAGIC_UNFOLDING_PRAGMA); } +"_F_" { RETURN(UNFOLDING_PRAGMA); } + +"_!_" { RETURN(COCON); } +"_#_" { RETURN(COPRIM); } +"_APP_" { RETURN(COAPP); } +"_TYAPP_" { RETURN(COTYAPP); } +"_ALG_" { RETURN(CO_ALG_ALTS); } +"_PRIM_" { RETURN(CO_PRIM_ALTS); } +"_NO_DEFLT_" { RETURN(CO_NO_DEFAULT); } +"_LETREC_" { RETURN(CO_LETREC); } + +"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); } +"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); } +"_USER_CC_" { RETURN(CO_USER_CC); } +"_AUTO_CC_" { RETURN(CO_AUTO_CC); } +"_DICT_CC_" { RETURN(CO_DICT_CC); } + +"_DUPD_CC_" { RETURN(CO_DUPD_CC); } +"_CAF_CC_" { RETURN(CO_CAF_CC); } + +"_SDSEL_" { RETURN(CO_SDSEL_ID); } +"_METH_" { RETURN(CO_METH_ID); } +"_DEFM_" { RETURN(CO_DEFM_ID); } +"_DFUN_" { RETURN(CO_DFUN_ID); } +"_CONSTM_" { RETURN(CO_CONSTM_ID); } +"_SPEC_" { RETURN(CO_SPEC_ID); } +"_WRKR_" { RETURN(CO_WRKR_ID); } +"_ORIG_" { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ } + +"_ALWAYS_" { RETURN(UNFOLD_ALWAYS); } +"_IF_ARGS_" { RETURN(UNFOLD_IF_ARGS); } + +"_NOREP_I_" { RETURN(NOREP_INTEGER); } +"_NOREP_R_" { RETURN(NOREP_RATIONAL); } +"_NOREP_S_" { RETURN(NOREP_STRING); } + +" #-}" { POP_STATE; RETURN(END_PRAGMA); } + +"{-#"{WS}*"SPECIALI"[SZ]E { + PUSH_STATE(UserPragma); + RETURN(SPECIALISE_UPRAGMA); + } +"{-#"{WS}*"INLINE" { + PUSH_STATE(UserPragma); + RETURN(INLINE_UPRAGMA); + } +"{-#"{WS}*"MAGIC_UNFOLDING" { + PUSH_STATE(UserPragma); + RETURN(MAGIC_UNFOLDING_UPRAGMA); + } +"{-#"{WS}*"DEFOREST" { + PUSH_STATE(UserPragma); + RETURN(DEFOREST_UPRAGMA); + } +"{-#"{WS}*"ABSTRACT" { + PUSH_STATE(UserPragma); + RETURN(ABSTRACT_UPRAGMA); + } +"#-}" { POP_STATE; RETURN(END_UPRAGMA); } + +%{ + /* + * Haskell keywords. `scc' is actually a Glasgow extension, but it is + * intentionally accepted as a keyword even for normal . + */ +%} + +"case" { RETURN(CASE); } +"class" { RETURN(CLASS); } +"data" { RETURN(DATA); } +"default" { RETURN(DEFAULT); } +"deriving" { RETURN(DERIVING); } +"else" { RETURN(ELSE); } +"hiding" { RETURN(HIDING); } +"if" { RETURN(IF); } +"import" { RETURN(IMPORT); } +"infix" { RETURN(INFIX); } +"infixl" { RETURN(INFIXL); } +"infixr" { RETURN(INFIXR); } +"instance" { RETURN(INSTANCE); } +"interface" { RETURN(INTERFACE); } +"module" { RETURN(MODULE); } +"of" { RETURN(OF); } +"renaming" { RETURN(RENAMING); } +"then" { RETURN(THEN); } +"to" { RETURN(TO); } +"type" { RETURN(TYPE); } +"where" { RETURN(WHERE); } +"in" { RETURN(IN); } +"let" { RETURN(LET); } +"_ccall_" { RETURN(CCALL); } +"_ccall_GC_" { RETURN(CCALL_GC); } +"_casm_" { RETURN(CASM); } +"_casm_GC_" { RETURN(CASM_GC); } +"_scc_" { RETURN(SCC); } +"_forall_" { RETURN(FORALL); } + +%{ + /* + * Haskell operators. Nothing special about these. + */ +%} + +".." { RETURN(DOTDOT); } +";" { RETURN(SEMI); } +"," { RETURN(COMMA); } +"|" { RETURN(VBAR); } +"=" { RETURN(EQUAL); } +"<-" { RETURN(LARROW); } +"->" { RETURN(RARROW); } +"=>" { RETURN(DARROW); } +"::" { RETURN(DCOLON); } +"(" { RETURN(OPAREN); } +")" { RETURN(CPAREN); } +"[" { RETURN(OBRACK); } +"]" { RETURN(CBRACK); } +"{" { RETURN(OCURLY); } +"}" { RETURN(CCURLY); } +"+" { RETURN(PLUS); } +"@" { RETURN(AT); } +"\\" { RETURN(LAMBDA); } +"_/\\_" { RETURN(TYLAMBDA); } +"_" { RETURN(WILDCARD); } +"`" { RETURN(BQUOTE); } +"~" { RETURN(LAZY); } +"-" { RETURN(MINUS); } + +%{ + /* + * Integers and (for Glasgow extensions) primitive integers. Note that + * we pass all of the text on to the parser, because flex/C can't handle + * arbitrary precision numbers. + */ +%} + +("-")?"0o"{O}+"#" { /* octal */ + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(INTPRIM); + } +"0o"{O}+ { /* octal */ + yylval.uid = xstrndup(yytext, yyleng); + RETURN(INTEGER); + } +("-")?"0x"{H}+"#" { /* hexadecimal */ + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(INTPRIM); + } +"0x"{H}+ { /* hexadecimal */ + yylval.uid = xstrndup(yytext, yyleng); + RETURN(INTEGER); + } +("-")?{N}"#" { + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(INTPRIM); + } +{N} { + yylval.uid = xstrndup(yytext, yyleng); + RETURN(INTEGER); + } + +%{ + /* + * Floats and (for Glasgow extensions) primitive floats/doubles. + */ +%} + +("-")?{F}"##" { + yylval.uid = xstrndup(yytext, yyleng - 2); + RETURN(DOUBLEPRIM); + } +("-")?{F}"#" { + yylval.uid = xstrndup(yytext, yyleng - 1); + RETURN(FLOATPRIM); + } +{F} { + yylval.uid = xstrndup(yytext, yyleng); + RETURN(FLOAT); + } + +%{ + /* + * Funky ``foo'' style C literals for Glasgow extensions + */ +%} + +"``"[^']+"''" { + hsnewid(yytext + 2, yyleng - 4); + RETURN(CLITLIT); + } + +%{ + /* + * Identifiers, both variables and operators. The trailing hash is allowed + * for Glasgow extensions. + */ +%} + +"_NIL_" { hsnewid(yytext, yyleng); RETURN(CONID); } +"_TUP_"{D}+ { hsnewid(yytext, yyleng); RETURN(CONID); } +[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); } + +{Id}"#" { + hsnewid(yytext, yyleng); + RETURN(_isconstr(yytext) ? CONID : VARID); + } +%{ +/* This SHOULDNAE work in "Code" (sigh) */ +%} +_+{Id} { + if (! (nonstandardFlag || in_interface)) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext); + hsperror(errbuf); + } + hsnewid(yytext, yyleng); + RETURN(isconstr(yytext) ? CONID : VARID); + /* NB: ^^^^^^^^ : not the macro! */ + } +{Id} { + hsnewid(yytext, yyleng); + RETURN(_isconstr(yytext) ? CONID : VARID); + } +{SId} { + hsnewid(yytext, yyleng); + RETURN(_isconstr(yytext) ? CONSYM : VARSYM); + } + +%{ + /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */ + + /* Because we can make the former well-behaved (we defined them). + + Sadly, the latter is defined by Haskell, which allows such + la-la land constructs as `{-a 900-line comment-} foo`. (WDP 94/12) + */ +%} + +"`"{Id}"#`" { + hsnewid(yytext + 1, yyleng - 2); + RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM); + } + +%{ + /* + * Character literals. The first form is the quick form, for character + * literals that don't contain backslashes. Literals with backslashes are + * lexed through multiple rules. First, we match the open ' and as many + * normal characters as possible. This puts us into the state, where + * a backslash is legal. Then, we match the backslash and move into the + * state. When we drop out of , we collect more normal + * characters and the close '. We may end up with too many characters, but + * this allows us to easily share the lex rules with strings. Excess characters + * are ignored with a warning. + */ +%} + +'({CHAR}|"\"")"'#" { + yylval.uhstring = installHstring(1, yytext+1); + RETURN(CHARPRIM); + } +'({CHAR}|"\"")' { + yylval.uhstring = installHstring(1, yytext+1); + RETURN(CHAR); + } +'' {char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "'' is not a valid character (or string) literal\n"); + hsperror(errbuf); + } +'({CHAR}|"\"")* { + hsmlcolno = hspcolno; + cleartext(); + addtext(yytext+1, yyleng-1); + PUSH_STATE(Char); + } +({CHAR}|"\"")*'# { + unsigned length; + char *text; + + addtext(yytext, yyleng - 2); + text = fetchtext(&length); + + if (! (nonstandardFlag || in_interface)) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text); + hsperror(errbuf); + } + + if (length > 1) { + fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) text, length); + fputs("' too long\n", stderr); + hsperror(""); + } + yylval.uhstring = installHstring(1, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(CHARPRIM); + } +({CHAR}|"\"")*' { + unsigned length; + char *text; + + addtext(yytext, yyleng - 1); + text = fetchtext(&length); + + if (length > 1) { + fprintf(stderr, "\"%s\", line %d, column %d: Character literal '", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) text, length); + fputs("' too long\n", stderr); + hsperror(""); + } + yylval.uhstring = installHstring(1, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(CHAR); + } +({CHAR}|"\"")+ { addtext(yytext, yyleng); } + + +%{ + /* + * String literals. The first form is the quick form, for string literals + * that don't contain backslashes. Literals with backslashes are lexed + * through multiple rules. First, we match the open " and as many normal + * characters as possible. This puts us into the state, where + * a backslash is legal. Then, we match the backslash and move into the + * state. When we drop out of , we collect more normal + * characters, moving back and forth between and as more + * backslashes are encountered. (We may even digress into mode if we + * find a comment in a gap between backslashes.) Finally, we read the last chunk + * of normal characters and the close ". + */ +%} + +"\""({CHAR}|"'")*"\""# { + yylval.uhstring = installHstring(yyleng-3, yytext+1); + /* the -3 accounts for the " on front, "# on the end */ + RETURN(STRINGPRIM); + } +"\""({CHAR}|"'")*"\"" { + yylval.uhstring = installHstring(yyleng-2, yytext+1); + RETURN(STRING); + } +"\""({CHAR}|"'")* { + hsmlcolno = hspcolno; + cleartext(); + addtext(yytext+1, yyleng-1); + PUSH_STATE(String); + } +({CHAR}|"'")*"\"#" { + unsigned length; + char *text; + + addtext(yytext, yyleng-2); + text = fetchtext(&length); + + if (! (nonstandardFlag || in_interface)) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text); + hsperror(errbuf); + } + + yylval.uhstring = installHstring(length, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(STRINGPRIM); + } +({CHAR}|"'")*"\"" { + unsigned length; + char *text; + + addtext(yytext, yyleng-1); + text = fetchtext(&length); + + yylval.uhstring = installHstring(length, text); + hspcolno = hsmlcolno; + POP_STATE; + RETURN(STRING); + } +({CHAR}|"'")+ { addtext(yytext, yyleng); } + +%{ + /* + * Character and string escapes are roughly the same, but strings have the + * extra `\&' sequence which is not allowed for characters. Also, comments + * are allowed in the state. (See the comment section much + * further down.) + * + * NB: Backslashes and tabs are stored in strings as themselves. + * But if we print them (in printtree.c), they must go out as + * "\\\\" and "\\t" respectively. (This is because of the bogus + * intermediate format that the parser produces. It uses '\t' fpr end of + * string, so it needs to be able to escape tabs, which means that it + * also needs to be able to escape the escape character ('\\'). Sigh. + */ +%} + +\\ { PUSH_STATE(CharEsc); } +\\& /* Ignore */ ; +\\ { PUSH_STATE(StringEsc); noGap = TRUE; } + +\\ { addchar(*yytext); POP_STATE; } +\\ { if (noGap) { addchar(*yytext); } POP_STATE; } + +["'] { addchar(*yytext); POP_STATE; } +NUL { addchar('\000'); POP_STATE; } +SOH { addchar('\001'); POP_STATE; } +STX { addchar('\002'); POP_STATE; } +ETX { addchar('\003'); POP_STATE; } +EOT { addchar('\004'); POP_STATE; } +ENQ { addchar('\005'); POP_STATE; } +ACK { addchar('\006'); POP_STATE; } +BEL | +a { addchar('\007'); POP_STATE; } +BS | +b { addchar('\010'); POP_STATE; } +HT | +t { addchar('\011'); POP_STATE; } +LF | +n { addchar('\012'); POP_STATE; } +VT | +v { addchar('\013'); POP_STATE; } +FF | +f { addchar('\014'); POP_STATE; } +CR | +r { addchar('\015'); POP_STATE; } +SO { addchar('\016'); POP_STATE; } +SI { addchar('\017'); POP_STATE; } +DLE { addchar('\020'); POP_STATE; } +DC1 { addchar('\021'); POP_STATE; } +DC2 { addchar('\022'); POP_STATE; } +DC3 { addchar('\023'); POP_STATE; } +DC4 { addchar('\024'); POP_STATE; } +NAK { addchar('\025'); POP_STATE; } +SYN { addchar('\026'); POP_STATE; } +ETB { addchar('\027'); POP_STATE; } +CAN { addchar('\030'); POP_STATE; } +EM { addchar('\031'); POP_STATE; } +SUB { addchar('\032'); POP_STATE; } +ESC { addchar('\033'); POP_STATE; } +FS { addchar('\034'); POP_STATE; } +GS { addchar('\035'); POP_STATE; } +RS { addchar('\036'); POP_STATE; } +US { addchar('\037'); POP_STATE; } +SP { addchar('\040'); POP_STATE; } +DEL { addchar('\177'); POP_STATE; } +"^"{CNTRL} { char c = yytext[1] - '@'; addchar(c); POP_STATE; } +{D}+ { + int i = strtol(yytext, NULL, 10); + if (i < NCHARS) { + addchar((char) i); + } else { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", + yytext); + hsperror(errbuf); + } + POP_STATE; + } +o{O}+ { + int i = strtol(yytext + 1, NULL, 8); + if (i < NCHARS) { + addchar((char) i); + } else { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", + yytext); + hsperror(errbuf); + } + POP_STATE; + } +x{H}+ { + int i = strtol(yytext + 1, NULL, 16); + if (i < NCHARS) { + addchar((char) i); + } else { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n", + yytext); + hsperror(errbuf); + } + POP_STATE; + } + +%{ + /* + * Simple comments and whitespace. Normally, we would just ignore these, but + * in case we're processing a string escape, we need to note that we've seen + * a gap. + */ +%} + +"--".*{NL}{WS}* | +{WS}+ { noGap = FALSE; } + +%{ + /* + * Nested comments. The major complication here is in trying to match the + * longest lexemes possible, for better performance. (See the flex document.) + * That's why the rules look so bizarre. + */ +%} + +"{-" { + noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment); + } + +[^-{]* | +"-"+[^-{}]+ | +"{"+[^-{}]+ ; +"{-" { nested_comments++; } +"-}" { if (--nested_comments == 0) POP_STATE; } +(.|\n) ; + +%{ + /* + * Illegal characters. This used to be a single rule, but we might as well + * pass on as much information as we have, so now we indicate our state in + * the error message. + */ +%} + +(.|\n) { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("'\n", stderr); + hsperror(""); + } +(.|\n) { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("' in a character literal\n", stderr); + hsperror(""); + } +(.|\n) { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("'\n", stderr); + hsperror(""); + } +(.|\n) { if (nonstandardFlag) { + addtext(yytext, yyleng); + } else { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("' in a string literal\n", stderr); + hsperror(""); + } + } +(.|\n) { + if (noGap) { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("'\n", stderr); + hsperror(""); + } else { + fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", + input_filename, hsplineno, hspcolno + 1); + format_string(stderr, (unsigned char *) yytext, 1); + fputs("' in a string gap\n", stderr); + hsperror(""); + } + } + +%{ + /* + * End of file. In any sub-state, this is an error. However, for the primary + * and states, this is perfectly normal. We just return an EOF + * and let the yylex() wrapper deal with whatever has to be done next (e.g. + * adding virtual close curlies, or closing an interface and returning to the + * primary source file. + * + * Note that flex does not call YY_USER_ACTION for <> rules. Hence the + * line/column advancement has to be done by hand. + */ +%} + +<> { + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated character literal"); + } +<> { + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated comment"); + } +<> { + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated string literal"); + } +<> { + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated interface pragma"); + } +<> { + hsplineno = hslineno; hspcolno = hscolno; + hsperror("unterminated user-specified pragma"); + } +<> { hsplineno = hslineno; hspcolno = hscolno; return(EOF); } + +%% + +/********************************************************************** +* * +* * +* YACC/LEX Initialisation etc. * +* * +* * +**********************************************************************/ + +/* + We initialise input_filename to "". + This allows unnamed sources to be piped into the parser. +*/ + +void +yyinit() +{ + extern BOOLEAN acceptPrim; + + input_filename = xstrdup(""); + + /* We must initialize the input buffer _now_, because we call + setyyin _before_ calling yylex for the first time! */ + yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE)); + + if (acceptPrim) + PUSH_STATE(GlaExt); + else + PUSH_STATE(Code); +} + +void +new_filename(f) /* This looks pretty dodgy to me (WDP) */ + char *f; +{ + if (input_filename != NULL) + free(input_filename); + input_filename = xstrdup(f); +} + +/********************************************************************** +* * +* * +* Layout Processing * +* * +* * +**********************************************************************/ + +/* + The following section deals with Haskell Layout conventions + forcing insertion of ; or } as appropriate +*/ + +BOOLEAN +hsshouldindent() +{ + return (!forgetindent && INDENTON); +} + + +/* Enter new context and set new indentation level */ +void +hssetindent() +{ +#ifdef HSP_DEBUG + fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT); +#endif + + /* + * partain: first chk that new indent won't be less than current one; this code + * doesn't make sense to me; hscolno tells the position of the _end_ of the + * current token; what that has to do with indenting, I don't know. + */ + + + if (hscolno - 1 <= INDENTPT) { + if (INDENTPT == -1) + return; /* Empty input OK for Haskell 1.1 */ + else { + char errbuf[ERR_BUF_SIZE]; + + sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT); + hsperror(errbuf); + } + } + hsentercontext((hspcolno << 1) | 1); +} + + +/* Enter a new context without changing the indentation level */ +void +hsincindent() +{ +#ifdef HSP_DEBUG + fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT); +#endif + hsentercontext(indenttab[icontexts] & ~1); +} + + +/* Turn off indentation processing, usually because an explicit "{" has been seen */ +void +hsindentoff() +{ + forgetindent = TRUE; +} + + +/* Enter a new layout context. */ +void +hsentercontext(indent) + int indent; +{ + /* Enter new context and set indentation as specified */ + if (++icontexts >= MAX_CONTEXTS) { + char errbuf[ERR_BUF_SIZE]; + + sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1); + hsperror(errbuf); + } + forgetindent = FALSE; + indenttab[icontexts] = indent; +#ifdef HSP_DEBUG + fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT); +#endif +} + + +/* Exit a layout context */ +void +hsendindent() +{ + --icontexts; +#ifdef HSP_DEBUG + fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT); +#endif +} + +/* + * Return checks the indentation level and returns ;, } or the specified token. + */ + +int +Return(tok) + int tok; +{ +#ifdef HSP_DEBUG + extern int yyleng; +#endif + + if (hsshouldindent()) { + if (hspcolno < INDENTPT) { +#ifdef HSP_DEBUG + fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT); +#endif + hssttok = tok; + return (VCCURLY); + } else if (hspcolno == INDENTPT) { +#ifdef HSP_DEBUG + fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT); +#endif + hssttok = -tok; + return (SEMI); + } + } + hssttok = -1; +#ifdef HSP_DEBUG + fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT); +#endif + return (tok); +} + + +/* + * Redefine yylex to check for stacked tokens, yylex1() is the original yylex() + */ +int +yylex() +{ + int tok; + static BOOLEAN eof = FALSE; + + if (!eof) { + if (hssttok != -1) { + if (hssttok < 0) { + tok = -hssttok; + hssttok = -1; + return tok; + } + RETURN(hssttok); + } else { + endlineno = hslineno; + if ((tok = yylex1()) != EOF) + return tok; + else + eof = TRUE; + } + } + if (icontexts > icontexts_save) { + if (INDENTON) { + eof = TRUE; + indenttab[icontexts] = 0; + return (VCCURLY); + } else + hsperror("missing '}' at end of file"); + } else if (hsbuf_save != NULL) { + fclose(yyin); + yy_delete_buffer(YY_CURRENT_BUFFER); + yy_switch_to_buffer(hsbuf_save); + hsbuf_save = NULL; + new_filename(filename_save); + free(filename_save); + hslineno = hslineno_save; + hsplineno = hsplineno_save; + hscolno = hscolno_save; + hspcolno = hspcolno_save; + etags = etags_save; + in_interface = FALSE; + icontexts = icontexts_save - 1; + icontexts_save = 0; +#ifdef HSP_DEBUG + fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT); +#endif + eof = FALSE; + RETURN(LEOF); + } else { + yyterminate(); + } + abort(); /* should never get here! */ + return(0); +} + +/********************************************************************** +* * +* * +* Input Processing for Interfaces * +* * +* * +**********************************************************************/ + +/* setyyin(file) open file as new lex input buffer */ +void +setyyin(file) + char *file; +{ + extern FILE *yyin; + + hsbuf_save = YY_CURRENT_BUFFER; + if ((yyin = fopen(file, "r")) == NULL) { + char errbuf[ERR_BUF_SIZE]; + + sprintf(errbuf, "can't read \"%-.50s\"", file); + hsperror(errbuf); + } + yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE)); + + hslineno_save = hslineno; + hsplineno_save = hsplineno; + hslineno = hsplineno = 1; + + filename_save = input_filename; + input_filename = NULL; + new_filename(file); + hscolno_save = hscolno; + hspcolno_save = hspcolno; + hscolno = hspcolno = 0; + in_interface = TRUE; + etags_save = etags; /* do not do "etags" stuff in interfaces */ + etags = 0; /* We remember whether we are doing it in + the module, so we can restore it later [WDP 94/09] */ + hsentercontext(-1); /* partain: changed this from 0 */ + icontexts_save = icontexts; +#ifdef HSP_DEBUG + fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT); +#endif +} + +static VOID +layout_input(text, len) +char *text; +int len; +{ +#ifdef HSP_DEBUG + fprintf(stderr, "Scanning \"%s\"\n", text); +#endif + + hsplineno = hslineno; + hspcolno = hscolno; + + while (len-- > 0) { + switch (*text++) { + case '\n': + case '\r': + case '\f': + hslineno++; + hscolno = 0; + break; + case '\t': + hscolno += 8 - (hscolno % 8); /* Tabs stops are 8 columns apart */ + break; + case '\v': + break; + default: + ++hscolno; + break; + } + } +} + +void +setstartlineno() +{ + startlineno = hsplineno; +#if 1/*etags*/ +#else + if (etags) + fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno); +#endif +} + +/********************************************************************** +* * +* * +* Text Caching * +* * +* * +**********************************************************************/ + +#define CACHE_SIZE YY_BUF_SIZE + +static struct { + unsigned allocated; + unsigned next; + char *text; +} textcache = { 0, 0, NULL }; + +static VOID +cleartext() +{ +/* fprintf(stderr, "cleartext\n"); */ + textcache.next = 0; + if (textcache.allocated == 0) { + textcache.allocated = CACHE_SIZE; + textcache.text = xmalloc(CACHE_SIZE); + } +} + +static VOID +addtext(text, length) +char *text; +unsigned length; +{ +/* fprintf(stderr, "addtext: %d %s\n", length, text); */ + + if (length == 0) + return; + + if (textcache.next + length + 1 >= textcache.allocated) { + textcache.allocated += length + CACHE_SIZE; + textcache.text = xrealloc(textcache.text, textcache.allocated); + } + bcopy(text, textcache.text + textcache.next, length); + textcache.next += length; +} + +static VOID +#ifdef __STDC__ +addchar(char c) +#else +addchar(c) + char c; +#endif +{ +/* fprintf(stderr, "addchar: %c\n", c); */ + + if (textcache.next + 2 >= textcache.allocated) { + textcache.allocated += CACHE_SIZE; + textcache.text = xrealloc(textcache.text, textcache.allocated); + } + textcache.text[textcache.next++] = c; +} + +static char * +fetchtext(length) +unsigned *length; +{ +/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */ + + *length = textcache.next; + textcache.text[textcache.next] = '\0'; + return textcache.text; +} + +/********************************************************************** +* * +* * +* Identifier Processing * +* * +* * +**********************************************************************/ + +/* + hsnewid Enters an id of length n into the symbol table. +*/ + +static VOID +hsnewid(name, length) +char *name; +int length; +{ + char save = name[length]; + + name[length] = '\0'; + yylval.uid = installid(name); + name[length] = save; +} + +BOOLEAN +isconstr(s) /* walks past leading underscores before using the macro */ + char *s; +{ + char *temp = s; + + for ( ; temp != NULL && *temp == '_' ; temp++ ); + + return _isconstr(temp); +} diff --git a/ghc/compiler/yaccParser/hsparser-DPH.y b/ghc/compiler/yaccParser/hsparser-DPH.y new file mode 100644 index 0000000..55749cd --- /dev/null +++ b/ghc/compiler/yaccParser/hsparser-DPH.y @@ -0,0 +1,1555 @@ +/************************************************************************** +* File: hsparser.y * +* * +* Author: Maria M. Gutierrez * +* Modified by: Kevin Hammond * +* Last date revised: December 13 1991. KH. * +* Modification: o Haskell 1.1 Syntax. * +* o Data Parallel Syntax. * +* * +* * +* Description: This file contains the LALR(1) grammar for Haskell. * +* * +* Entry Point: module * +* * +* Problems: None known. * +* * +* * +* LALR(1) Syntax for Haskell 1.2 + Data Parallelism * +* * +**************************************************************************/ + + +%{ +#ifdef DEBUG +# define YYDEBUG 1 +#endif + +#include +#include +#include +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + + + +/********************************************************************** +* * +* * +* Imported Variables and Functions * +* * +* * +**********************************************************************/ + +extern BOOLEAN nonstandardFlag; +extern BOOLEAN expect_ccurly; +extern BOOLEAN etags; + +extern BOOLEAN ispatt PROTO((tree, BOOLEAN)); +extern tree function PROTO((tree)); + +static char modname[MODNAME_SIZE]; +static char *the_module_name; +static char iface_name[MODNAME_SIZE]; +static char interface_filename[FILENAME_SIZE]; + +static list module_exports; /* Exported entities */ +static list prelude_imports; /* Entities imported from the Prelude */ + +extern list all; /* All valid deriving classes */ + +extern tree niltree; +extern list Lnil; + +extern tree root; + +/* For FN, PREVPATT and SAMEFN macros */ +extern tree fns[]; +extern short samefn[]; +extern tree prevpatt[]; +extern short icontexts; + + +/* Line Numbers */ +extern int hsplineno; +extern int startlineno; + +/********************************************************************** +* * +* * +* Fixity and Precedence Declarations * +* * +* * +**********************************************************************/ + +list fixlist; +static int Fixity = 0, Precedence = 0; +struct infix; + +char *ineg(); + +static BOOLEAN hidden = FALSE; /* Set when HIDING used */ + +extern BOOLEAN inpat; /* True when parsing a pattern */ +extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */ + +%} + +%union { + tree utree; + list ulist; + ttype uttype; + atype uatype; + binding ubinding; + pbinding upbinding; + finfot ufinfo; + impidt uimpid; + entidt uentid; + id uid; + int uint; + float ufloat; + char *ustring; + hpragma uhpragma; +} + + +/********************************************************************** +* * +* * +* These are lexemes. * +* * +* * +**********************************************************************/ + + +%token VARID CONID + VARSYM CONSYM MINUS + +%token INTEGER FLOAT CHAR STRING + CHARPRIM INTPRIM FLOATPRIM DOUBLEPRIM + CLITLIT VOIDPRIM + + + +/********************************************************************** +* * +* * +* Special Symbols * +* * +* * +**********************************************************************/ + +%token OCURLY CCURLY VCCURLY SEMI +%token OBRACK CBRACK OPAREN CPAREN +%token COMMA BQUOTE +%token OPOD CPOD OPROC CPROC + + +/********************************************************************** +* * +* * +* Reserved Operators * +* * +* * +**********************************************************************/ + +%token RARROW +%token VBAR EQUAL DARROW DOTDOT +%token DCOLON LARROW +%token WILDCARD AT LAZY LAMBDA +%token DRAWNFROM INDEXFROM + + +/********************************************************************** +* * +* * +* Reserved Identifiers * +* * +* * +**********************************************************************/ + +%token LET IN +%token WHERE CASE OF +%token TYPE DATA CLASS INSTANCE DEFAULT +%token INFIX INFIXL INFIXR +%token MODULE IMPORT INTERFACE HIDING +%token CCALL CCALL_DANGEROUS CASM CASM_DANGEROUS SCC + +%token IF THEN ELSE +%token RENAMING DERIVING TO + +/********************************************************************** +* * +* * +* Special Symbols for the Lexer * +* * +* * +**********************************************************************/ + +%token LEOF +%token ARITY_PRAGMA SPECIALIZE_PRAGMA STRICTNESS_PRAGMA UPDATE_PRAGMA +%token END_PRAGMA + +/********************************************************************** +* * +* * +* Precedences of the various tokens * +* * +* * +**********************************************************************/ + + +%left CASE LET IN LAMBDA + IF ELSE CCALL CCALL_DANGEROUS + CASM CASM_DANGEROUS SCC AT + +%left VARSYM CONSYM PLUS MINUS BQUOTE + +%left DCOLON + +%left SEMI COMMA + +%left OCURLY OBRACK OPAREN + +%left OPOD OPROC + +%left EQUAL + +%right DARROW +%right RARROW + + + +/********************************************************************** +* * +* * +* Type Declarations * +* * +* * +**********************************************************************/ + + +%type alt alts altrest quals vars varsrest cons + tyvars constrs dtypes types atypes + exps pats context context_list tyvar_list + maybeexports export_list + impspec maybeimpspec import_list + impdecls maybeimpdecls impdecl + renaming renamings renaming_list + tyclses tycls_list + gdrhs gdpat valrhs valrhs1 + lampats + upto + cexp + tyvar_pids + parquals + pragmas + + +%type exp dexp fexp kexp oexp aexp literal + tuple list sequence comprehension qual qualrest + gd + apat bpat pat apatc conpat dpat fpat opat aapat + dpatk fpatk opatk aapatk + texps + processor parqual + +%type MINUS VARID CONID VARSYM CONSYM + var vark con conk varop varop1 conop op op1 + varid conid varsym consym minus plus + tycls tycon modid ccallid + +%type topdecl topdecls + typed datad classd instd defaultd + decl decls valdef valdefs sign + iimport iimports maybeiimports + ityped idatad iclassd iinstd ivarsd + itopdecl itopdecls + maybe_where + interface readinterface ibody + cbody rinst + impdecl_rest + +%type simple simple_long type atype btype ttype ntatype inst class + tyvar + +%type constr + +%type STRING FLOAT INTEGER CHARPRIM INTPRIM FLOATPRIM DOUBLEPRIM CLITLIT VOIDPRIM +%type CHAR +%type export import +%type pragma + + +/********************************************************************** +* * +* * +* Start Symbol for the Parser * +* * +* * +**********************************************************************/ + +%start pmodule + + +%% + +pmodule : readprelude module + ; + +module : MODULE modid maybeexports + { the_module_name = $2; module_exports = $3; } + WHERE body + | { the_module_name = install_literal("Main"); module_exports = Lnil; } + body + ; + +body : ocurly maybeimpdecls maybefixes topdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4); + } + | vocurly maybeimpdecls maybefixes topdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4); + } + + | vocurly impdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind()); + } + | ocurly impdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind()); + } + +/* Adds 1 S/R, 2 R/R conflicts, alternatives add 3 R/R conflicts */ + | vocurly maybeimpdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind()); + } + | ocurly maybeimpdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind()); + } + ; + + +maybeexports : /* empty */ { $$ = Lnil; } + | OPAREN export_list CPAREN { $$ = $2; } + ; + +export_list: + export { $$ = lsing($1); } + | export_list COMMA export { $$ = lapp($1,$3); } + ; + +export : + var { $$ = mkentid($1); } + | tycon { $$ = mkenttype($1); } + | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | tycon OPAREN cons CPAREN + { $$ = mkenttypecons($1,$3); + /* should be a datatype with cons representing all constructors */ + } + | tycon OPAREN vars CPAREN + { $$ = mkentclass($1,$3); + /* should be a class with vars representing all Class operations */ + } + | tycon OPAREN CPAREN + { $$ = mkentclass($1,Lnil); + /* "tycon" should be a class with no operations */ + } + | tycon DOTDOT + { $$ = mkentmod($1); + /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */ + } + ; + + +impspec : OPAREN import_list CPAREN { $$ = $2; hidden = FALSE; } + | HIDING OPAREN import_list CPAREN { $$ = $3; hidden = TRUE; } + | OPAREN CPAREN { $$ = Lnil; hidden = FALSE; } + ; + +maybeimpspec : /* empty */ { $$ = Lnil; } + | impspec { $$ = $1; } + ; + +import_list: + import { $$ = lsing($1); } + | import_list COMMA import { $$ = lapp($1,$3); } + ; + +import : + var { $$ = mkentid($1); } + | tycon { $$ = mkenttype($1); } + | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | tycon OPAREN cons CPAREN + { $$ = mkenttypecons($1,$3); + /* should be a datatype with cons representing all constructors */ + } + | tycon OPAREN vars CPAREN + { $$ = mkentclass($1,$3); + /* should be a class with vars representing all Class operations */ + } + | tycon OPAREN CPAREN + { $$ = mkentclass($1,Lnil); + /* "tycon" should be a class with no operations */ + } + ; + + +pragmas: + pragma { $$ = lsing($1); } + | pragmas pragma { $$ = lapp($1,$2); } + | /* empty */ { $$ = Lnil; } + ; + +pragma: + ARITY_PRAGMA var EQUAL INTEGER END_PRAGMA + { $$ = mkarity_pragma($2,$4); } + + | SPECIALIZE_PRAGMA var EQUAL ivarsd END_PRAGMA + { $$ = mkspecialize_pragma($2, $4); } + + | STRICTNESS_PRAGMA var EQUAL STRING pragmas END_PRAGMA + { $$ = mkstrictness_pragma($2, $4, $5); } + + | UPDATE_PRAGMA var EQUAL INTEGER END_PRAGMA + { $$ = mkupdate_pragma($2, $4); } + ; + + +readprelude : + { + if ( implicitPrelude ) { + find_module_on_imports_dirlist("Prelude",TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + setyyin(interface_filename); + enteriscope(); + } + readinterface + { + binding prelude = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno); + prelude_imports = implicitPrelude? lsing(prelude): Lnil; + } + ; + +maybeimpdecls : /* empty */ { $$ = Lnil; } + | impdecls SEMI { $$ = $1; } + ; + +impdecls: impdecl { $$ = $1; } + | impdecls SEMI impdecl { $$ = lconc($1,$3); } + ; + +impdecl : IMPORT modid + { /* filename returned in "interface_filename" */ + char *module_name = id_to_string($2); + find_module_on_imports_dirlist(module_name,FALSE,interface_filename); + setyyin(interface_filename); + enteriscope(); + if(strcmp(module_name,"Prelude")==0) + prelude_imports = Lnil; + } + impdecl_rest + { + if (hidden) + $4->tag = hiding; + $$ = lsing($4); + } + +impdecl_rest: + readinterface maybeimpspec + { $$ = mkimport(installid(iface_name),$2,Lnil,$1,xstrdup(interface_filename),hsplineno); } + /* WDP: uncertain about those hsplinenos */ + | readinterface maybeimpspec RENAMING renamings + { $$ = mkimport(installid(iface_name),$2,$4,$1,xstrdup(interface_filename),hsplineno); } + ; + +readinterface: + interface LEOF + { + exposeis(); /* partain: expose infix ops at level i+1 to level i */ + $$ = $1; + } + ; + +renamings: OPAREN renaming_list CPAREN { $$ = $2; } + ; + +renaming_list: renaming { $$ = lsing($1); } + | renaming_list COMMA renaming { $$ = lapp($1,$3); } + ; + +renaming: var TO var { $$ = ldub($1,$3); } + | con TO con { $$ = ldub($1,$3); } + ; + +maybeiimports : /* empty */ { $$ = mknullbind(); } + | iimports SEMI { $$ = $1; } + ; + +iimports : iimports SEMI iimport { $$ = mkabind($1,$3); } + | iimport { $$ = $1; } + ; + +iimport : importkey modid OPAREN import_list CPAREN + { $$ = mkmbind($2,$4,Lnil,startlineno); } + | importkey modid OPAREN import_list CPAREN RENAMING renamings + { $$ = mkmbind($2,$4,$7,startlineno); } + ; + + +interface: + INTERFACE modid + { fixlist = Lnil; + strcpy(iface_name, id_to_string($2)); + } + WHERE ibody + { + /* WDP: not only do we not check the module name + but we take the one in the interface to be what we really want + -- we need this for Prelude jiggery-pokery. (Blech. KH) + ToDo: possibly revert.... + checkmodname(modname,id_to_string($2)); + */ + $$ = $5; + } + ; + + +ibody : ocurly maybeiimports maybefixes itopdecls ccurly + { + $$ = mkabind($2,$4); + } + | ocurly iimports ccurly + { + $$ = $2; + } + | vocurly maybeiimports maybefixes itopdecls vccurly + { + $$ = mkabind($2,$4); + } + | vocurly iimports vccurly + { + $$ = $2; + } + ; + +maybefixes: /* empty */ + | fixes SEMI + ; + + +fixes : fixes SEMI fix + | fix + ; + +fix : INFIXL INTEGER + { Precedence = checkfixity($2); Fixity = INFIXL; } + ops + | INFIXR INTEGER + { Precedence = checkfixity($2); Fixity = INFIXR; } + ops + | INFIX INTEGER + { Precedence = checkfixity($2); Fixity = INFIX; } + ops + | INFIXL + { Fixity = INFIXL; Precedence = 9; } + ops + | INFIXR + { Fixity = INFIXR; Precedence = 9; } + ops + | INFIX + { Fixity = INFIX; Precedence = 9; } + ops + ; + +ops : op { makeinfix(id_to_string($1),Fixity,Precedence); } + | ops COMMA op { makeinfix(id_to_string($3),Fixity,Precedence); } + ; + +topdecls: topdecls SEMI topdecl + { + if($1 != NULL) + if($3 != NULL) + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + else + $$ = $1; + else + $$ = $3; + SAMEFN = 0; + } + | topdecl + ; + +topdecl : typed { $$ = $1; } + | datad { $$ = $1; } + | classd { $$ = $1; } + | instd { $$ = $1; } + | defaultd { $$ = $1; } + | decl { $$ = $1; } + ; + +typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno,mkno_pramga()); } + ; + + +datad : datakey context DARROW simple EQUAL constrs + { $$ = mktbind($2,$4,$6,all,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs + { $$ = mktbind(Lnil,$2,$4,all,startlineno,mkno_pragma()); } + | datakey context DARROW simple EQUAL constrs DERIVING tyclses + { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs DERIVING tyclses + { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); } + ; + +classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,Lnil); } + | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,Lnil); } + ; + +cbody : /* empty */ { $$ = mknullbind(); } + | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; } + | WHERE vocurly decls vccurly { checkorder($3); $$ =$3; } + ; + + +instd : instkey context DARROW tycls inst rinst { $$ = mkibind($2,$4,$5,$6,startlineno,Lnil); } + | instkey tycls inst rinst { $$ = mkibind(Lnil,$2,$3,$4,startlineno,Lnil); } + ; + +rinst : /* empty */ { $$ = mknullbind(); } + | WHERE ocurly valdefs ccurly { $$ = $3; } + | WHERE vocurly valdefs vccurly { $$ = $3; } + ; + +inst : tycon { $$ = mktname($1,Lnil); } + | OPAREN simple_long CPAREN { $$ = $2; } + /* partain?: "simple" requires k >= 0, not k > 0 (hence "simple_long" hack) */ + | OPAREN tyvar_list CPAREN { $$ = mkttuple($2); } + | OPAREN CPAREN { $$ = mkttuple(Lnil); } + | OBRACK tyvar CBRACK { $$ = mktllist($2); } + | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); } + | OPOD tyvar CPOD { $$ = mktpod($2); } + | OPROC tyvar_pids SEMI tyvar CPROC { $$ = mktproc($2,$4); } + | OPOD tyvar_pids SEMI tyvar CPOD { $$ = mktpod(mktproc($2,$4));} + | OPOD OPROC tyvar_pids SEMI tyvar CPROC CPOD + { $$ = mktpod(mktproc($3,$5)); } + ; + +/* Note (hilly) : Similar to tyvar_list except k>=1 not k>=2 */ + +tyvar_pids : tyvar COMMA tyvar_pids { $$ = mklcons($1,$3); } + | tyvar { $$ = lsing($1); } + ; + +defaultd: defaultkey dtypes + { + $$ = mkdbind($2,startlineno); + } + ; + +dtypes : OPAREN type COMMA types CPAREN { $$ = mklcons($2,$4); } + | ttype { $$ = lsing($1); } +/* Omitting this forces () to be the *type* (), which never defaults. This is a KLUDGE */ +/* | OPAREN CPAREN { $$ = Lnil; }*/ + ; + +decls : decls SEMI decl + { + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + } + | decl + ; + +/* partain: this "DCOLON context" vs "DCOLON type" is a problem, + because you can't distinguish between + + foo :: (Baz a, Baz a) + bar :: (Baz a, Baz a) => [a] -> [a] -> [a] + + with one token of lookahead. The HACK is to have "DCOLON ttype" + [tuple type] in the first case, then check that it has the right + form C a, or (C1 a, C2 b, ... Cn z) and convert it into a + context. Blaach! + (FIXED 90/06/06) +*/ + +decl : vars DCOLON type DARROW type iclasop_pragma + { /* type2context.c for code */ + $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); + PREVPATT = NULL; + FN = NULL; + SAMEFN = 0; + } + | sign + | valdef + | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; } + ; + +sign : vars DCOLON type iclasop_pragma + { + $$ = mksbind($1,$3,startlineno,$4); + PREVPATT = NULL; + FN = NULL; + SAMEFN = 0; + } + ; + + + +itopdecls : itopdecls SEMI itopdecl { $$ = mkabind($1,$3); } + | itopdecl { $$ = $1; } + ; + +itopdecl: ityped { $$ = $1; } + | idatad { $$ = $1; } + | iclassd { $$ = $1; } + | iinstd { $$ = $1; } + | ivarsd { $$ = $1; } + | /* empty */ { $$ = mknullbind(); } + ; + + /* partain: see comment elsewhere about why "type", not "context" */ +ivarsd : vars DCOLON type DARROW type ival_pragma + { $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); } + | vars DCOLON type ival_pragma + { $$ = mksbind($1,$3,startlineno,$4); } + ; + +ityped : typekey simple EQUAL type itype_pragma { $$ = mknbind($2,$4,startlineno,$5); } + ; + +idatad : datakey context DARROW simple idata_pragma { $$ = mktbind($2,$4,Lnil,Lnil,startlineno,$5); } + | datakey simple idata_pragma { $$ = mktbind(Lnil,$2,Lnil,Lnil,startlineno,$3); } + | datakey context DARROW simple EQUAL constrs { $$ = mktbind($2,$4,$6,Lnil,startlineno,mk_nopragma()); } + | datakey simple EQUAL constrs { $$ = mktbind(Lnil,$2,$4,Lnil,startlineno,mk_nopragma()); } + | datakey context DARROW simple EQUAL constrs DERIVING tyclses { $$ = mktbind($2,$4,$6,$8,startlineno,mk_nopragma()); } + | datakey simple EQUAL constrs DERIVING tyclses { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mk_nopragma()); } + ; + + +iclassd : classkey context DARROW class cbody pragmas + { $$ = mkcbind($2,$4,$5,startlineno,$6); } + | classkey class cbody pragmas + { $$ = mkcbind(Lnil,$2,$3,startlineno,$4); } + ; + +iinstd : instkey context DARROW tycls inst pragmas + { $$ = mkibind($2,$4,$5,mknullbind(),startlineno,$6); } + | instkey tycls inst pragmas + { $$ = mkibind(Lnil,$2,$3,mknullbind(),startlineno,$4); } + ; + + +/* obsolete: "(C a, ...)" cause r/r conflict, resolved in favour of context rather than type */ + +class : tycon tyvar { $$ = mktname($1,lsing($2)); } + /* partain: changed "tycls" to "tycon" */ + ; + +types : types COMMA type { $$ = lapp($1,$3); } + | type { $$ = lsing($1); } + ; + +type : btype { $$ = $1; } + | btype RARROW type { $$ = mktfun($1,$3); } + +btype : atype { $$ = $1; } + | tycon atypes { $$ = mktname($1,$2); } + ; + +atypes : atypes atype { $$ = lapp($1,$2); } + | atype { $$ = lsing($1); } + ; + +/* The split with ntatype allows us to use the same syntax for defaults as for types */ +ttype : ntatype { $$ = $1; } + | btype RARROW type { $$ = mktfun($1,$3); } + | tycon atypes { $$ = mktname($1,$2); } + ; + +atype : ntatype + | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); } + ; + +ntatype : tyvar { $$ = $1; } + | tycon { $$ = mktname($1,Lnil); } + | OPAREN CPAREN { $$ = mkttuple(Lnil); } + | OPAREN type CPAREN { $$ = $2; } + | OBRACK type CBRACK { $$ = mktllist($2); } + | OPOD type CPOD { $$ = mktpod($2); } + | OPROC types SEMI type CPROC { $$ = mktproc($2,$4); } + | OPOD types SEMI type CPOD { $$ = mktpod(mktproc($2,$4));} + ; + + +simple : tycon { $$ = mktname($1,Lnil); } + | tycon tyvars { $$ = mktname($1,$2); } + ; + + +simple_long : tycon tyvars { $$ = mktname($1,$2); } + ; /* partain: see comment in "inst" */ + + +constrs : constrs VBAR constr { $$ = lapp($1,$3); } + | constr { $$ = lsing($1); } + ; + +/* Using tycon rather than con avoids 5 S/R errors */ +constr : tycon atypes { $$ = mkatc($1,$2,hsplineno); } + | OPAREN consym CPAREN atypes { $$ = mkatc($2,$4,hsplineno); } + | tycon { $$ = mkatc($1,Lnil,hsplineno); } + | OPAREN consym CPAREN { $$ = mkatc($2,Lnil,hsplineno); } + | btype conop btype { $$ = mkatc($2, ldub($1,$3), hsplineno); } + ; + +tyclses : OPAREN tycls_list CPAREN { $$ = $2; } + | OPAREN CPAREN { $$ = Lnil; } + | tycls { $$ = lsing($1); } + ; + +tycls_list: tycls COMMA tycls_list { $$ = mklcons($1,$3); } + | tycls { $$ = lsing($1); } + ; + +context : OPAREN context_list CPAREN { $$ = $2; } + | class { $$ = lsing($1); } + ; + +context_list: class COMMA context_list { $$ = mklcons($1,$3); } + | class { $$ = lsing($1); } + ; + +valdefs : valdefs SEMI valdef + { + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + } + | valdef { $$ = $1; } + | /* empty */ { $$ = mknullbind(); } + ; + + +vars : vark COMMA varsrest { $$ = mklcons($1,$3); } + | vark { $$ = lsing($1); } + ; + +varsrest: varsrest COMMA var { $$ = lapp($1,$3); } + | var { $$ = lsing($1); } + ; + +cons : cons COMMA con { $$ = lapp($1,$3); } + | con { $$ = lsing($1); } + ; + + +valdef : opatk + { + tree fn = function($1); + + PREVPATT = $1; + + if(ttree(fn) == ident) + { + checksamefn(gident(fn)); + FN = fn; + } + + else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident) + { + checksamefn(gident(ginfun((struct Sap *) fn))); + FN = ginfun((struct Sap *) fn); + } + + else if(etags) + printf("%u\n",startlineno); + } + valrhs + { + if(ispatt($1,TRUE)) + { + $$ = mkpbind($3, startlineno); + FN = NULL; + SAMEFN = 0; + } + else + $$ = mkfbind($3,startlineno); + + PREVPATT = NULL; + } + ; + +valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); } + ; + +valrhs1 : gdrhs + | EQUAL exp { $$ = lsing(mktruecase($2)); } + ; + +gdrhs : gd EQUAL exp { $$ = lsing(ldub($1,$3)); } + | gd EQUAL exp gdrhs { $$ = mklcons(ldub($1,$3),$4); } + ; + +maybe_where: + WHERE ocurly decls ccurly { $$ = $3; } + | WHERE vocurly decls vccurly { $$ = $3; } + | /* empty */ { $$ = mknullbind(); } + ; + +gd : VBAR oexp { $$ = $2; } + ; + + +lampats : apat lampats { $$ = mklcons($1,$2); } + | apat { $$ = lsing($1); } + ; + + +/* + Changed as above to allow for contexts! + KH@21/12/92 +*/ + + +exp : oexp DCOLON type DARROW type { $$ = mkrestr($1,mkcontext(type2context($3),$5)); } + | oexp DCOLON type { $$ = mkrestr($1,$3); } + | oexp + ; + +/* + Operators must be left-associative at the same precedence + for prec. parsing to work. +*/ + + /* Infix operator application */ +oexp : dexp + | oexp op oexp %prec PLUS + { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +/* + This comes here because of the funny precedence rules concerning + prefix minus. +*/ + + +dexp : MINUS kexp { $$ = mknegate($2); } + | kexp + ; + +/* + let/if/lambda/case have higher precedence than infix operators. +*/ + +kexp : LAMBDA + { /* enteriscope(); /? I don't understand this -- KH */ + hsincindent(); /* added by partain; push new context for */ + /* FN = NULL; not actually concerned about */ + FN = NULL; /* indenting */ + $$ = hsplineno; /* remember current line number */ + } + lampats + { hsendindent(); /* added by partain */ + /* exitiscope(); /? Also not understood */ + } + RARROW exp /* lambda abstraction */ + { + $$ = mklambda($3, $6, $2); + } + + /* Let Expression */ + | LET ocurly decls ccurly IN exp { $$ = mklet($3,$6); } + | LET vocurly decls vccurly IN exp { $$ = mklet($3,$6); } + + /* If Expression */ + | IF exp THEN exp ELSE exp { $$ = mkife($2,$4,$6); } + + /* Case Expression */ + | CASE exp OF ocurly alts ccurly { $$ = mkcasee($2,$5); } + | CASE exp OF vocurly alts vccurly { $$ = mkcasee($2,$5); } + + /* CCALL/CASM Expression */ + | CCALL ccallid cexp { $$ = mkccall($2,installid("n"),$3); } + | CCALL ccallid { $$ = mkccall($2,installid("n"),Lnil); } + | CCALL_DANGEROUS ccallid cexp { $$ = mkccall($2,installid("p"),$3); } + | CCALL_DANGEROUS ccallid { $$ = mkccall($2,installid("p"),Lnil); } + | CASM CLITLIT cexp { $$ = mkccall($2,installid("N"),$3); } + | CASM CLITLIT { $$ = mkccall($2,installid("N"),Lnil); } + | CASM_DANGEROUS CLITLIT cexp { $$ = mkccall($2,installid("P"),$3); } + | CASM_DANGEROUS CLITLIT { $$ = mkccall($2,installid("P"),Lnil); } + + /* SCC Expression */ + | SCC STRING exp + { extern BOOLEAN ignoreSCC; + extern BOOLEAN warnSCC; + extern char * input_filename; + + if (ignoreSCC) { + if (warnSCC) + fprintf(stderr, + "\"%s\", line %d: scc (`set [profiling] cost centre') ignored\n", + input_filename, hsplineno); + $$ = $3; + } else { + $$ = mkscc($2, $3); + } + } + | fexp + ; + + + + /* Function application */ +fexp : fexp aexp { $$ = mkap($1,$2); } + | aexp + ; + +cexp : cexp aexp { $$ = lapp($1,$2); } + | aexp { $$ = lsing($1); } + ; + + +/* + The mkpars are so that infix parsing doesn't get confused. + + KH. +*/ + + /* Simple Expressions */ +aexp : var { $$ = mkident($1); } + | con { $$ = mkident($1); } + | literal + | OPAREN exp CPAREN { $$ = mkpar($2); } + | OPAREN oexp op CPAREN { checkprec($2,$3,FALSE); $$ = mklsection($2,$3); } + | OPAREN op1 oexp CPAREN { checkprec($3,$2,TRUE); $$ = mkrsection($2,$3); } + + /* structures */ + | tuple + | list { $$ = mkpar($1); } + | sequence { $$ = mkpar($1); } + | comprehension { $$ = mkpar($1); } + | OPOD exp VBAR parquals CPOD { $$ = mkparzf($2,$4); } + | OPOD exps CPOD { $$ = mkpod($2); } + | processor { $$ = mkpar($1); } + + /* These only occur in patterns */ + | var AT aexp { checkinpat(); $$ = mkas($1,$3); } + | WILDCARD { checkinpat(); $$ = mkwildp(); } + | LAZY aexp { checkinpat(); $$ = mklazyp($2); } + ; + + +processor : OPROC exps SEMI exp CPROC { $$ = mkproc($2,$4); } + ; + +parquals : parquals COMMA parqual { $$ = lapp($1,$3); } + | parqual { $$ = lsing($1); } + ; + +parqual : exp { $$ = mkparfilt($1); } + | processor DRAWNFROM exp + { $$ = mkpardgen($1,$3); + checkpatt($1); + } + | processor INDEXFROM exp + { $$ = mkparigen($1,$3); + checkpatt(gprocdata($1)); + } + ; + + +/* + LHS patterns are parsed in a similar way to + expressions. This avoids the horrible non-LRness + which occurs with the 1.1 syntax. + + The xpatk business is to do with accurately recording + the starting line for definitions. +*/ + +/*TESTTEST +bind : opatk + | vark lampats + { $$ = mkap($1,$2); } + | opatk varop opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + } + ; + +opatk : dpatk + | opatk conop opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + precparse($$); + } + ; + +*/ + +opatk : dpatk + | opatk op opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + + if(isconstr(id_to_string($2))) + precparse($$); + else + { + checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */ + checkprec($3,$2,TRUE); /* then check the right pattern */ + } + } + ; + +opat : dpat + | opat op opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + + if(isconstr(id_to_string($2))) + precparse($$); + else + { + checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */ + checkprec($3,$2,TRUE); /* then check the right pattern */ + } + } + ; + +/* + This comes here because of the funny precedence rules concerning + prefix minus. +*/ + + +dpat : MINUS fpat { $$ = mknegate($2); } + | fpat + ; + + /* Function application */ +fpat : fpat aapat { $$ = mkap($1,$2); } + | aapat + ; + +dpatk : minuskey fpat { $$ = mknegate($2); } + | fpatk + ; + + /* Function application */ +fpatk : fpatk aapat { $$ = mkap($1,$2); } + | aapatk + ; + +aapat : con { $$ = mkident($1); } + | var { $$ = mkident($1); } + | var AT apat { $$ = mkas($1,$3); } + | literal { $$ = $1; } + | WILDCARD { $$ = mkwildp(); } + | OPAREN CPAREN { $$ = mktuple(Lnil); } + | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } + | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } + | OPAREN opat CPAREN { $$ = mkpar($2); } + | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | OBRACK pats CBRACK { $$ = mkllist($2); } + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } + | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); } + ; + +aapatk : conk { $$ = mkident($1); } + | vark { $$ = mkident($1); } + | vark AT apat { $$ = mkas($1,$3); } + | literal { $$ = $1; setstartlineno(); } + | WILDCARD { $$ = mkwildp(); setstartlineno(); } + | oparenkey CPAREN { $$ = mktuple(Lnil); } + | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } + | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } + | oparenkey opat CPAREN { $$ = mkpar($2); } + | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | obrackkey pats CBRACK { $$ = mkllist($2); } + | obrackkey CBRACK { $$ = mkllist(Lnil); } + | lazykey apat { $$ = mklazyp($2); } + | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); } + ; + + +/* + The mkpars are so that infix parsing doesn't get confused. + + KH. +*/ + +tuple : OPAREN exp COMMA texps CPAREN + { if (ttree($4) == tuple) + $$ = mktuple(mklcons($2, gtuplelist($4))); + else + $$ = mktuple(ldub($2, $4)); + } + | OPAREN CPAREN + { $$ = mktuple(Lnil); } + ; + +texps : exp COMMA texps + { if (ttree($3) == tuple) + $$ = mktuple(mklcons($1, gtuplelist($3))); + else + $$ = mktuple(ldub($1, $3)); + } + | exp { $$ = mkpar($1); } + ; + + +list : OBRACK CBRACK { $$ = mkllist(Lnil); } + | OBRACK exps CBRACK { $$ = mkllist($2); } + ; + +exps : exp COMMA exps { $$ = mklcons($1,$3); } + | exp { $$ = lsing($1); } + ; + + +sequence: OBRACK exp COMMA exp DOTDOT upto CBRACK {$$ = mkeenum($2,lsing($4),$6);} + | OBRACK exp DOTDOT upto CBRACK { $$ = mkeenum($2,Lnil,$4); } + ; + +comprehension: OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); } + ; + +quals : quals COMMA qual { $$ = lapp($1,$3); } + | qual { $$ = lsing($1); } + ; + +qual : { inpat = TRUE; } exp { inpat = FALSE; } qualrest + { if ($4 == NULL) + $$ = mkguard($2); + else + { + checkpatt($2); + if(ttree($4)==def) + { + tree prevpatt_save = PREVPATT; + PREVPATT = $2; + $$ = mkdef(mkpbind(lsing(createpat(lsing(mktruecase((tree)(ggdef($4)))),mknullbind())),hsplineno)); + PREVPATT = prevpatt_save; + } + else + $$ = mkqual($2,$4); + } + } + ; + +qualrest: LARROW exp { $$ = $2; } +/* OLD: + | EQUAL exp + { if(nonstandardFlag) + $$ = mkdef($2); + else + hsperror("Definitions in comprehensions are not standard Haskell"); + } +*/ + | /* empty */ { $$ = NULL; } + ; + + +alts : alts SEMI alt { $$ = lconc($1,$3); } + | alt { $$ = $1; } + ; + +alt : pat + { PREVPATT = $1; } + altrest + { $$ = $3; + PREVPATT = NULL; + } + | /* empty */ { $$ = Lnil; } + ; + +altrest : gdpat maybe_where { $$ = lsing(createpat($1,$2)); } + | RARROW exp maybe_where { $$ = lsing(createpat(lsing(mktruecase($2)),$3)); } + ; + +gdpat : gd RARROW exp gdpat { $$ = mklcons(ldub($1,$3),$4); } + | gd RARROW exp { $$ = lsing(ldub($1,$3)); } + ; + +upto : /* empty */ { $$ = Lnil; } + | exp { $$ = lsing($1); } + ; + +pats : pat COMMA pats { $$ = mklcons($1,$3); } + | pat { $$ = lsing($1); } + ; + +pat : bpat + | pat conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +bpat : apatc + | conpat + | MINUS INTEGER { $$ = mkinteger(ineg($2)); } + | MINUS FLOAT { $$ = mkfloatr(ineg($2)); } + ; + +conpat : con { $$ = mkident($1); } + | conpat apat { $$ = mkap($1,$2); } + ; + +apat : con { $$ = mkident($1); } + | apatc + ; + +apatc : var { $$ = mkident($1); } + | var AT apat { $$ = mkas($1,$3); } + | literal { $$ = $1; } + | WILDCARD { $$ = mkwildp(); } + | OPAREN CPAREN { $$ = mktuple(Lnil); } + | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } + | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } + | OPAREN pat CPAREN { $$ = mkpar($2); } + | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | OBRACK pats CBRACK { $$ = mkllist($2); } + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } + | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); } + ; + +/* +patk : bpatk + | patk conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +bpatk : apatck + | conpatk + | minuskey INTEGER { $$ = mkinteger(ineg($2)); } + | minuskey FLOAT { $$ = mkfloatr(ineg($2)); } + ; + +conpatk : conk { $$ = mkident($1); } + | conpatk apat { $$ = mkap($1,$2); } + ; + +apatck : vark { $$ = mkident($1); } + | vark AT apat { $$ = mkas($1,$3); } + | literal { $$ = $1; setstartlineno(); } + | WILDCARD { $$ = mkwildp(); setstartlineno(); } + | oparenkey CPAREN { $$ = mktuple(Lnil); } + | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } + | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } + | oparenkey pat CPAREN { $$ = mkpar($2); } + | oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | obrackkey pats CBRACK { $$ = mkllist($2); } + | obrackkey CBRACK { $$ = mkllist(Lnil); } + | lazykey apat { $$ = mklazyp($2); } + | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); } + ; +*/ + +literal : INTEGER { $$ = mkinteger($1); } + | FLOAT { $$ = mkfloatr($1); } + | CHAR { $$ = mkcharr($1); } + | STRING { $$ = mkstring($1); } + | CHARPRIM { $$ = mkcharprim($1); } + | INTPRIM { $$ = mkintprim($1); } + | FLOATPRIM { $$ = mkfloatprim($1); } + | DOUBLEPRIM { $$ = mkdoubleprim($1); } + | CLITLIT { $$ = mkclitlit($1); } + | VOIDPRIM { $$ = mkvoidprim(); } + ; + + +/* Keywords which record the line start */ + +importkey: IMPORT { setstartlineno(); } + ; + +datakey : DATA { setstartlineno(); + if(etags) + printf("%u\n",startlineno); + } + ; + +typekey : TYPE { setstartlineno(); + if(etags) + printf("%u\n",startlineno); + } + ; + +instkey : INSTANCE { setstartlineno(); + if(etags) + printf("%u\n",startlineno); + } + ; + +defaultkey: DEFAULT { setstartlineno(); } + ; + +classkey: CLASS { setstartlineno(); + if(etags) + printf("%u\n",startlineno); + } + ; + +minuskey: MINUS { setstartlineno(); } + ; + +oparenkey: OPAREN { setstartlineno(); } + ; + +obrackkey: OBRACK { setstartlineno(); } + ; + +lazykey : LAZY { setstartlineno(); } + ; + +oprockey: OPROC { setstartlineno(); } + ; + + +/* Non "-" op, used in right sections -- KH */ +op1 : conop + | varop1 + ; + +op : conop + | varop + ; + +varop : varsym + | BQUOTE varid BQUOTE { $$ = $2; } + ; + +/* Non-minus varop, used in right sections */ +varop1 : VARSYM + | plus + | BQUOTE varid BQUOTE { $$ = $2; } + ; + +conop : consym + | BQUOTE conid BQUOTE { $$ = $2; } + ; + +consym : CONSYM + ; + +varsym : VARSYM + | plus + | minus + ; + +minus : MINUS { $$ = install_literal("-"); } + ; + +plus : PLUS { $$ = install_literal("+"); } + ; + +var : VARID + | OPAREN varsym CPAREN { $$ = $2; } + ; + +vark : VARID { setstartlineno(); $$ = $1; } + | oparenkey varsym CPAREN { $$ = $2; } + ; + +/* tycon used here to eliminate 11 spurious R/R errors -- KH */ +con : tycon + | OPAREN consym CPAREN { $$ = $2; } + ; + +conk : tycon { setstartlineno(); $$ = $1; } + | oparenkey consym CPAREN { $$ = $2; } + ; + +varid : VARID + ; + +conid : CONID + ; + +ccallid : varid + | conid + ; + +/* partain: "tyvar_list" must be at least 2 elements long (defn of "inst") */ +tyvar_list: tyvar COMMA tyvar_list { $$ = mklcons($1,$3); } + | tyvar COMMA tyvar { $$ = mklcons($1,lsing($3)); } + ; + +tyvars : tyvar tyvars { $$ = mklcons($1,$2); } + | tyvar { $$ = lsing($1); } + ; + +tyvar : VARID { $$ = mknamedtvar($1); } + ; + +tycls : tycon + /* partain: "aconid"->"tycon" got rid of a r/r conflict + (and introduced >= 2 s/r's ...) + */ + ; + +tycon : conid + ; + +modid : CONID + ; + + +ocurly : layout OCURLY { hsincindent(); } + +vocurly : layout { hssetindent(); } + ; + +layout : { hsindentoff(); } + ; + +ccurly : + CCURLY + { + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + ; + +vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; } + ; + +vccurly1: + VCCURLY + { + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + | error + { + yyerrok; + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + ; + +%% diff --git a/ghc/compiler/yaccParser/hsparser.tab.c b/ghc/compiler/yaccParser/hsparser.tab.c new file mode 100644 index 0000000..7b0fec0 --- /dev/null +++ b/ghc/compiler/yaccParser/hsparser.tab.c @@ -0,0 +1,4665 @@ + +/* A Bison parser, made from yaccParser/hsparser.y with Bison version GNU Bison version 1.21 + */ + +#define YYBISON 1 /* Identify Bison output. */ + +#define VARID 258 +#define CONID 259 +#define VARSYM 260 +#define CONSYM 261 +#define MINUS 262 +#define INTEGER 263 +#define FLOAT 264 +#define CHAR 265 +#define STRING 266 +#define CHARPRIM 267 +#define STRINGPRIM 268 +#define INTPRIM 269 +#define FLOATPRIM 270 +#define DOUBLEPRIM 271 +#define CLITLIT 272 +#define OCURLY 273 +#define CCURLY 274 +#define VCCURLY 275 +#define SEMI 276 +#define OBRACK 277 +#define CBRACK 278 +#define OPAREN 279 +#define CPAREN 280 +#define COMMA 281 +#define BQUOTE 282 +#define RARROW 283 +#define VBAR 284 +#define EQUAL 285 +#define DARROW 286 +#define DOTDOT 287 +#define DCOLON 288 +#define LARROW 289 +#define WILDCARD 290 +#define AT 291 +#define LAZY 292 +#define LAMBDA 293 +#define LET 294 +#define IN 295 +#define WHERE 296 +#define CASE 297 +#define OF 298 +#define TYPE 299 +#define DATA 300 +#define CLASS 301 +#define INSTANCE 302 +#define DEFAULT 303 +#define INFIX 304 +#define INFIXL 305 +#define INFIXR 306 +#define MODULE 307 +#define IMPORT 308 +#define INTERFACE 309 +#define HIDING 310 +#define CCALL 311 +#define CCALL_GC 312 +#define CASM 313 +#define CASM_GC 314 +#define SCC 315 +#define IF 316 +#define THEN 317 +#define ELSE 318 +#define RENAMING 319 +#define DERIVING 320 +#define TO 321 +#define LEOF 322 +#define GHC_PRAGMA 323 +#define END_PRAGMA 324 +#define NO_PRAGMA 325 +#define NOINFO_PRAGMA 326 +#define ABSTRACT_PRAGMA 327 +#define SPECIALISE_PRAGMA 328 +#define MODNAME_PRAGMA 329 +#define ARITY_PRAGMA 330 +#define UPDATE_PRAGMA 331 +#define STRICTNESS_PRAGMA 332 +#define KIND_PRAGMA 333 +#define UNFOLDING_PRAGMA 334 +#define MAGIC_UNFOLDING_PRAGMA 335 +#define DEFOREST_PRAGMA 336 +#define SPECIALISE_UPRAGMA 337 +#define INLINE_UPRAGMA 338 +#define MAGIC_UNFOLDING_UPRAGMA 339 +#define ABSTRACT_UPRAGMA 340 +#define DEFOREST_UPRAGMA 341 +#define END_UPRAGMA 342 +#define TYLAMBDA 343 +#define COCON 344 +#define COPRIM 345 +#define COAPP 346 +#define COTYAPP 347 +#define FORALL 348 +#define TYVAR_TEMPLATE_ID 349 +#define CO_ALG_ALTS 350 +#define CO_PRIM_ALTS 351 +#define CO_NO_DEFAULT 352 +#define CO_LETREC 353 +#define CO_SDSEL_ID 354 +#define CO_METH_ID 355 +#define CO_DEFM_ID 356 +#define CO_DFUN_ID 357 +#define CO_CONSTM_ID 358 +#define CO_SPEC_ID 359 +#define CO_WRKR_ID 360 +#define CO_ORIG_NM 361 +#define UNFOLD_ALWAYS 362 +#define UNFOLD_IF_ARGS 363 +#define NOREP_INTEGER 364 +#define NOREP_RATIONAL 365 +#define NOREP_STRING 366 +#define CO_PRELUDE_DICTS_CC 367 +#define CO_ALL_DICTS_CC 368 +#define CO_USER_CC 369 +#define CO_AUTO_CC 370 +#define CO_DICT_CC 371 +#define CO_CAF_CC 372 +#define CO_DUPD_CC 373 +#define PLUS 374 + +#line 22 "yaccParser/hsparser.y" + +#ifdef HSP_DEBUG +# define YYDEBUG 1 +#endif + +#include +#include +#include +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/********************************************************************** +* * +* * +* Imported Variables and Functions * +* * +* * +**********************************************************************/ + +BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */ + +extern BOOLEAN nonstandardFlag; +extern BOOLEAN etags; + +extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *)); + +extern char *input_filename; +static char *the_module_name; +static char iface_name[MODNAME_SIZE]; +static char interface_filename[FILENAME_SIZE]; + +static list module_exports; /* Exported entities */ +static list prelude_core_import, prelude_imports; + /* Entities imported from the Prelude */ + +extern list all; /* All valid deriving classes */ + +extern tree niltree; +extern list Lnil; + +extern tree root; + +/* For FN, PREVPATT and SAMEFN macros */ +extern tree fns[]; +extern short samefn[]; +extern tree prevpatt[]; +extern short icontexts; + +/* Line Numbers */ +extern int hsplineno, hspcolno; +extern int startlineno; + + +/********************************************************************** +* * +* * +* Fixity and Precedence Declarations * +* * +* * +**********************************************************************/ + +list fixlist; +static int Fixity = 0, Precedence = 0; +struct infix; + +char *ineg PROTO((char *)); + +static BOOLEAN hidden = FALSE; /* Set when HIDING used */ + +extern BOOLEAN inpat; /* True when parsing a pattern */ +extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */ +extern BOOLEAN haskell1_3Flag; /* True if we are attempting (proto)Haskell 1.3 */ + +extern int thisIfacePragmaVersion; + + +#line 100 "yaccParser/hsparser.y" +typedef union { + tree utree; + list ulist; + ttype uttype; + atype uatype; + binding ubinding; + pbinding upbinding; + finfot ufinfo; + entidt uentid; + id uid; + literal uliteral; + int uint; + float ufloat; + char *ustring; + hstring uhstring; + hpragma uhpragma; + coresyn ucoresyn; +} YYSTYPE; + +#ifndef YYLTYPE +typedef + struct yyltype + { + int timestamp; + int first_line; + int first_column; + int last_line; + int last_column; + char *text; + } + yyltype; + +#define YYLTYPE yyltype +#endif + +#include + +#ifndef __cplusplus +#ifndef __STDC__ +#define const +#endif +#endif + + + +#define YYFINAL 1094 +#define YYFLAG -32768 +#define YYNTBASE 120 + +#define YYTRANSLATE(x) ((unsigned)(x) <= 374 ? yytranslate[x] : 347) + +static const char yytranslate[] = { 0, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 1, 2, 3, 4, 5, + 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, + 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, + 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, + 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, + 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, + 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, + 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, + 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, + 116, 117, 118, 119 +}; + +#if YYDEBUG != 0 +static const short yyprhs[] = { 0, + 0, 4, 5, 12, 13, 16, 22, 28, 32, 36, + 40, 44, 45, 49, 51, 55, 57, 59, 64, 69, + 74, 78, 81, 85, 90, 93, 94, 96, 98, 102, + 104, 106, 111, 116, 121, 125, 130, 134, 135, 138, + 139, 141, 145, 149, 153, 154, 158, 159, 164, 165, + 170, 176, 182, 183, 186, 187, 190, 194, 195, 197, + 204, 206, 209, 211, 214, 216, 218, 220, 223, 227, + 231, 232, 234, 237, 241, 243, 249, 251, 255, 257, + 260, 262, 266, 272, 274, 278, 285, 287, 291, 293, + 295, 296, 298, 300, 304, 308, 313, 318, 323, 330, + 335, 339, 345, 352, 361, 368, 374, 376, 378, 382, + 386, 387, 390, 396, 397, 400, 405, 407, 411, 413, + 417, 421, 424, 429, 436, 443, 450, 452, 454, 456, + 458, 462, 466, 470, 476, 483, 489, 492, 496, 500, + 502, 504, 513, 522, 531, 540, 542, 543, 546, 552, + 555, 559, 561, 565, 567, 569, 571, 574, 576, 580, + 583, 587, 589, 593, 595, 597, 601, 603, 605, 606, + 609, 610, 613, 614, 617, 619, 623, 624, 629, 632, + 637, 640, 644, 646, 650, 654, 658, 659, 662, 664, + 668, 674, 682, 683, 689, 695, 699, 705, 709, 710, + 713, 715, 719, 720, 725, 726, 731, 732, 737, 738, + 742, 743, 747, 748, 752, 754, 758, 760, 764, 766, + 768, 770, 772, 774, 776, 781, 788, 793, 802, 809, + 815, 819, 820, 825, 830, 837, 842, 843, 848, 853, + 855, 859, 863, 866, 870, 876, 879, 885, 887, 889, + 893, 900, 905, 911, 917, 923, 928, 933, 937, 941, + 943, 944, 945, 947, 949, 953, 955, 959, 961, 965, + 967, 969, 971, 973, 975, 976, 983, 988, 994, 1000, + 1004, 1012, 1018, 1027, 1034, 1041, 1046, 1053, 1058, 1061, + 1063, 1067, 1069, 1073, 1078, 1080, 1083, 1086, 1088, 1090, + 1094, 1097, 1099, 1105, 1107, 1109, 1112, 1116, 1120, 1127, + 1129, 1131, 1134, 1137, 1139, 1143, 1146, 1151, 1153, 1157, + 1161, 1165, 1168, 1170, 1172, 1176, 1180, 1182, 1184, 1188, + 1189, 1191, 1195, 1200, 1205, 1207, 1211, 1213, 1215, 1219, + 1221, 1225, 1226, 1230, 1233, 1235, 1238, 1242, 1247, 1252, + 1257, 1258, 1261, 1264, 1266, 1272, 1276, 1278, 1280, 1284, + 1287, 1289, 1290, 1291, 1298, 1305, 1312, 1319, 1326, 1333, + 1337, 1340, 1344, 1347, 1351, 1354, 1358, 1361, 1365, 1367, + 1370, 1372, 1375, 1377, 1379, 1381, 1383, 1387, 1392, 1397, + 1399, 1401, 1403, 1405, 1409, 1411, 1414, 1416, 1420, 1422, + 1426, 1429, 1431, 1434, 1436, 1439, 1441, 1444, 1446, 1448, + 1450, 1454, 1456, 1458, 1461, 1467, 1471, 1477, 1481, 1484, + 1487, 1489, 1491, 1495, 1497, 1499, 1502, 1508, 1512, 1518, + 1522, 1525, 1528, 1534, 1537, 1539, 1543, 1546, 1550, 1552, + 1556, 1564, 1570, 1576, 1578, 1582, 1583, 1584, 1589, 1592, + 1593, 1595, 1599, 1600, 1604, 1605, 1608, 1612, 1617, 1621, + 1622, 1624, 1628, 1630, 1632, 1636, 1638, 1640, 1643, 1646, + 1648, 1651, 1653, 1655, 1657, 1661, 1663, 1665, 1668, 1674, + 1678, 1684, 1688, 1691, 1694, 1696, 1698, 1700, 1702, 1704, + 1706, 1708, 1710, 1712, 1714, 1718, 1721, 1725, 1728, 1730, + 1732, 1734, 1736, 1738, 1740, 1742, 1744, 1746, 1748, 1750, + 1752, 1754, 1756, 1758, 1760, 1764, 1766, 1768, 1772, 1774, + 1778, 1780, 1782, 1784, 1786, 1788, 1790, 1794, 1796, 1800, + 1802, 1806, 1808, 1812, 1814, 1816, 1820, 1824, 1826, 1829, + 1831, 1833, 1835, 1837, 1840, 1842, 1843, 1845, 1846, 1849, + 1851 +}; + +static const short yyrhs[] = { 188, + 190, 121, 0, 0, 317, 339, 125, 122, 41, 124, + 0, 0, 123, 124, 0, 340, 192, 207, 217, 343, + 0, 341, 192, 207, 217, 344, 0, 341, 193, 344, + 0, 340, 193, 343, 0, 341, 192, 344, 0, 340, + 192, 343, 0, 0, 24, 126, 25, 0, 127, 0, + 126, 26, 127, 0, 329, 0, 338, 0, 338, 24, + 32, 25, 0, 338, 24, 260, 25, 0, 338, 24, + 258, 25, 0, 338, 24, 25, 0, 338, 32, 0, + 24, 130, 25, 0, 55, 24, 130, 25, 0, 24, + 25, 0, 0, 128, 0, 131, 0, 130, 26, 131, + 0, 329, 0, 338, 0, 338, 24, 32, 25, 0, + 338, 24, 260, 25, 0, 338, 24, 258, 25, 0, + 338, 24, 25, 0, 68, 250, 133, 69, 0, 68, + 133, 69, 0, 0, 73, 134, 0, 0, 135, 0, + 134, 26, 135, 0, 22, 157, 23, 0, 68, 72, + 69, 0, 0, 68, 151, 69, 0, 0, 68, 143, + 143, 69, 0, 0, 68, 140, 143, 69, 0, 68, + 140, 143, 160, 69, 0, 68, 140, 143, 141, 69, + 0, 0, 74, 339, 0, 0, 73, 155, 0, 68, + 143, 69, 0, 0, 71, 0, 144, 145, 146, 147, + 149, 152, 0, 70, 0, 75, 8, 0, 70, 0, + 76, 8, 0, 70, 0, 81, 0, 70, 0, 77, + 89, 0, 77, 11, 148, 0, 18, 143, 19, 0, + 0, 70, 0, 80, 330, 0, 79, 150, 162, 0, + 107, 0, 108, 8, 8, 4, 8, 0, 143, 0, + 151, 26, 143, 0, 70, 0, 73, 153, 0, 154, + 0, 153, 26, 154, 0, 22, 157, 23, 8, 148, + 0, 156, 0, 155, 26, 156, 0, 22, 157, 23, + 8, 148, 159, 0, 158, 0, 157, 26, 158, 0, + 70, 0, 242, 0, 0, 160, 0, 161, 0, 160, + 26, 161, 0, 329, 30, 143, 0, 38, 176, 28, + 162, 0, 88, 181, 28, 162, 0, 89, 331, 183, + 178, 0, 89, 106, 339, 331, 183, 178, 0, 90, + 175, 183, 178, 0, 91, 162, 178, 0, 92, 162, + 18, 185, 19, 0, 42, 162, 43, 18, 163, 19, + 0, 39, 18, 177, 30, 162, 19, 40, 162, 0, + 98, 18, 169, 19, 40, 162, 0, 60, 18, 171, + 19, 162, 0, 309, 0, 174, 0, 95, 164, 168, + 0, 96, 166, 168, 0, 0, 164, 165, 0, 174, + 176, 28, 162, 21, 0, 0, 166, 167, 0, 309, + 28, 162, 21, 0, 97, 0, 177, 28, 162, 0, + 170, 0, 169, 21, 170, 0, 177, 30, 162, 0, + 112, 173, 0, 113, 11, 11, 173, 0, 114, 11, + 11, 11, 173, 172, 0, 115, 174, 11, 11, 173, + 172, 0, 116, 174, 11, 11, 173, 172, 0, 70, + 0, 117, 0, 70, 0, 118, 0, 99, 338, 338, + 0, 100, 338, 329, 0, 101, 338, 329, 0, 102, + 338, 24, 185, 25, 0, 103, 338, 329, 24, 185, + 25, 0, 104, 174, 22, 186, 23, 0, 105, 174, + 0, 106, 339, 329, 0, 106, 339, 331, 0, 329, + 0, 331, 0, 24, 56, 333, 18, 183, 185, 19, + 25, 0, 24, 57, 333, 18, 183, 185, 19, 25, + 0, 24, 58, 309, 18, 183, 185, 19, 25, 0, + 24, 59, 309, 18, 183, 185, 19, 25, 0, 3, + 0, 0, 176, 177, 0, 24, 3, 33, 185, 25, + 0, 22, 23, 0, 22, 179, 23, 0, 180, 0, + 179, 26, 180, 0, 309, 0, 174, 0, 3, 0, + 181, 3, 0, 94, 0, 182, 26, 94, 0, 22, + 23, 0, 22, 184, 23, 0, 185, 0, 184, 26, + 185, 0, 242, 0, 187, 0, 186, 26, 187, 0, + 70, 0, 185, 0, 0, 189, 197, 0, 0, 191, + 197, 0, 0, 193, 21, 0, 194, 0, 193, 21, + 194, 0, 0, 53, 339, 195, 196, 0, 197, 129, + 0, 197, 129, 64, 198, 0, 204, 67, 0, 24, + 199, 25, 0, 200, 0, 199, 26, 200, 0, 329, + 66, 329, 0, 331, 66, 331, 0, 0, 202, 21, + 0, 203, 0, 202, 21, 203, 0, 310, 339, 24, + 130, 25, 0, 310, 339, 24, 130, 25, 64, 198, + 0, 0, 54, 339, 205, 41, 206, 0, 340, 201, + 207, 233, 343, 0, 340, 202, 343, 0, 341, 201, + 207, 233, 344, 0, 341, 202, 344, 0, 0, 208, + 21, 0, 209, 0, 208, 21, 209, 0, 0, 50, + 8, 210, 216, 0, 0, 51, 8, 211, 216, 0, + 0, 49, 8, 212, 216, 0, 0, 50, 213, 216, + 0, 0, 51, 214, 216, 0, 0, 49, 215, 216, + 0, 322, 0, 216, 26, 322, 0, 218, 0, 217, + 21, 218, 0, 219, 0, 220, 0, 221, 0, 223, + 0, 226, 0, 229, 0, 312, 248, 30, 242, 0, + 311, 254, 31, 248, 30, 250, 0, 311, 248, 30, + 250, 0, 311, 254, 31, 248, 30, 250, 65, 252, + 0, 311, 248, 30, 250, 65, 252, 0, 315, 254, + 31, 240, 222, 0, 315, 240, 222, 0, 0, 41, + 340, 228, 343, 0, 41, 341, 228, 344, 0, 313, + 254, 31, 337, 225, 224, 0, 313, 337, 225, 224, + 0, 0, 41, 340, 256, 343, 0, 41, 341, 256, + 344, 0, 338, 0, 24, 249, 25, 0, 24, 334, + 25, 0, 24, 25, 0, 22, 246, 23, 0, 24, + 246, 28, 246, 25, 0, 314, 227, 0, 24, 242, + 26, 241, 25, 0, 245, 0, 229, 0, 228, 21, + 229, 0, 258, 33, 242, 31, 242, 138, 0, 258, + 33, 242, 138, 0, 82, 330, 33, 231, 87, 0, + 82, 47, 4, 225, 87, 0, 82, 45, 338, 244, + 87, 0, 83, 330, 230, 87, 0, 84, 330, 330, + 87, 0, 86, 330, 87, 0, 85, 338, 87, 0, + 261, 0, 0, 0, 4, 0, 232, 0, 231, 26, + 232, 0, 242, 0, 242, 30, 330, 0, 234, 0, + 233, 21, 234, 0, 236, 0, 237, 0, 238, 0, + 239, 0, 235, 0, 0, 258, 33, 242, 31, 242, + 142, 0, 258, 33, 242, 142, 0, 312, 248, 30, + 242, 136, 0, 311, 254, 31, 248, 132, 0, 311, + 248, 132, 0, 311, 254, 31, 248, 30, 250, 132, + 0, 311, 248, 30, 250, 132, 0, 311, 254, 31, + 248, 30, 250, 65, 252, 0, 311, 248, 30, 250, + 65, 252, 0, 315, 254, 31, 240, 137, 222, 0, + 315, 240, 137, 222, 0, 313, 254, 31, 337, 225, + 139, 0, 313, 337, 225, 139, 0, 338, 336, 0, + 242, 0, 241, 26, 242, 0, 243, 0, 243, 28, + 242, 0, 93, 182, 31, 242, 0, 246, 0, 338, + 244, 0, 244, 246, 0, 246, 0, 247, 0, 243, + 28, 242, 0, 338, 244, 0, 247, 0, 24, 242, + 26, 241, 25, 0, 336, 0, 338, 0, 24, 25, + 0, 24, 242, 25, 0, 22, 242, 23, 0, 18, + 18, 4, 242, 19, 19, 0, 94, 0, 338, 0, + 338, 335, 0, 338, 244, 0, 251, 0, 250, 29, + 251, 0, 338, 244, 0, 24, 6, 25, 244, 0, + 338, 0, 24, 6, 25, 0, 243, 325, 243, 0, + 24, 253, 25, 0, 24, 25, 0, 337, 0, 337, + 0, 253, 26, 337, 0, 24, 255, 25, 0, 240, + 0, 240, 0, 255, 26, 240, 0, 0, 257, 0, + 256, 21, 257, 0, 83, 330, 230, 87, 0, 84, + 330, 330, 87, 0, 261, 0, 330, 26, 259, 0, + 330, 0, 329, 0, 259, 26, 329, 0, 331, 0, + 260, 26, 331, 0, 0, 278, 262, 263, 0, 264, + 266, 0, 265, 0, 30, 269, 0, 267, 30, 269, + 0, 267, 30, 269, 265, 0, 41, 340, 228, 343, + 0, 41, 341, 228, 344, 0, 0, 29, 270, 0, + 307, 268, 0, 307, 0, 270, 33, 242, 31, 242, + 0, 270, 33, 242, 0, 270, 0, 271, 0, 270, + 322, 270, 0, 7, 272, 0, 272, 0, 0, 0, + 38, 273, 268, 274, 28, 269, 0, 39, 340, 228, + 343, 40, 269, 0, 39, 341, 228, 344, 40, 269, + 0, 61, 269, 62, 269, 63, 269, 0, 42, 269, + 43, 340, 297, 343, 0, 42, 269, 43, 341, 297, + 344, 0, 56, 333, 276, 0, 56, 333, 0, 57, + 333, 276, 0, 57, 333, 0, 58, 17, 276, 0, + 58, 17, 0, 59, 17, 276, 0, 59, 17, 0, + 60, 11, 269, 0, 275, 0, 275, 277, 0, 277, + 0, 276, 277, 0, 277, 0, 329, 0, 331, 0, + 309, 0, 24, 269, 25, 0, 24, 270, 322, 25, + 0, 24, 321, 270, 25, 0, 286, 0, 288, 0, + 290, 0, 291, 0, 329, 36, 277, 0, 35, 0, + 37, 277, 0, 282, 0, 278, 322, 279, 0, 280, + 0, 279, 322, 279, 0, 7, 281, 0, 281, 0, + 281, 284, 0, 284, 0, 316, 281, 0, 283, 0, + 283, 284, 0, 285, 0, 331, 0, 329, 0, 329, + 36, 307, 0, 309, 0, 35, 0, 24, 25, 0, + 24, 329, 119, 8, 25, 0, 24, 279, 25, 0, + 24, 279, 26, 303, 25, 0, 22, 303, 23, 0, + 22, 23, 0, 37, 307, 0, 332, 0, 330, 0, + 330, 36, 307, 0, 309, 0, 35, 0, 318, 25, + 0, 318, 329, 119, 8, 25, 0, 318, 279, 25, + 0, 318, 279, 26, 303, 25, 0, 319, 303, 23, + 0, 319, 23, 0, 320, 307, 0, 24, 269, 26, + 287, 25, 0, 24, 25, 0, 269, 0, 269, 26, + 287, 0, 22, 23, 0, 22, 289, 23, 0, 269, + 0, 269, 26, 289, 0, 22, 269, 26, 269, 32, + 302, 23, 0, 22, 269, 32, 302, 23, 0, 22, + 269, 29, 292, 23, 0, 293, 0, 292, 26, 293, + 0, 0, 0, 294, 269, 295, 296, 0, 34, 269, + 0, 0, 298, 0, 297, 21, 298, 0, 0, 304, + 299, 300, 0, 0, 301, 266, 0, 28, 269, 266, + 0, 267, 28, 269, 301, 0, 267, 28, 269, 0, + 0, 269, 0, 304, 26, 303, 0, 304, 0, 305, + 0, 304, 325, 305, 0, 308, 0, 306, 0, 7, + 8, 0, 7, 9, 0, 331, 0, 306, 307, 0, + 331, 0, 308, 0, 329, 0, 329, 36, 307, 0, + 309, 0, 35, 0, 24, 25, 0, 24, 329, 119, + 8, 25, 0, 24, 304, 25, 0, 24, 304, 26, + 303, 25, 0, 22, 303, 23, 0, 22, 23, 0, + 37, 307, 0, 8, 0, 9, 0, 10, 0, 11, + 0, 12, 0, 13, 0, 14, 0, 15, 0, 16, + 0, 17, 0, 17, 78, 4, 0, 109, 8, 0, + 110, 8, 8, 0, 111, 11, 0, 53, 0, 45, + 0, 44, 0, 47, 0, 48, 0, 46, 0, 7, + 0, 52, 0, 24, 0, 22, 0, 37, 0, 325, + 0, 324, 0, 325, 0, 323, 0, 326, 0, 27, + 3, 27, 0, 5, 0, 328, 0, 27, 3, 27, + 0, 6, 0, 27, 4, 27, 0, 5, 0, 328, + 0, 327, 0, 7, 0, 119, 0, 3, 0, 24, + 326, 25, 0, 3, 0, 318, 326, 25, 0, 338, + 0, 24, 6, 25, 0, 338, 0, 318, 6, 25, + 0, 3, 0, 4, 0, 246, 26, 246, 0, 246, + 26, 334, 0, 336, 0, 335, 336, 0, 3, 0, + 338, 0, 4, 0, 4, 0, 342, 18, 0, 342, + 0, 0, 19, 0, 0, 345, 346, 0, 20, 0, + 1, 0 +}; + +#endif + +#if YYDEBUG != 0 +static const short yyrline[] = { 0, + 331, 334, 336, 337, 339, 342, 346, 351, 355, 361, + 365, 372, 373, 376, 378, 381, 383, 384, 385, 389, + 393, 397, 404, 405, 406, 409, 410, 413, 415, 418, + 420, 421, 422, 426, 430, 438, 441, 443, 446, 449, + 452, 454, 458, 462, 464, 467, 469, 472, 475, 479, + 483, 486, 489, 493, 496, 500, 503, 506, 510, 513, + 517, 519, 522, 524, 527, 529, 532, 534, 537, 541, + 543, 545, 547, 549, 553, 556, 560, 562, 565, 567, + 570, 572, 575, 580, 582, 585, 590, 592, 595, 597, + 600, 602, 605, 607, 610, 619, 622, 624, 626, 628, + 630, 632, 634, 636, 638, 640, 642, 643, 646, 649, + 653, 655, 658, 663, 665, 668, 672, 674, 677, 679, + 682, 686, 688, 689, 691, 693, 696, 697, 699, 700, + 702, 704, 705, 706, 708, 710, 712, 713, 714, 715, + 716, 719, 722, 724, 726, 728, 731, 733, 736, 739, + 741, 744, 746, 749, 751, 754, 756, 759, 761, 764, + 766, 769, 771, 774, 794, 796, 799, 801, 806, 821, + 828, 842, 849, 850, 853, 854, 857, 879, 885, 889, + 893, 901, 904, 906, 909, 910, 913, 914, 917, 918, + 921, 923, 928, 933, 946, 950, 954, 958, 964, 965, + 969, 970, 973, 976, 976, 979, 979, 982, 982, 985, + 985, 988, 988, 991, 993, 994, 997, 998, 1017, 1018, + 1019, 1020, 1021, 1022, 1025, 1029, 1031, 1033, 1035, 1039, + 1040, 1043, 1044, 1045, 1048, 1049, 1052, 1053, 1054, 1057, + 1058, 1060, 1061, 1062, 1063, 1066, 1069, 1070, 1077, 1078, + 1107, 1112, 1125, 1131, 1137, 1143, 1149, 1155, 1161, 1169, + 1170, 1173, 1175, 1177, 1179, 1182, 1184, 1186, 1187, 1190, + 1191, 1192, 1193, 1194, 1195, 1199, 1201, 1205, 1209, 1211, + 1213, 1215, 1217, 1219, 1223, 1225, 1229, 1231, 1238, 1242, + 1243, 1246, 1247, 1249, 1252, 1253, 1256, 1257, 1261, 1262, + 1263, 1266, 1267, 1270, 1271, 1272, 1273, 1274, 1276, 1278, + 1282, 1283, 1287, 1293, 1294, 1298, 1299, 1300, 1301, 1302, + 1305, 1306, 1307, 1310, 1311, 1314, 1315, 1318, 1319, 1322, + 1323, 1324, 1337, 1344, 1350, 1354, 1355, 1359, 1360, 1363, + 1364, 1368, 1394, 1408, 1411, 1412, 1415, 1416, 1419, 1421, + 1422, 1425, 1429, 1430, 1439, 1440, 1441, 1450, 1451, 1461, + 1462, 1469, 1477, 1480, 1486, 1487, 1490, 1493, 1494, 1497, + 1498, 1499, 1500, 1501, 1502, 1503, 1504, 1507, 1521, 1526, + 1527, 1530, 1531, 1541, 1542, 1543, 1544, 1545, 1546, 1549, + 1550, 1551, 1552, 1555, 1556, 1557, 1590, 1591, 1605, 1606, + 1626, 1627, 1631, 1632, 1635, 1636, 1640, 1641, 1644, 1645, + 1646, 1647, 1648, 1649, 1650, 1654, 1655, 1656, 1657, 1658, + 1661, 1662, 1663, 1664, 1665, 1666, 1667, 1671, 1672, 1673, + 1674, 1675, 1685, 1691, 1695, 1696, 1706, 1707, 1710, 1712, + 1727, 1728, 1731, 1734, 1735, 1738, 1738, 1739, 1757, 1758, + 1761, 1762, 1765, 1768, 1771, 1774, 1775, 1778, 1779, 1782, + 1783, 1786, 1787, 1791, 1792, 1795, 1796, 1797, 1798, 1801, + 1802, 1805, 1806, 1809, 1810, 1811, 1812, 1813, 1814, 1818, + 1819, 1820, 1821, 1822, 1825, 1827, 1828, 1829, 1830, 1831, + 1832, 1833, 1834, 1835, 1836, 1837, 1838, 1839, 1845, 1848, + 1858, 1868, 1879, 1882, 1892, 1895, 1905, 1908, 1911, 1917, + 1918, 1921, 1922, 1925, 1926, 1930, 1931, 1932, 1935, 1936, + 1939, 1940, 1941, 1944, 1947, 1950, 1951, 1954, 1955, 1959, + 1960, 1963, 1964, 1967, 1968, 1972, 1973, 1977, 1978, 1981, + 1984, 1990, 1993, 1997, 1999, 2002, 2005, 2013, 2013, 2016, + 2022 +}; + +static const char * const yytname[] = { "$","error","$illegal.","VARID","CONID", +"VARSYM","CONSYM","MINUS","INTEGER","FLOAT","CHAR","STRING","CHARPRIM","STRINGPRIM", +"INTPRIM","FLOATPRIM","DOUBLEPRIM","CLITLIT","OCURLY","CCURLY","VCCURLY","SEMI", +"OBRACK","CBRACK","OPAREN","CPAREN","COMMA","BQUOTE","RARROW","VBAR","EQUAL", +"DARROW","DOTDOT","DCOLON","LARROW","WILDCARD","AT","LAZY","LAMBDA","LET","IN", +"WHERE","CASE","OF","TYPE","DATA","CLASS","INSTANCE","DEFAULT","INFIX","INFIXL", +"INFIXR","MODULE","IMPORT","INTERFACE","HIDING","CCALL","CCALL_GC","CASM","CASM_GC", +"SCC","IF","THEN","ELSE","RENAMING","DERIVING","TO","LEOF","GHC_PRAGMA","END_PRAGMA", +"NO_PRAGMA","NOINFO_PRAGMA","ABSTRACT_PRAGMA","SPECIALISE_PRAGMA","MODNAME_PRAGMA", +"ARITY_PRAGMA","UPDATE_PRAGMA","STRICTNESS_PRAGMA","KIND_PRAGMA","UNFOLDING_PRAGMA", +"MAGIC_UNFOLDING_PRAGMA","DEFOREST_PRAGMA","SPECIALISE_UPRAGMA","INLINE_UPRAGMA", +"MAGIC_UNFOLDING_UPRAGMA","ABSTRACT_UPRAGMA","DEFOREST_UPRAGMA","END_UPRAGMA", +"TYLAMBDA","COCON","COPRIM","COAPP","COTYAPP","FORALL","TYVAR_TEMPLATE_ID","CO_ALG_ALTS", +"CO_PRIM_ALTS","CO_NO_DEFAULT","CO_LETREC","CO_SDSEL_ID","CO_METH_ID","CO_DEFM_ID", +"CO_DFUN_ID","CO_CONSTM_ID","CO_SPEC_ID","CO_WRKR_ID","CO_ORIG_NM","UNFOLD_ALWAYS", +"UNFOLD_IF_ARGS","NOREP_INTEGER","NOREP_RATIONAL","NOREP_STRING","CO_PRELUDE_DICTS_CC", +"CO_ALL_DICTS_CC","CO_USER_CC","CO_AUTO_CC","CO_DICT_CC","CO_CAF_CC","CO_DUPD_CC", +"PLUS","pmodule","module","@1","@2","body","maybeexports","export_list","export", +"impspec","maybeimpspec","import_list","import","idata_pragma","idata_pragma_specs", +"idata_pragma_specslist","idata_pragma_spectypes","itype_pragma","iclas_pragma", +"iclasop_pragma","iinst_pragma","modname_pragma","restof_iinst_spec","ival_pragma", +"gen_pragma","arity_pragma","update_pragma","deforest_pragma","strictness_pragma", +"worker_info","unfolding_pragma","unfolding_guidance","gen_pragma_list","type_pragma_pairs_maybe", +"type_pragma_pairs","type_pragma_pair","type_instpragma_pairs","type_instpragma_pair", +"type_maybes","type_maybe","maybe_name_pragma_pairs","name_pragma_pairs","name_pragma_pair", +"core_expr","core_case_alts","core_alg_alts","core_alg_alt","core_prim_alts", +"core_prim_alt","core_default","corec_binds","corec_bind","co_scc","co_caf", +"co_dupd","core_id","co_primop","core_binders","core_binder","core_atoms","core_atom_list", +"core_atom","core_tyvars","core_tv_templates","core_types","core_type_list", +"core_type","core_type_maybes","core_type_maybe","readpreludecore","@3","readprelude", +"@4","maybeimpdecls","impdecls","impdecl","@5","impdecl_rest","readinterface", +"renamings","renaming_list","renaming","maybeiimports","iimports","iimport", +"interface","@6","ibody","maybefixes","fixes","fix","@7","@8","@9","@10","@11", +"@12","ops","topdecls","topdecl","typed","datad","classd","cbody","instd","rinst", +"inst","defaultd","dtypes","decls","decl","howto_inline_maybe","types_and_maybe_ids", +"type_and_maybe_id","itopdecls","itopdecl","ivarsd","ityped","idatad","iclassd", +"iinstd","class","types","type","btype","atypes","ttype","atype","ntatype","simple", +"simple_long","constrs","constr","tyclses","tycls_list","context","context_list", +"instdefs","instdef","vars","varsrest","cons","valdef","@13","valrhs","valrhs1", +"gdrhs","maybe_where","gd","lampats","exp","oexp","dexp","kexp","@14","@15", +"fexp","cexp","aexp","opatk","opat","dpat","fpat","dpatk","fpatk","aapat","aapatk", +"tuple","texps","list","list_exps","sequence","comprehension","quals","qual", +"@16","@17","qualrest","alts","alt","@18","altrest","gdpat","upto","pats","pat", +"bpat","conpat","apat","apatc","lit_constant","importkey","datakey","typekey", +"instkey","defaultkey","classkey","minuskey","modulekey","oparenkey","obrackkey", +"lazykey","op1","op","varop","varop1","conop","varsym","minus","plus","var", +"vark","con","conk","ccallid","atype_list","tyvars","tyvar","tycls","tycon", +"modid","ocurly","vocurly","layout","ccurly","vccurly","@19","vccurly1","" +}; +#endif + +static const short yyr1[] = { 0, + 120, 122, 121, 123, 121, 124, 124, 124, 124, 124, + 124, 125, 125, 126, 126, 127, 127, 127, 127, 127, + 127, 127, 128, 128, 128, 129, 129, 130, 130, 131, + 131, 131, 131, 131, 131, 132, 132, 132, 133, 133, + 134, 134, 135, 136, 136, 137, 137, 138, 138, 139, + 139, 139, 139, 140, 140, 141, 142, 142, 143, 143, + 144, 144, 145, 145, 146, 146, 147, 147, 147, 148, + 148, 149, 149, 149, 150, 150, 151, 151, 152, 152, + 153, 153, 154, 155, 155, 156, 157, 157, 158, 158, + 159, 159, 160, 160, 161, 162, 162, 162, 162, 162, + 162, 162, 162, 162, 162, 162, 162, 162, 163, 163, + 164, 164, 165, 166, 166, 167, 168, 168, 169, 169, + 170, 171, 171, 171, 171, 171, 172, 172, 173, 173, + 174, 174, 174, 174, 174, 174, 174, 174, 174, 174, + 174, 175, 175, 175, 175, 175, 176, 176, 177, 178, + 178, 179, 179, 180, 180, 181, 181, 182, 182, 183, + 183, 184, 184, 185, 186, 186, 187, 187, 189, 188, + 191, 190, 192, 192, 193, 193, 195, 194, 196, 196, + 197, 198, 199, 199, 200, 200, 201, 201, 202, 202, + 203, 203, 205, 204, 206, 206, 206, 206, 207, 207, + 208, 208, 210, 209, 211, 209, 212, 209, 213, 209, + 214, 209, 215, 209, 216, 216, 217, 217, 218, 218, + 218, 218, 218, 218, 219, 220, 220, 220, 220, 221, + 221, 222, 222, 222, 223, 223, 224, 224, 224, 225, + 225, 225, 225, 225, 225, 226, 227, 227, 228, 228, + 229, 229, 229, 229, 229, 229, 229, 229, 229, 229, + 229, 230, 230, 231, 231, 232, 232, 233, 233, 234, + 234, 234, 234, 234, 234, 235, 235, 236, 237, 237, + 237, 237, 237, 237, 238, 238, 239, 239, 240, 241, + 241, 242, 242, 242, 243, 243, 244, 244, 245, 245, + 245, 246, 246, 247, 247, 247, 247, 247, 247, 247, + 248, 248, 249, 250, 250, 251, 251, 251, 251, 251, + 252, 252, 252, 253, 253, 254, 254, 255, 255, 256, + 256, 256, 257, 257, 257, 258, 258, 259, 259, 260, + 260, 262, 261, 263, 264, 264, 265, 265, 266, 266, + 266, 267, 268, 268, 269, 269, 269, 270, 270, 271, + 271, 273, 274, 272, 272, 272, 272, 272, 272, 272, + 272, 272, 272, 272, 272, 272, 272, 272, 272, 275, + 275, 276, 276, 277, 277, 277, 277, 277, 277, 277, + 277, 277, 277, 277, 277, 277, 278, 278, 279, 279, + 280, 280, 281, 281, 282, 282, 283, 283, 284, 284, + 284, 284, 284, 284, 284, 284, 284, 284, 284, 284, + 285, 285, 285, 285, 285, 285, 285, 285, 285, 285, + 285, 285, 286, 286, 287, 287, 288, 288, 289, 289, + 290, 290, 291, 292, 292, 294, 295, 293, 296, 296, + 297, 297, 299, 298, 298, 300, 300, 301, 301, 302, + 302, 303, 303, 304, 304, 305, 305, 305, 305, 306, + 306, 307, 307, 308, 308, 308, 308, 308, 308, 308, + 308, 308, 308, 308, 309, 309, 309, 309, 309, 309, + 309, 309, 309, 309, 309, 309, 309, 309, 310, 311, + 312, 313, 314, 315, 316, 317, 318, 319, 320, 321, + 321, 322, 322, 323, 323, 324, 324, 324, 325, 325, + 326, 326, 326, 327, 328, 329, 329, 330, 330, 331, + 331, 332, 332, 333, 333, 334, 334, 335, 335, 336, + 337, 338, 339, 340, 341, 342, 343, 345, 344, 346, + 346 +}; + +static const short yyr2[] = { 0, + 3, 0, 6, 0, 2, 5, 5, 3, 3, 3, + 3, 0, 3, 1, 3, 1, 1, 4, 4, 4, + 3, 2, 3, 4, 2, 0, 1, 1, 3, 1, + 1, 4, 4, 4, 3, 4, 3, 0, 2, 0, + 1, 3, 3, 3, 0, 3, 0, 4, 0, 4, + 5, 5, 0, 2, 0, 2, 3, 0, 1, 6, + 1, 2, 1, 2, 1, 1, 1, 2, 3, 3, + 0, 1, 2, 3, 1, 5, 1, 3, 1, 2, + 1, 3, 5, 1, 3, 6, 1, 3, 1, 1, + 0, 1, 1, 3, 3, 4, 4, 4, 6, 4, + 3, 5, 6, 8, 6, 5, 1, 1, 3, 3, + 0, 2, 5, 0, 2, 4, 1, 3, 1, 3, + 3, 2, 4, 6, 6, 6, 1, 1, 1, 1, + 3, 3, 3, 5, 6, 5, 2, 3, 3, 1, + 1, 8, 8, 8, 8, 1, 0, 2, 5, 2, + 3, 1, 3, 1, 1, 1, 2, 1, 3, 2, + 3, 1, 3, 1, 1, 3, 1, 1, 0, 2, + 0, 2, 0, 2, 1, 3, 0, 4, 2, 4, + 2, 3, 1, 3, 3, 3, 0, 2, 1, 3, + 5, 7, 0, 5, 5, 3, 5, 3, 0, 2, + 1, 3, 0, 4, 0, 4, 0, 4, 0, 3, + 0, 3, 0, 3, 1, 3, 1, 3, 1, 1, + 1, 1, 1, 1, 4, 6, 4, 8, 6, 5, + 3, 0, 4, 4, 6, 4, 0, 4, 4, 1, + 3, 3, 2, 3, 5, 2, 5, 1, 1, 3, + 6, 4, 5, 5, 5, 4, 4, 3, 3, 1, + 0, 0, 1, 1, 3, 1, 3, 1, 3, 1, + 1, 1, 1, 1, 0, 6, 4, 5, 5, 3, + 7, 5, 8, 6, 6, 4, 6, 4, 2, 1, + 3, 1, 3, 4, 1, 2, 2, 1, 1, 3, + 2, 1, 5, 1, 1, 2, 3, 3, 6, 1, + 1, 2, 2, 1, 3, 2, 4, 1, 3, 3, + 3, 2, 1, 1, 3, 3, 1, 1, 3, 0, + 1, 3, 4, 4, 1, 3, 1, 1, 3, 1, + 3, 0, 3, 2, 1, 2, 3, 4, 4, 4, + 0, 2, 2, 1, 5, 3, 1, 1, 3, 2, + 1, 0, 0, 6, 6, 6, 6, 6, 6, 3, + 2, 3, 2, 3, 2, 3, 2, 3, 1, 2, + 1, 2, 1, 1, 1, 1, 3, 4, 4, 1, + 1, 1, 1, 3, 1, 2, 1, 3, 1, 3, + 2, 1, 2, 1, 2, 1, 2, 1, 1, 1, + 3, 1, 1, 2, 5, 3, 5, 3, 2, 2, + 1, 1, 3, 1, 1, 2, 5, 3, 5, 3, + 2, 2, 5, 2, 1, 3, 2, 3, 1, 3, + 7, 5, 5, 1, 3, 0, 0, 4, 2, 0, + 1, 3, 0, 3, 0, 2, 3, 4, 3, 0, + 1, 3, 1, 1, 3, 1, 1, 2, 2, 1, + 2, 1, 1, 1, 3, 1, 1, 2, 5, 3, + 5, 3, 2, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 3, 2, 3, 2, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 3, 1, 1, 3, 1, 3, + 1, 1, 1, 1, 1, 1, 3, 1, 3, 1, + 3, 1, 3, 1, 1, 3, 3, 1, 2, 1, + 1, 1, 1, 2, 1, 0, 1, 0, 2, 1, + 1 +}; + +static const short yydefact[] = { 169, + 171, 0, 4, 0, 0, 170, 0, 506, 1, 546, + 0, 172, 543, 193, 181, 5, 173, 173, 545, 12, + 0, 0, 199, 0, 175, 199, 548, 544, 0, 2, + 546, 177, 547, 213, 209, 211, 261, 0, 201, 11, + 174, 9, 261, 10, 0, 8, 526, 542, 0, 0, + 14, 16, 17, 0, 194, 187, 187, 0, 207, 0, + 203, 0, 205, 0, 528, 505, 485, 486, 487, 488, + 489, 490, 491, 492, 493, 494, 508, 507, 425, 509, + 501, 500, 504, 502, 503, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 217, 219, 220, 221, 222, 223, + 224, 0, 260, 342, 397, 406, 408, 424, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 422, 421, 532, + 200, 176, 548, 551, 550, 549, 521, 524, 525, 0, + 523, 522, 13, 0, 0, 22, 546, 499, 199, 0, + 189, 0, 199, 548, 178, 26, 0, 519, 0, 214, + 215, 513, 512, 514, 0, 210, 0, 212, 0, 0, + 0, 0, 0, 262, 0, 0, 0, 496, 0, 498, + 261, 6, 0, 0, 0, 0, 0, 413, 0, 407, + 412, 410, 409, 530, 0, 327, 0, 0, 311, 0, + 311, 0, 0, 541, 540, 0, 0, 0, 310, 246, + 0, 248, 295, 299, 304, 305, 232, 0, 0, 405, + 404, 0, 524, 426, 0, 399, 402, 0, 410, 0, + 0, 431, 0, 477, 0, 0, 463, 464, 467, 466, + 476, 474, 470, 432, 473, 472, 0, 0, 202, 7, + 527, 15, 507, 21, 0, 0, 0, 337, 340, 3, + 275, 188, 196, 0, 275, 198, 0, 0, 27, 179, + 208, 0, 0, 0, 204, 206, 495, 0, 0, 0, + 263, 0, 0, 259, 258, 497, 218, 0, 0, 49, + 292, 302, 305, 0, 0, 343, 351, 345, 0, 0, + 398, 419, 0, 0, 414, 0, 410, 420, 0, 328, + 0, 0, 0, 312, 538, 0, 538, 0, 0, 0, + 237, 240, 289, 0, 0, 306, 0, 0, 301, 298, + 305, 546, 231, 0, 403, 533, 401, 428, 0, 0, + 529, 0, 468, 469, 483, 0, 524, 478, 0, 474, + 484, 430, 0, 0, 0, 471, 0, 336, 338, 423, + 18, 20, 19, 0, 0, 268, 274, 270, 271, 272, + 273, 0, 0, 0, 0, 0, 190, 0, 548, 25, + 0, 28, 30, 31, 0, 0, 515, 520, 216, 0, + 0, 0, 264, 266, 256, 257, 0, 158, 0, 0, + 0, 252, 0, 296, 0, 0, 0, 395, 0, 362, + 546, 0, 0, 0, 0, 0, 0, 0, 352, 358, + 361, 379, 381, 390, 391, 392, 393, 386, 384, 385, + 346, 357, 546, 344, 0, 418, 531, 416, 0, 0, + 411, 326, 0, 0, 0, 227, 314, 318, 0, 539, + 225, 0, 541, 0, 243, 0, 0, 0, 305, 546, + 236, 0, 308, 307, 0, 300, 297, 261, 261, 232, + 0, 400, 0, 482, 480, 0, 0, 462, 465, 475, + 0, 0, 341, 275, 195, 0, 38, 0, 0, 0, + 0, 47, 0, 0, 197, 23, 0, 0, 0, 0, + 180, 255, 254, 0, 253, 0, 0, 0, 0, 49, + 61, 59, 0, 0, 0, 293, 360, 437, 439, 0, + 516, 519, 524, 434, 0, 0, 357, 0, 511, 510, + 517, 396, 0, 261, 261, 0, 534, 535, 371, 373, + 375, 377, 0, 0, 0, 380, 0, 0, 261, 261, + 347, 0, 0, 329, 0, 0, 0, 0, 316, 0, + 237, 244, 0, 0, 241, 242, 313, 330, 330, 0, + 0, 290, 0, 249, 548, 230, 429, 427, 0, 0, + 339, 269, 58, 0, 40, 280, 0, 0, 0, 53, + 0, 232, 0, 191, 29, 35, 0, 0, 0, 24, + 0, 0, 183, 0, 0, 265, 267, 0, 159, 294, + 251, 62, 0, 63, 0, 0, 0, 446, 460, 438, + 0, 387, 0, 0, 0, 363, 354, 0, 548, 546, + 370, 383, 372, 374, 376, 378, 0, 359, 394, 356, + 0, 548, 348, 417, 415, 319, 320, 315, 0, 229, + 323, 226, 235, 536, 537, 0, 0, 0, 0, 331, + 335, 422, 548, 0, 247, 0, 261, 233, 234, 481, + 479, 0, 0, 277, 38, 0, 0, 40, 38, 45, + 0, 55, 288, 77, 0, 286, 47, 0, 32, 34, + 33, 182, 0, 0, 0, 303, 48, 64, 65, 66, + 0, 439, 440, 0, 444, 0, 461, 0, 518, 435, + 0, 388, 389, 0, 353, 0, 0, 455, 455, 382, + 0, 0, 349, 350, 317, 322, 0, 324, 0, 245, + 262, 0, 0, 238, 239, 309, 291, 250, 58, 0, + 0, 282, 0, 39, 41, 37, 0, 0, 279, 0, + 278, 53, 0, 0, 0, 46, 232, 192, 184, 185, + 186, 67, 0, 0, 0, 460, 443, 446, 447, 442, + 0, 433, 0, 0, 0, 0, 451, 453, 548, 0, + 355, 321, 0, 228, 0, 0, 332, 276, 57, 284, + 89, 0, 87, 90, 0, 36, 38, 0, 287, 54, + 0, 78, 285, 71, 68, 72, 0, 0, 0, 439, + 0, 445, 450, 436, 364, 365, 366, 455, 368, 0, + 369, 367, 325, 333, 334, 43, 0, 42, 0, 281, + 44, 50, 0, 0, 0, 93, 0, 0, 69, 75, + 0, 0, 73, 79, 0, 60, 441, 0, 448, 452, + 0, 0, 454, 351, 88, 283, 0, 56, 84, 52, + 0, 51, 0, 0, 0, 147, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 74, 108, 107, 140, 141, 0, 80, + 81, 449, 351, 0, 456, 0, 0, 94, 95, 70, + 0, 0, 0, 0, 0, 156, 0, 0, 0, 146, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 137, 0, 0, 0, 457, 459, 0, 85, 0, + 0, 0, 148, 0, 0, 0, 0, 0, 0, 0, + 0, 157, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 101, 0, 0, 119, 0, 131, 132, 133, + 0, 0, 0, 138, 139, 0, 82, 458, 71, 76, + 0, 96, 0, 0, 129, 130, 122, 0, 0, 0, + 0, 0, 97, 0, 160, 0, 162, 164, 98, 0, + 0, 0, 0, 100, 150, 155, 0, 152, 154, 0, + 0, 0, 0, 0, 0, 167, 168, 0, 165, 71, + 91, 0, 0, 111, 114, 0, 0, 0, 0, 0, + 106, 0, 161, 0, 0, 0, 0, 0, 151, 0, + 102, 0, 120, 121, 134, 0, 136, 0, 83, 86, + 92, 0, 0, 0, 0, 103, 123, 0, 0, 0, + 99, 163, 0, 0, 0, 0, 153, 105, 135, 166, + 149, 0, 0, 117, 112, 109, 147, 0, 115, 110, + 0, 0, 0, 0, 0, 0, 0, 0, 104, 0, + 0, 0, 127, 128, 124, 125, 126, 0, 0, 0, + 0, 0, 118, 0, 142, 143, 144, 145, 0, 116, + 113, 0, 0, 0 +}; + +static const short yydefgoto[] = { 1092, + 9, 54, 10, 16, 30, 50, 51, 259, 260, 371, + 372, 576, 667, 734, 735, 741, 582, 392, 673, 744, + 824, 664, 504, 505, 606, 691, 754, 829, 799, 832, + 675, 836, 880, 881, 848, 849, 782, 783, 1030, 825, + 826, 874, 1006, 1034, 1055, 1035, 1059, 1056, 945, 946, + 931, 1075, 967, 875, 902, 892, 923, 943, 987, 988, + 897, 389, 936, 976, 997, 998, 999, 1, 2, 3, + 4, 23, 24, 25, 58, 145, 6, 491, 592, 593, + 139, 140, 141, 7, 21, 55, 37, 38, 39, 155, + 157, 147, 62, 64, 60, 150, 94, 95, 96, 97, + 98, 323, 99, 451, 311, 100, 200, 563, 564, 272, + 382, 383, 355, 356, 357, 358, 359, 360, 361, 186, + 561, 978, 281, 319, 202, 203, 282, 187, 447, 436, + 437, 640, 717, 188, 301, 649, 650, 102, 348, 247, + 103, 174, 286, 287, 288, 424, 289, 616, 697, 422, + 410, 411, 523, 704, 412, 621, 413, 104, 215, 216, + 217, 105, 106, 211, 107, 414, 701, 415, 693, 416, + 417, 694, 695, 696, 803, 839, 766, 767, 810, 843, + 844, 698, 226, 227, 228, 229, 617, 230, 418, 142, + 109, 110, 111, 112, 113, 114, 11, 162, 116, 117, + 518, 151, 152, 519, 153, 154, 131, 132, 419, 118, + 420, 119, 529, 448, 304, 205, 641, 184, 14, 17, + 18, 19, 40, 44, 45, 126 +}; + +static const short yypact[] = {-32768, +-32768, 58, 15, 58, 140,-32768, 197,-32768,-32768,-32768, + 140,-32768,-32768,-32768,-32768,-32768, 220, 220, 326, 342, + 405, 140, 424, 358,-32768, 649, 400,-32768, 415,-32768, +-32768,-32768,-32768, 446, 480, 484, 1796, 487,-32768,-32768, + 220,-32768, 1796,-32768, 433,-32768,-32768,-32768, 59, 579, +-32768,-32768, 409, 482,-32768, 486, 486, 58,-32768, 116, +-32768, 116,-32768, 116,-32768,-32768,-32768,-32768,-32768,-32768, +-32768,-32768,-32768,-32768,-32768, 452,-32768,-32768,-32768,-32768, +-32768,-32768,-32768,-32768,-32768, 272, 174, 174, 545, 174, + 546, 576, 589, 577,-32768,-32768,-32768,-32768,-32768,-32768, +-32768, 578,-32768, 116,-32768, 1370,-32768,-32768, 291, 545, + 291, 815, 291, 1370, 1086, 2359, 2549, 471,-32768,-32768, + 649,-32768, 603,-32768,-32768,-32768,-32768,-32768,-32768, 614, +-32768,-32768,-32768, 415, 700,-32768,-32768,-32768, 649, 597, +-32768, 140, 649, 643,-32768, 199, 116,-32768, 656, 658, +-32768,-32768,-32768,-32768, 116, 658, 116, 658, 678, 545, + 711, 59, 685, 732, 174, 644, 659,-32768, 759,-32768, + 1796,-32768, 782, 648, 2472, 2402, 1152,-32768, 2549,-32768, +-32768, 728,-32768,-32768, 545,-32768, 757, 765, 787, 775, + 787, 777, 333, 787,-32768, 799, 782, 672,-32768,-32768, + 793,-32768,-32768, 800,-32768, 956, 500, 801, 787, 1370, +-32768, 811, 1370,-32768, 336,-32768, 1370, 830, -8, 733, + 2437,-32768, 1550,-32768, 2549, 825, 359,-32768, 2549,-32768, +-32768, 824,-32768,-32768,-32768,-32768, 255, 2549,-32768,-32768, +-32768,-32768, 860,-32768, 844, 847, 719, 848,-32768,-32768, + 511, 486,-32768, 856, 511,-32768, 497, 866,-32768, 835, + 658, 870, 876, 116, 658, 658,-32768, 956, 333, 782, +-32768, 818, 827,-32768,-32768,-32768,-32768, 672, 814, 149, + 883,-32768, 956, 1977, 1977,-32768, 879,-32768, 894, 1370, +-32768,-32768, 907, 906,-32768, 442, 44,-32768, 2549,-32768, + 725, 1015, 545, 787, 908, 782,-32768, 545, 956, 944, + 897,-32768,-32768, 937, 921,-32768, 727, 782, 918,-32768, +-32768,-32768,-32768, 545,-32768,-32768, 1370,-32768, 2514, 2472, +-32768, 943,-32768,-32768,-32768, 929, 733,-32768, 388, 48, +-32768,-32768, 2514, 949, 2514,-32768, 2549, 928,-32768,-32768, +-32768,-32768,-32768, 324, 613,-32768,-32768,-32768,-32768,-32768, +-32768, 922, 291, 545, 291, 291,-32768, 415, 942,-32768, + 729,-32768,-32768, 946, 415, 947,-32768,-32768,-32768, 979, + 880, 5,-32768, 945,-32768,-32768, 745,-32768, 159, 782, + 544,-32768, 782, 956, 2106, 1852, 1491,-32768, 2584,-32768, +-32768, 1977, 769, 769, 962, 964, 973, 1977, 116,-32768, +-32768, 2584,-32768,-32768,-32768,-32768,-32768,-32768, 952,-32768, +-32768, 362,-32768,-32768, 1977,-32768,-32768,-32768, 2514, 965, +-32768,-32768, 545, 663, 374, 216,-32768, 303, 955,-32768, +-32768, 333,-32768, 967,-32768, 623, 969, 970, 956,-32768, +-32768, 782,-32768,-32768, 782,-32768,-32768, 2168, 2168, 951, + 971,-32768, 974,-32768,-32768, 2514, 990,-32768,-32768,-32768, + 255, 860,-32768, 511,-32768, 782, 66, 976, 972, 977, + 333, 189, 980, 751,-32768,-32768, 415, 820, 758, 426, +-32768,-32768,-32768, 782,-32768, 174, 782, 910, 782, 932, +-32768,-32768, 1002, 544, 477,-32768,-32768,-32768, 536, 991, + 992, 906, 2106,-32768, 789, 805, 362, 1977,-32768,-32768, + 999,-32768, 2549, 2168, 2168, 982,-32768,-32768, 2584, 2584, + 2584, 2584, 1977, 954, 1977,-32768, 2584, 782, 2168, 2168, + 997, 1004, 1006,-32768, 1007, 956, 1015, 403, 867, 1015, + 897,-32768, 956, 956,-32768,-32768, 956, 2324, 2324, 1008, + 821,-32768, 652,-32768, 1013,-32768,-32768,-32768, 1011, 1016, +-32768,-32768, 198, 1015, 688,-32768, 545, 782, 545, 978, + 544, 951, 545, 983,-32768,-32768, 1019, 1023, 828,-32768, + 237, 833,-32768, 985, 986,-32768,-32768, 857,-32768,-32768, +-32768,-32768, 987,-32768, 1032, 207, 1977,-32768, 1977,-32768, + 1022,-32768, 1977, 1916, 521,-32768, 2549, 652, 1013,-32768, + 2584,-32768, 2584, 2584, 2584,-32768, 1977,-32768,-32768, 1026, + 652, 1013,-32768,-32768,-32768, 956,-32768,-32768, 398,-32768, +-32768, 217,-32768, 1033,-32768, 1038, 174, 174, 674,-32768, +-32768, 1031, 1048, 1053, 1046, 782, 2168,-32768,-32768,-32768, +-32768, 782, 544,-32768, 106, 1065, 1035, 27, 86, 1020, + 333, 1039,-32768,-32768, 49,-32768, 1037, 947,-32768,-32768, +-32768,-32768, 426, 255, 324,-32768,-32768,-32768,-32768,-32768, + 13, 538,-32768, 134,-32768, 1977,-32768, 1083,-32768, 1081, + 1087,-32768,-32768, 1091,-32768, 1074, 1082, 2514, 2514,-32768, + 1061, 782,-32768,-32768, 956,-32768, 862,-32768, 403,-32768, + 732, 174, 2324,-32768,-32768,-32768,-32768,-32768, 1057, 1059, + 403,-32768, 705, 1100,-32768,-32768, 1060, 1015,-32768, 1058, +-32768, 978, 140, 544, 544,-32768, 951,-32768,-32768,-32768, +-32768,-32768, 36, 169, 1977, 1977,-32768,-32768,-32768,-32768, + 1977,-32768, 1977, 1977, 1977, 686,-32768, 374, 1110, 1977, +-32768,-32768, 545,-32768, 1047, 1049,-32768,-32768,-32768,-32768, +-32768, 470,-32768,-32768, 1065,-32768, 261, 1064,-32768,-32768, + 330,-32768,-32768, 1117,-32768,-32768, 788, 174, 547, 1111, + 1115,-32768, 1105,-32768,-32768,-32768,-32768, 2514,-32768, 888, +-32768,-32768,-32768,-32768,-32768,-32768, 705,-32768, 403,-32768, +-32768,-32768, 1118, 1072, 50,-32768, 1113, 544,-32768,-32768, + 1136, 1629,-32768,-32768, 1125,-32768,-32768, 1977,-32768,-32768, + 1977, 1120,-32768, 879,-32768,-32768, 705, 1123,-32768,-32768, + 255,-32768, 544, 1131, 1143,-32768, 1134, 1629, 1135, 1151, + 39, 407, 1629, 1629, 1153, 545, 545, 545, 545, 545, + 474, 474, 140,-32768,-32768,-32768,-32768,-32768, 705, 1144, +-32768,-32768, 879, 1977,-32768, 599, 1118,-32768,-32768,-32768, + 1168, 227, 1149, 1132, 515,-32768, 99, 140, 1159,-32768, + 533, 1159, 1160, 1165, 1149, 545, 255, 255, 1164, 255, + 1162,-32768, 426, 615, 1125,-32768, 997, 1183,-32768, 1184, + 1190, 1629,-32768, 1169, 1180, 11, 1189, 1191, 474, 474, + 1187,-32768, 1629, 324, 563, 1160, 769, 769, 1069, 1069, + 1160, 2185,-32768, 782, 709,-32768, 1173,-32768,-32768,-32768, + 782, 1185, 756,-32768,-32768, 1200,-32768,-32768, 1117,-32768, + 1179,-32768, 1629, 823,-32768,-32768,-32768, 1202, 1203, 1204, + 1205, 1629,-32768, 1159,-32768, 635,-32768,-32768,-32768, 1199, + 1211, 1212, 1213,-32768,-32768,-32768, 642,-32768,-32768, 1216, + 1192, 1149, 1629, 1215, 782,-32768,-32768, 660,-32768, 1117, + 255, 782, 1217,-32768,-32768, 1218, 11, 1227, 1230, 1231, +-32768, 1160,-32768, 782, 1159, 1159, 1159, 1159,-32768, 2215, +-32768, 1629,-32768,-32768,-32768, 1219,-32768, 756,-32768,-32768, + 1221, 1223, 1220, 710, 1210,-32768,-32768, 11, 11, 11, +-32768,-32768, 782, 782, 782, 782,-32768,-32768,-32768,-32768, +-32768, 1629, 88,-32768,-32768,-32768,-32768, 1222,-32768,-32768, + 1224, 3, 3, 3, 1238, 1239, 1240, 1245,-32768, 380, + 1629, 1629,-32768,-32768,-32768,-32768,-32768, 1241, 1242, 1243, + 1244, 1629,-32768, 1249,-32768,-32768,-32768,-32768, 1251,-32768, +-32768, 1265, 1273,-32768 +}; + +static const short yypgoto[] = {-32768, +-32768,-32768,-32768, 1106,-32768,-32768, 1141,-32768,-32768, 95, + 791, -604, 611,-32768, 495,-32768, 604, 783, 540,-32768, +-32768, 555, -477,-32768,-32768,-32768,-32768, -902,-32768,-32768, +-32768,-32768,-32768, 370,-32768, 399, -746, 472,-32768, 286, + 437, -95,-32768,-32768,-32768,-32768,-32768, 258,-32768, 302, +-32768, -135, -527, -427,-32768, 238, -732, -652,-32768, 276, +-32768,-32768, -705,-32768, -401,-32768, 269,-32768,-32768,-32768, +-32768, 1285, 1286, 1267,-32768,-32768, 68, 634,-32768, 630, + 1260, 1266, 1070,-32768,-32768,-32768, 52,-32768, 1207,-32768, +-32768,-32768,-32768,-32768,-32768, 235, 1281, 1154,-32768,-32768, +-32768, -442,-32768, 781, -243,-32768,-32768, -53, -22, 612, +-32768, 840, 1084, 863,-32768,-32768,-32768,-32768,-32768, -88, + 839, -59, -90, -245,-32768, 353, 1226, -78,-32768, -505, + 794, -657,-32768, -72,-32768, 784, 617, -100,-32768, 854, + -508,-32768,-32768,-32768, 803, -662, -804, 730, -44, -255, +-32768, -355,-32768,-32768,-32768, 208, -159,-32768, -117,-32768, + -60,-32768,-32768, -51,-32768,-32768, 584,-32768, 950,-32768, +-32768,-32768, 590,-32768,-32768,-32768, 641, 543,-32768,-32768, + 436, 598, -142, -199, 1010,-32768, -73, -97, -7,-32768, + -218, -209, -203,-32768, -202,-32768,-32768, -34,-32768,-32768, +-32768, 120,-32768,-32768, -208, -47,-32768, 960, -29, -76, + 1139,-32768, -400, 806,-32768, 43, -103, 752, -6, -18, + -14,-32768, -23, -20,-32768,-32768 +}; + + +#define YYLAST 2695 + + +static const short yytable[] = { 52, + 42, 130, 115, 530, 20, 842, 46, 193, 115, 163, + 164, 165, 56, 167, 101, 32, 57, 566, 345, 235, + 101, 201, 380, 339, 207, 381, 603, 299, 409, 108, + 494, 190, 363, 293, 246, 108, 363, 394, 192, 507, + 208, 364, 48, 234, 642, 364, 794, 365, 366, 651, + 651, 365, 366, 210, 180, 547, 1001, 291, 248, 296, + 732, 774, 472, 127, 739, 128, 8, 218, 665, 668, + 172, 12, 1073, 780, 745, 851, 182, 43, 336, 299, + 965, 235, 752, 347, 182, 219, 232, 232, 273, 753, + 961, 495, 127, 294, 128, 574, 300, 1029, 181, 666, + 886, 932, 240, 674, 52, 298, 181, 181, 231, 231, + 332, 5, 842, 280, 218, 738, 253, 746, 852, 1074, + 127, 148, 128, 256, 795, 146, 933, 235, 966, 130, + 345, 235, 914, 575, 547, 254, 115, 315, 317, 676, + 235, 517, 149, 13, 898, 182, 232, 297, 101, 232, + 362, 341, 327, 575, 362, 346, 757, 507, 325, 758, + 924, 846, 430, 108, 350, 325, 467, 181, 231, 181, + 731, 231, 947, 575, 248, 130, 65, 129, 248, 390, + 182, 885, 820, 182, 498, 730, 461, 182, 520, 499, + 251, 232, 549, 340, 255, 232, 941, 78, 551, 232, + 468, 235, 181, 557, 442, 181, 129, 349, 232, 181, + 384, 435, 462, 231, 651, 231, 391, 231, 387, -327, + 916, 231, 257, 175, 439, 431, 546, 373, 662, 327, + 231, 305, 787, 307, 129, 460, 313, 580, 796, 522, + 421, 127, 294, 128, 547, 547, 441, 797, 798, 235, + 921, 313, 536, 258, 922, 363, 581, 47, 456, 947, + 182, 481, 615, 15, 364, 663, 791, 792, 1012, 232, + 365, 366, 22, 470, 65, 325, 689, 482, 49, 628, + 548, 719, 181, 979, 477, 479, 542, 690, 984, 547, + 478, 231, 480, 483, 48, 78, 156, 182, 158, 232, + 182, 1058, 1058, 458, 793, 195, 48, 459, -305, 1043, + 1044, 1045, 1046, 232, 185, 232, 160, 232, 161, 181, + 196, 231, 181, 569, 197, 819, 278, 48, 575, -305, + 500, 475, 47, 506, 330, 231, 48, 231, 373, 231, + 127, 148, 128, 28, 544, 373, 440, 472, 485, 130, + 854, 509, 516, 49, 309, 129, 310, 526, 628, 1041, + 328, 329, 149, 534, 148, 29, 127, 148, 128, 622, + 622, 622, 622, 362, 387, 889, 33, 629, 41, 148, + 541, 261, 524, 379, 343, 344, 525, 588, 149, 265, + 715, 266, 560, 148, 538, 562, 199, 248, 822, 232, + 344, 48, 823, 921, 539, 565, 48, 1082, 540, 900, + 330, 248, 465, 466, 344, 330, 573, 47, 48, 597, + 41, 231, 716, 115, 115, 235, 639, 742, 47, 48, + 901, 558, 135, 124, 384, 559, 232, 562, 49, 600, + 136, 571, 33, 911, 912, 31, 127, 148, 128, 591, + 108, 108, 125, 59, 129, 637, 435, 373, 231, 435, + 594, 710, 484, 710, 710, 710, 428, 429, 149, 489, + 618, 619, 34, 35, 36, 671, 47, 48, 630, 1037, + 129, 652, 652, 435, 435, 631, 632, 61, 626, 115, + 115, 63, 816, 232, 677, 817, 237, 591, 669, 47, + 48, 970, 971, -337, 115, 115, 238, 121, 768, 768, + 1062, 1063, 1064, 65, 986, 231, 108, 108, 670, 235, + 49, 370, 137, 115, 115, 127, 148, 128, 535, 159, + -327, 108, 108, 977, 78, 718, 980, 981, 138, 658, + 322, 535, 990, 130, 659, 703, 604, 149, 48, 994, + 108, 108, 605, 168, 81, 82, 83, 84, 320, 345, + 129, 607, 692, 755, 608, 195, 48, 609, 700, 756, + 721, 722, 866, 867, 868, 869, 870, 871, 872, 873, + 196, 330, 711, 169, 197, 975, 278, 232, 937, 938, + 939, 940, 986, 1026, 706, 33, 727, 171, 707, 170, + 1032, 708, 729, 133, 134, 709, 1057, 713, 768, 231, + 173, 714, 1042, 501, 502, 33, 834, 252, 503, 835, + 320, 918, 115, 171, 817, 724, 926, 927, 928, 929, + 930, 33, 725, 474, 728, 320, 614, 956, 241, 129, + 817, 1065, 1066, 1067, 1068, 776, 652, 435, 553, 108, + 554, 759, 771, 594, 750, 279, 199, 1013, 262, 263, + 1014, 444, 446, 252, 1019, 195, 48, 1020, 545, 813, + 33, 457, 657, 784, 195, 48, 284, 285, 232, 232, + 196, 267, 1027, 264, 197, 1028, 278, 316, 115, 196, + 195, 48, 33, 197, 723, 278, 316, 34, 35, 36, + 231, 231, 65, 48, 33, 196, 808, 195, 48, 197, + 800, 434, 47, 48, 269, 108, 700, 270, 805, 806, + 807, 833, 196, 243, 244, 812, 197, 991, 278, 992, + 274, 245, 457, 1053, 535, 271, 790, 623, 624, 625, + 333, 334, 809, 353, 354, 275, 457, 535, 811, 432, + 433, 454, 455, 486, 487, 279, 199, 784, 195, 48, + 666, 827, 894, 299, 279, 199, 276, 903, 904, 454, + 497, 527, 528, 196, 781, 584, 487, 197, 232, 278, + 53, 199, 590, 487, 195, 48, 302, 784, 120, 195, + 320, 611, 263, 882, 120, 303, 883, 279, 199, 196, + 231, 320, 877, 197, 306, 278, 1054, 308, 866, 867, + 868, 869, 870, 871, 872, 873, 314, 195, 48, 784, + 318, 827, 65, 48, 876, 996, 962, -302, 877, 612, + 613, 324, 196, 877, 877, 326, 197, 973, 198, 917, + 166, 877, 877, 243, 586, 655, 656, 342, 279, 199, + 876, 587, 681, 354, 331, 876, 876, 682, 683, 347, + 189, 191, 194, 206, 209, 294, 913, 1003, 351, 195, + 48, 352, -296, 237, 279, 199, 1011, 949, 950, 368, + 952, 686, 656, 954, 196, 53, 772, 773, 197, 375, + 278, 934, 877, -296, 830, 831, 377, 1024, 376, 877, + 877, 457, 378, 877, 385, 644, 646, 388, 199, 457, + 393, 268, 877, 386, 876, 841, 284, 1004, 1005, 423, + 195, 48, 120, 425, 283, 876, 1048, 1076, 1077, 426, + 427, 982, 983, 877, 989, 196, 209, 450, -289, 197, + 452, 278, 877, 453, 312, -296, 195, 48, 283, 283, + 463, 464, 263, 471, 476, 876, 1069, 321, 195, 48, + 199, 196, 474, 877, 876, 197, 493, 278, 445, 488, + 490, 827, 543, 196, 496, 1083, 1084, 197, 531, 278, + 532, 195, 48, 533, 550, 876, 1089, 537, 320, 552, + 877, 322, 877, 555, 556, 567, 196, 570, 568, 391, + 197, 578, 278, 599, 877, 130, 577, 579, 374, 602, + 583, 199, 989, 610, 876, 627, -521, 195, 48, 321, + 312, 283, 877, -522, 620, 284, 654, 1061, 634, 283, + 635, 636, 196, 657, 321, 660, 197, 199, 434, 688, + 661, 877, 877, 679, 876, 672, 678, 680, 699, 199, + 684, 685, 877, 438, 191, 687, 712, 283, 553, 443, + 321, 449, 720, 876, 876, 492, 238, 457, 723, 283, + 321, 726, 199, -303, 876, 209, 67, 68, 69, 70, + 71, 72, 73, 74, 75, 76, 733, 740, 47, 48, + 127, 212, 213, 67, 68, 69, 70, 71, 72, 73, + 74, 75, 76, 736, 581, 760, 761, 176, 199, 177, + 214, 762, 743, 764, 189, 191, 194, 209, 763, 374, + 178, 765, 179, 770, 663, 785, 374, 779, 786, 788, + 808, 321, 821, 814, 828, 815, 755, 837, 838, 847, + 850, 283, 853, 855, 283, 321, 879, 884, 887, 890, + 891, 893, 895, 896, 47, 48, 127, 294, 213, 67, + 68, 69, 70, 71, 72, 73, 74, 75, 76, 915, + 905, 920, 921, 176, 925, 177, 295, 91, 92, 93, + 935, 942, 944, 953, 209, 283, 178, 951, 179, 321, + 959, 960, 961, 312, 91, 92, 93, 964, 963, 968, + 321, 969, 993, 283, 129, 972, 283, 1000, 995, 120, + 120, 1002, 1007, 1008, 1009, 1010, 1015, 67, 68, 69, + 70, 71, 72, 73, 74, 75, 76, 283, 1016, 1017, + 1018, 1022, 312, 921, 1021, 1033, 1036, 1038, 374, 1025, + 1039, 1040, 250, 1049, 183, 283, 851, 1051, 283, 1071, + 283, 1072, 183, 183, 233, 236, 1078, 1079, 1080, 1052, + 91, 92, 93, 1081, 1093, 1085, 1086, 1087, 1088, 1090, + 129, 1091, 1094, 249, 242, 120, 120, 585, 737, 818, + 747, 789, 601, 778, 957, 919, 1031, 888, 845, 283, + 120, 120, 1060, 1023, 1070, 1047, 1050, 283, 438, 443, + 321, 438, 26, 27, 321, 321, 1054, 122, 321, 120, + 120, 748, 749, 183, 233, 183, 143, 236, 91, 92, + 93, 367, 144, 123, 277, 438, 438, 239, 191, 283, + 443, 643, 775, 596, 209, 598, 572, 204, 369, 777, + 638, 589, 653, 633, 804, 510, 705, 802, 183, 769, + 840, 183, 958, 801, 469, 183, 521, 0, 645, 233, + 0, 233, 0, 236, 0, 0, 0, 236, 0, 0, + 0, 0, 47, 48, 0, 0, 236, 67, 68, 69, + 70, 71, 72, 73, 74, 75, 76, 321, 0, 0, + 443, 176, 0, 177, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 178, 0, 179, 283, 120, 0, + 0, 0, 0, 283, 0, 0, 0, 0, 0, 0, + 0, 0, 312, 0, 0, 0, 0, 0, 183, 0, + 0, 0, 0, 0, 0, 0, 0, 236, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 283, 0, 183, 321, 233, 183, 0, + 443, 0, 0, 0, 120, 0, 0, 0, 91, 92, + 93, 233, 443, 233, 283, 236, 0, 0, 0, 438, + 0, 0, 473, 47, 48, 511, 512, 513, 67, 68, + 69, 70, 71, 72, 73, 74, 75, 76, 0, 0, + 0, 0, 396, 0, 397, 514, 0, 515, 0, 0, + 0, 0, 0, 0, 443, 398, 0, 399, 400, 401, + 0, 0, 402, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 403, 404, 405, 406, + 407, 408, 47, 48, 127, 294, 337, 67, 68, 69, + 70, 71, 72, 73, 74, 75, 76, 233, 283, 0, + 443, 221, 0, 223, 338, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 224, 0, 225, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 283, 91, + 92, 93, 0, 0, 233, 0, 0, 0, 0, 129, + 0, 0, 0, 0, 0, 0, 0, 906, 907, 908, + 909, 910, 0, 0, 0, 0, 249, 0, 595, 0, + 283, 47, 48, 0, 0, 0, 67, 68, 69, 70, + 71, 72, 73, 74, 75, 76, 0, 0, 0, 0, + 0, 0, 591, 0, 0, 0, 0, 948, 91, 92, + 93, 236, 0, 0, 0, 0, 856, 857, 129, 0, + 858, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 283, 0, 859, 0, + 0, 0, 0, 0, 0, 283, 0, 0, 0, 0, + 0, 0, 283, 0, 283, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 860, 861, 862, 863, + 864, 0, 0, 0, 0, 0, 865, 866, 867, 868, + 869, 870, 871, 872, 873, 0, 0, 91, 92, 93, + 0, 0, 0, 0, 0, 0, 283, 0, 0, 0, + 0, 0, 0, 283, 0, 236, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 283, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 283, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 283, 283, 283, 283, 65, 48, + 0, 0, 66, 67, 68, 69, 70, 71, 72, 73, + 74, 75, 76, 0, 0, 0, 0, 77, 0, 78, + 0, 595, 0, 751, 0, 0, 0, 0, 0, 0, + 79, 0, 80, 0, 0, 0, 0, 0, 0, 81, + 82, 83, 84, 85, 0, 0, 233, 233, 0, 0, + 0, 0, 0, 0, 47, 48, 0, 0, 395, 67, + 68, 69, 70, 71, 72, 73, 74, 75, 76, 0, + 0, 0, 0, 396, 508, 397, 0, 86, 87, 88, + 89, 90, 0, 0, 0, 0, 398, 0, 399, 400, + 401, 0, 0, 402, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 91, 92, 93, 403, 404, 405, + 406, 407, 408, 0, 0, 0, 0, 0, 47, 48, + 0, 0, 395, 67, 68, 69, 70, 71, 72, 73, + 74, 75, 76, 0, 0, 0, 0, 396, 0, 397, + 702, 0, 0, 0, 0, 0, 233, 0, 0, 0, + 398, 0, 399, 400, 401, 0, 0, 402, 0, 0, + 91, 92, 93, 0, 0, 0, 0, 0, 0, 0, + 878, 403, 404, 405, 406, 407, 408, 0, 0, 47, + 48, 0, 0, 395, 67, 68, 69, 70, 71, 72, + 73, 74, 75, 76, 0, 0, 878, 0, 396, 899, + 397, 878, 878, 0, 0, 0, 0, 0, 0, 878, + 878, 398, 0, 399, 400, 401, 0, 0, 402, 0, + 0, 0, 0, 0, 91, 92, 93, 0, 0, 0, + 0, 0, 403, 404, 405, 406, 407, 408, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 955, 0, 0, 0, 0, 0, 0, 0, 0, + 878, 0, 0, 0, 0, 0, 0, 878, 878, 0, + 0, 878, 974, 0, 0, 0, 0, 0, 0, 0, + 878, 0, 0, 0, 0, 91, 92, 93, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 878, 0, 0, 0, 0, 0, 0, 47, 48, + 878, 0, 0, 67, 68, 69, 70, 71, 72, 73, + 74, 75, 76, 0, 0, 0, 0, 396, 0, 397, + 0, 878, 0, 0, 0, 0, 0, 0, 0, 0, + 398, 0, 399, 400, 401, 0, 0, 402, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 878, 0, + 878, 403, 404, 405, 406, 407, 408, 0, 0, 0, + 65, 48, 878, 0, 66, 67, 68, 69, 70, 71, + 72, 73, 74, 75, 76, 0, 0, 47, 48, 77, + 878, 78, 67, 68, 69, 70, 71, 72, 73, 74, + 75, 76, 79, 0, 80, 0, 0, 985, 591, 878, + 878, 0, 0, 0, 91, 92, 93, 47, 48, 0, + 878, 0, 67, 68, 69, 70, 71, 72, 73, 74, + 75, 76, 0, 0, 0, 0, 0, 0, 591, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, + 87, 88, 89, 90, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 91, 92, 93, 0, + 0, 0, 0, 866, 867, 868, 869, 870, 871, 872, + 873, 0, 0, 91, 92, 93, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 866, 867, 868, 869, 870, 871, 872, + 873, 0, 0, 91, 92, 93, 65, 48, 0, 0, + 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 76, 0, 0, 0, 0, 77, 0, 78, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 79, 0, + 80, 47, 48, 0, 0, 220, 67, 68, 69, 70, + 71, 72, 73, 74, 75, 76, 0, 0, 0, 0, + 221, 222, 223, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 224, 0, 225, 0, 0, 0, 0, + 0, 0, 0, 0, 47, 48, 647, 648, 220, 67, + 68, 69, 70, 71, 72, 73, 74, 75, 76, 0, + 0, 0, 0, 221, 292, 223, 0, 0, 0, 0, + 0, 0, 91, 92, 93, 0, 224, 0, 225, 47, + 48, 0, 0, 220, 67, 68, 69, 70, 71, 72, + 73, 74, 75, 76, 0, 0, 0, 0, 221, 335, + 223, 0, 0, 0, 0, 0, 0, 91, 92, 93, + 0, 224, 0, 225, 47, 48, 0, 0, 290, 67, + 68, 69, 70, 71, 72, 73, 74, 75, 76, 0, + 0, 0, 0, 176, 0, 177, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 178, 0, 179, 0, + 91, 92, 93, 0, 0, 0, 47, 48, 0, 0, + 220, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 76, 0, 0, 0, 0, 221, 0, 223, 0, 0, + 0, 0, 0, 0, 0, 91, 92, 93, 224, 0, + 225, 47, 48, 0, 0, 0, 67, 68, 69, 70, + 71, 72, 73, 74, 75, 76, 0, 0, 0, 0, + 221, 0, 223, 0, 0, 0, 0, 0, 0, 0, + 91, 92, 93, 224, 0, 225, 47, 48, 0, 0, + 0, 67, 68, 69, 70, 71, 72, 73, 74, 75, + 76, 0, 0, 0, 0, 396, 0, 397, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 398, 0, + 399, 0, 91, 92, 93, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 91, 92, 93, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 91, 92, 93 +}; + +static const short yycheck[] = { 29, + 24, 49, 37, 404, 11, 810, 27, 111, 43, 86, + 87, 88, 31, 90, 37, 22, 31, 460, 227, 117, + 43, 112, 268, 223, 113, 269, 504, 36, 284, 37, + 26, 110, 251, 176, 135, 43, 255, 283, 111, 395, + 113, 251, 4, 117, 550, 255, 11, 251, 251, 558, + 559, 255, 255, 114, 106, 29, 959, 175, 135, 177, + 665, 719, 24, 5, 669, 7, 52, 115, 574, 575, + 94, 4, 70, 731, 26, 26, 106, 26, 221, 36, + 70, 179, 70, 36, 114, 115, 116, 117, 165, 77, + 3, 87, 5, 6, 7, 30, 185, 1000, 106, 73, + 847, 3, 123, 581, 134, 179, 114, 115, 116, 117, + 119, 54, 917, 173, 162, 30, 140, 69, 69, 117, + 5, 6, 7, 144, 89, 58, 28, 225, 118, 177, + 339, 229, 879, 68, 29, 142, 171, 197, 198, 582, + 238, 397, 27, 4, 106, 175, 176, 177, 171, 179, + 251, 225, 213, 68, 255, 229, 23, 513, 210, 26, + 893, 819, 119, 171, 238, 217, 119, 175, 176, 177, + 65, 179, 905, 68, 251, 223, 3, 119, 255, 31, + 210, 844, 787, 213, 26, 663, 329, 217, 397, 31, + 139, 221, 438, 223, 143, 225, 902, 24, 442, 229, + 343, 299, 210, 449, 308, 213, 119, 237, 238, 217, + 270, 302, 330, 221, 723, 223, 68, 225, 278, 31, + 883, 229, 24, 104, 303, 299, 435, 257, 31, 290, + 238, 189, 738, 191, 119, 324, 194, 481, 70, 399, + 285, 5, 6, 7, 29, 29, 306, 79, 80, 347, + 24, 209, 412, 55, 28, 474, 68, 3, 318, 992, + 290, 365, 518, 67, 474, 68, 744, 745, 974, 299, + 474, 474, 53, 347, 3, 327, 70, 366, 24, 535, + 65, 65, 290, 936, 363, 364, 429, 81, 941, 29, + 363, 299, 365, 366, 4, 24, 62, 327, 64, 329, + 330, 1034, 1035, 322, 747, 3, 4, 322, 6, 1015, + 1016, 1017, 1018, 343, 24, 345, 45, 347, 47, 327, + 18, 329, 330, 466, 22, 65, 24, 4, 68, 27, + 390, 355, 3, 393, 215, 343, 4, 345, 368, 347, + 5, 6, 7, 18, 433, 375, 304, 24, 369, 397, + 828, 396, 397, 24, 22, 119, 24, 402, 614, 1012, + 25, 26, 27, 408, 6, 24, 5, 6, 7, 529, + 530, 531, 532, 474, 434, 853, 19, 537, 21, 6, + 425, 147, 401, 264, 26, 27, 401, 488, 27, 155, + 636, 157, 452, 6, 33, 455, 94, 474, 69, 429, + 27, 4, 73, 24, 423, 459, 4, 28, 423, 3, + 291, 488, 25, 26, 27, 296, 476, 3, 4, 496, + 21, 429, 25, 458, 459, 523, 24, 671, 3, 4, + 24, 450, 24, 1, 494, 450, 466, 497, 24, 499, + 32, 471, 19, 871, 872, 41, 5, 6, 7, 24, + 458, 459, 20, 8, 119, 546, 547, 487, 466, 550, + 490, 621, 368, 623, 624, 625, 25, 26, 27, 375, + 524, 525, 49, 50, 51, 579, 3, 4, 538, 1007, + 119, 558, 559, 574, 575, 539, 540, 8, 533, 524, + 525, 8, 23, 523, 583, 26, 26, 24, 577, 3, + 4, 929, 930, 33, 539, 540, 36, 21, 708, 709, + 1038, 1039, 1040, 3, 942, 523, 524, 525, 578, 617, + 24, 25, 41, 558, 559, 5, 6, 7, 409, 78, + 31, 539, 540, 935, 24, 639, 937, 938, 53, 563, + 41, 422, 944, 591, 565, 25, 70, 27, 4, 951, + 558, 559, 76, 8, 44, 45, 46, 47, 206, 768, + 119, 26, 607, 26, 29, 3, 4, 32, 613, 32, + 647, 648, 99, 100, 101, 102, 103, 104, 105, 106, + 18, 462, 627, 8, 22, 23, 24, 617, 56, 57, + 58, 59, 1020, 995, 618, 19, 656, 21, 619, 11, + 1002, 620, 662, 25, 26, 620, 1034, 631, 808, 617, + 33, 632, 1014, 70, 71, 19, 70, 21, 75, 73, + 268, 23, 657, 21, 26, 649, 112, 113, 114, 115, + 116, 19, 653, 21, 657, 283, 517, 23, 25, 119, + 26, 1043, 1044, 1045, 1046, 722, 723, 738, 26, 657, + 28, 696, 712, 683, 684, 93, 94, 23, 3, 4, + 26, 309, 310, 21, 23, 3, 4, 26, 6, 773, + 19, 319, 21, 733, 3, 4, 29, 30, 708, 709, + 18, 4, 23, 26, 22, 26, 24, 25, 723, 18, + 3, 4, 19, 22, 21, 24, 25, 49, 50, 51, + 708, 709, 3, 4, 19, 18, 21, 3, 4, 22, + 755, 24, 3, 4, 4, 723, 761, 33, 763, 764, + 765, 798, 18, 24, 25, 770, 22, 19, 24, 21, + 87, 32, 380, 24, 615, 4, 743, 530, 531, 532, + 8, 9, 766, 25, 26, 87, 394, 628, 769, 25, + 26, 25, 26, 25, 26, 93, 94, 817, 3, 4, + 73, 791, 858, 36, 93, 94, 8, 863, 864, 25, + 26, 3, 4, 18, 70, 25, 26, 22, 808, 24, + 29, 94, 25, 26, 3, 4, 30, 847, 37, 3, + 438, 3, 4, 838, 43, 31, 841, 93, 94, 18, + 808, 449, 832, 22, 30, 24, 97, 31, 99, 100, + 101, 102, 103, 104, 105, 106, 18, 3, 4, 879, + 28, 851, 3, 4, 832, 70, 922, 28, 858, 25, + 26, 31, 18, 863, 864, 25, 22, 933, 24, 884, + 89, 871, 872, 24, 25, 25, 26, 23, 93, 94, + 858, 32, 25, 26, 25, 863, 864, 25, 26, 36, + 109, 110, 111, 112, 113, 6, 873, 963, 25, 3, + 4, 25, 6, 26, 93, 94, 972, 907, 908, 24, + 910, 25, 26, 913, 18, 134, 25, 26, 22, 24, + 24, 898, 922, 27, 107, 108, 27, 993, 64, 929, + 930, 549, 27, 933, 87, 553, 554, 94, 94, 557, + 28, 160, 942, 87, 922, 28, 29, 95, 96, 41, + 3, 4, 171, 30, 173, 933, 1022, 1063, 1064, 23, + 25, 939, 940, 963, 942, 18, 185, 41, 31, 22, + 4, 24, 972, 23, 193, 28, 3, 4, 197, 198, + 8, 23, 4, 26, 33, 963, 1052, 206, 3, 4, + 94, 18, 21, 993, 972, 22, 87, 24, 25, 24, + 24, 1001, 8, 18, 30, 1071, 1072, 22, 17, 24, + 17, 3, 4, 11, 30, 993, 1082, 36, 636, 23, + 1020, 41, 1022, 25, 25, 25, 18, 8, 25, 68, + 22, 30, 24, 94, 1034, 1053, 31, 31, 257, 8, + 31, 94, 1020, 23, 1022, 62, 25, 3, 4, 268, + 269, 270, 1052, 25, 43, 29, 19, 1035, 25, 278, + 25, 25, 18, 21, 283, 25, 22, 94, 24, 8, + 25, 1071, 1072, 25, 1052, 68, 64, 25, 27, 94, + 66, 66, 1082, 302, 303, 69, 31, 306, 26, 308, + 309, 310, 25, 1071, 1072, 87, 36, 715, 21, 318, + 319, 19, 94, 28, 1082, 324, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, 22, 68, 3, 4, + 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, 69, 68, 23, 26, 22, 94, 24, + 25, 25, 74, 40, 363, 364, 365, 366, 28, 368, + 35, 40, 37, 63, 68, 26, 375, 69, 69, 72, + 21, 380, 69, 87, 18, 87, 26, 23, 34, 22, + 69, 390, 30, 8, 393, 394, 22, 28, 26, 19, + 8, 18, 18, 3, 3, 4, 5, 6, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 16, 17, 26, + 18, 4, 24, 22, 43, 24, 25, 109, 110, 111, + 22, 22, 18, 22, 433, 434, 35, 24, 37, 438, + 8, 8, 3, 442, 109, 110, 111, 18, 30, 11, + 449, 11, 30, 452, 119, 19, 455, 8, 24, 458, + 459, 33, 11, 11, 11, 11, 18, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 476, 18, 18, + 18, 40, 481, 24, 19, 19, 19, 11, 487, 25, + 11, 11, 137, 25, 106, 494, 26, 25, 497, 28, + 499, 28, 114, 115, 116, 117, 19, 19, 19, 40, + 109, 110, 111, 19, 0, 25, 25, 25, 25, 21, + 119, 21, 0, 135, 134, 524, 525, 487, 668, 785, + 677, 742, 500, 729, 915, 887, 1001, 851, 817, 538, + 539, 540, 1035, 992, 1057, 1020, 1028, 546, 547, 548, + 549, 550, 18, 18, 553, 554, 97, 41, 557, 558, + 559, 678, 683, 175, 176, 177, 57, 179, 109, 110, + 111, 252, 57, 43, 171, 574, 575, 121, 577, 578, + 579, 551, 721, 494, 583, 497, 474, 112, 255, 723, + 547, 488, 559, 541, 761, 396, 617, 758, 210, 709, + 808, 213, 917, 756, 345, 217, 397, -1, 553, 221, + -1, 223, -1, 225, -1, -1, -1, 229, -1, -1, + -1, -1, 3, 4, -1, -1, 238, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 636, -1, -1, + 639, 22, -1, 24, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 35, -1, 37, 656, 657, -1, + -1, -1, -1, 662, -1, -1, -1, -1, -1, -1, + -1, -1, 671, -1, -1, -1, -1, -1, 290, -1, + -1, -1, -1, -1, -1, -1, -1, 299, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 712, -1, 327, 715, 329, 330, -1, + 719, -1, -1, -1, 723, -1, -1, -1, 109, 110, + 111, 343, 731, 345, 733, 347, -1, -1, -1, 738, + -1, -1, 354, 3, 4, 5, 6, 7, 8, 9, + 10, 11, 12, 13, 14, 15, 16, 17, -1, -1, + -1, -1, 22, -1, 24, 25, -1, 27, -1, -1, + -1, -1, -1, -1, 773, 35, -1, 37, 38, 39, + -1, -1, 42, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 56, 57, 58, 59, + 60, 61, 3, 4, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 429, 817, -1, + 819, 22, -1, 24, 25, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 35, -1, 37, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 847, 109, + 110, 111, -1, -1, 466, -1, -1, -1, -1, 119, + -1, -1, -1, -1, -1, -1, -1, 866, 867, 868, + 869, 870, -1, -1, -1, -1, 488, -1, 490, -1, + 879, 3, 4, -1, -1, -1, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, -1, -1, -1, -1, + -1, -1, 24, -1, -1, -1, -1, 906, 109, 110, + 111, 523, -1, -1, -1, -1, 38, 39, 119, -1, + 42, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 935, -1, 60, -1, + -1, -1, -1, -1, -1, 944, -1, -1, -1, -1, + -1, -1, 951, -1, 953, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 88, 89, 90, 91, + 92, -1, -1, -1, -1, -1, 98, 99, 100, 101, + 102, 103, 104, 105, 106, -1, -1, 109, 110, 111, + -1, -1, -1, -1, -1, -1, 995, -1, -1, -1, + -1, -1, -1, 1002, -1, 617, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 1014, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 1028, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 1043, 1044, 1045, 1046, 3, 4, + -1, -1, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, -1, -1, -1, -1, 22, -1, 24, + -1, 683, -1, 685, -1, -1, -1, -1, -1, -1, + 35, -1, 37, -1, -1, -1, -1, -1, -1, 44, + 45, 46, 47, 48, -1, -1, 708, 709, -1, -1, + -1, -1, -1, -1, 3, 4, -1, -1, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 16, 17, -1, + -1, -1, -1, 22, 23, 24, -1, 82, 83, 84, + 85, 86, -1, -1, -1, -1, 35, -1, 37, 38, + 39, -1, -1, 42, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, 109, 110, 111, 56, 57, 58, + 59, 60, 61, -1, -1, -1, -1, -1, 3, 4, + -1, -1, 7, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, -1, -1, -1, -1, 22, -1, 24, + 25, -1, -1, -1, -1, -1, 808, -1, -1, -1, + 35, -1, 37, 38, 39, -1, -1, 42, -1, -1, + 109, 110, 111, -1, -1, -1, -1, -1, -1, -1, + 832, 56, 57, 58, 59, 60, 61, -1, -1, 3, + 4, -1, -1, 7, 8, 9, 10, 11, 12, 13, + 14, 15, 16, 17, -1, -1, 858, -1, 22, 861, + 24, 863, 864, -1, -1, -1, -1, -1, -1, 871, + 872, 35, -1, 37, 38, 39, -1, -1, 42, -1, + -1, -1, -1, -1, 109, 110, 111, -1, -1, -1, + -1, -1, 56, 57, 58, 59, 60, 61, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 913, -1, -1, -1, -1, -1, -1, -1, -1, + 922, -1, -1, -1, -1, -1, -1, 929, 930, -1, + -1, 933, 934, -1, -1, -1, -1, -1, -1, -1, + 942, -1, -1, -1, -1, 109, 110, 111, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, 963, -1, -1, -1, -1, -1, -1, 3, 4, + 972, -1, -1, 8, 9, 10, 11, 12, 13, 14, + 15, 16, 17, -1, -1, -1, -1, 22, -1, 24, + -1, 993, -1, -1, -1, -1, -1, -1, -1, -1, + 35, -1, 37, 38, 39, -1, -1, 42, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 1020, -1, + 1022, 56, 57, 58, 59, 60, 61, -1, -1, -1, + 3, 4, 1034, -1, 7, 8, 9, 10, 11, 12, + 13, 14, 15, 16, 17, -1, -1, 3, 4, 22, + 1052, 24, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, 35, -1, 37, -1, -1, 23, 24, 1071, + 1072, -1, -1, -1, 109, 110, 111, 3, 4, -1, + 1082, -1, 8, 9, 10, 11, 12, 13, 14, 15, + 16, 17, -1, -1, -1, -1, -1, -1, 24, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, + 83, 84, 85, 86, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 109, 110, 111, -1, + -1, -1, -1, 99, 100, 101, 102, 103, 104, 105, + 106, -1, -1, 109, 110, 111, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 99, 100, 101, 102, 103, 104, 105, + 106, -1, -1, 109, 110, 111, 3, 4, -1, -1, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, -1, -1, -1, -1, 22, -1, 24, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 35, -1, + 37, 3, 4, -1, -1, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, -1, -1, -1, -1, + 22, 23, 24, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, 35, -1, 37, -1, -1, -1, -1, + -1, -1, -1, -1, 3, 4, 83, 84, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 16, 17, -1, + -1, -1, -1, 22, 23, 24, -1, -1, -1, -1, + -1, -1, 109, 110, 111, -1, 35, -1, 37, 3, + 4, -1, -1, 7, 8, 9, 10, 11, 12, 13, + 14, 15, 16, 17, -1, -1, -1, -1, 22, 23, + 24, -1, -1, -1, -1, -1, -1, 109, 110, 111, + -1, 35, -1, 37, 3, 4, -1, -1, 7, 8, + 9, 10, 11, 12, 13, 14, 15, 16, 17, -1, + -1, -1, -1, 22, -1, 24, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, 35, -1, 37, -1, + 109, 110, 111, -1, -1, -1, 3, 4, -1, -1, + 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, -1, -1, -1, -1, 22, -1, 24, -1, -1, + -1, -1, -1, -1, -1, 109, 110, 111, 35, -1, + 37, 3, 4, -1, -1, -1, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, -1, -1, -1, -1, + 22, -1, 24, -1, -1, -1, -1, -1, -1, -1, + 109, 110, 111, 35, -1, 37, 3, 4, -1, -1, + -1, 8, 9, 10, 11, 12, 13, 14, 15, 16, + 17, -1, -1, -1, -1, 22, -1, 24, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 35, -1, + 37, -1, 109, 110, 111, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, 109, 110, 111, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, 109, 110, 111 +}; +/* -*-C-*- Note some compilers choke on comments on `#line' lines. */ +#line 3 "/usr/local/gnu/lib/bison.simple" + +/* Skeleton output parser for bison, + Copyright (C) 1984, 1989, 1990 Bob Corbett and Richard Stallman + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + + +#ifndef alloca +#ifdef __GNUC__ +#define alloca __builtin_alloca +#else /* not GNU C. */ +#if (!defined (__STDC__) && defined (sparc)) || defined (__sparc__) || defined (__sparc) || defined (__sgi) +#include +#else /* not sparc */ +#if defined (MSDOS) && !defined (__TURBOC__) +#include +#else /* not MSDOS, or __TURBOC__ */ +#if defined(_AIX) +#include + #pragma alloca +#else /* not MSDOS, __TURBOC__, or _AIX */ +#ifdef __hpux +#ifdef __cplusplus +extern "C" { +void *alloca (unsigned int); +}; +#else /* not __cplusplus */ +void *alloca (unsigned int); +#endif /* not __cplusplus */ +#endif /* __hpux */ +#endif /* not _AIX */ +#endif /* not MSDOS, or __TURBOC__ */ +#endif /* not sparc. */ +#endif /* not GNU C. */ +#endif /* alloca not defined. */ + +/* This is the parser code that is written into each bison parser + when the %semantic_parser declaration is not specified in the grammar. + It was written by Richard Stallman by simplifying the hairy parser + used when %semantic_parser is specified. */ + +/* Note: there must be only one dollar sign in this file. + It is replaced by the list of actions, each action + as one case of the switch. */ + +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY -2 +#define YYEOF 0 +#define YYACCEPT return(0) +#define YYABORT return(1) +#define YYERROR goto yyerrlab1 +/* Like YYERROR except do call yyerror. + This remains here temporarily to ease the + transition to the new meaning of YYERROR, for GCC. + Once GCC version 2 has supplanted version 1, this can go. */ +#define YYFAIL goto yyerrlab +#define YYRECOVERING() (!!yyerrstatus) +#define YYBACKUP(token, value) \ +do \ + if (yychar == YYEMPTY && yylen == 1) \ + { yychar = (token), yylval = (value); \ + yychar1 = YYTRANSLATE (yychar); \ + YYPOPSTACK; \ + goto yybackup; \ + } \ + else \ + { yyerror ("syntax error: cannot back up"); YYERROR; } \ +while (0) + +#define YYTERROR 1 +#define YYERRCODE 256 + +#ifndef YYPURE +#define YYLEX yylex() +#endif + +#ifdef YYPURE +#ifdef YYLSP_NEEDED +#define YYLEX yylex(&yylval, &yylloc) +#else +#define YYLEX yylex(&yylval) +#endif +#endif + +/* If nonreentrant, generate the variables here */ + +#ifndef YYPURE + +int yychar; /* the lookahead symbol */ +YYSTYPE yylval; /* the semantic value of the */ + /* lookahead symbol */ + +#ifdef YYLSP_NEEDED +YYLTYPE yylloc; /* location data for the lookahead */ + /* symbol */ +#endif + +int yynerrs; /* number of parse errors so far */ +#endif /* not YYPURE */ + +#if YYDEBUG != 0 +int yydebug; /* nonzero means print parse trace */ +/* Since this is uninitialized, it does not stop multiple parsers + from coexisting. */ +#endif + +/* YYINITDEPTH indicates the initial size of the parser's stacks */ + +#ifndef YYINITDEPTH +#define YYINITDEPTH 200 +#endif + +/* YYMAXDEPTH is the maximum size the stacks can grow to + (effective only if the built-in stack extension method is used). */ + +#if YYMAXDEPTH == 0 +#undef YYMAXDEPTH +#endif + +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 10000 +#endif + +/* Prevent warning if -Wstrict-prototypes. */ +#ifdef __GNUC__ +int yyparse (void); +#endif + +#if __GNUC__ > 1 /* GNU C and GNU C++ define this. */ +#define __yy_bcopy(FROM,TO,COUNT) __builtin_memcpy(TO,FROM,COUNT) +#else /* not GNU C or C++ */ +#ifndef __cplusplus + +/* This is the most reliable way to avoid incompatibilities + in available built-in functions on various systems. */ +static void +__yy_bcopy (from, to, count) + char *from; + char *to; + int count; +{ + register char *f = from; + register char *t = to; + register int i = count; + + while (i-- > 0) + *t++ = *f++; +} + +#else /* __cplusplus */ + +/* This is the most reliable way to avoid incompatibilities + in available built-in functions on various systems. */ +static void +__yy_bcopy (char *from, char *to, int count) +{ + register char *f = from; + register char *t = to; + register int i = count; + + while (i-- > 0) + *t++ = *f++; +} + +#endif +#endif + +#line 184 "/usr/local/gnu/lib/bison.simple" +int +yyparse() +{ + register int yystate; + register int yyn; + register short *yyssp; + register YYSTYPE *yyvsp; + int yyerrstatus; /* number of tokens to shift before error messages enabled */ + int yychar1; /* lookahead token as an internal (translated) token number */ + + short yyssa[YYINITDEPTH]; /* the state stack */ + YYSTYPE yyvsa[YYINITDEPTH]; /* the semantic value stack */ + + short *yyss = yyssa; /* refer to the stacks thru separate pointers */ + YYSTYPE *yyvs = yyvsa; /* to allow yyoverflow to reallocate them elsewhere */ + +#ifdef YYLSP_NEEDED + YYLTYPE yylsa[YYINITDEPTH]; /* the location stack */ + YYLTYPE *yyls = yylsa; + YYLTYPE *yylsp; + +#define YYPOPSTACK (yyvsp--, yyssp--, yylsp--) +#else +#define YYPOPSTACK (yyvsp--, yyssp--) +#endif + + int yystacksize = YYINITDEPTH; + +#ifdef YYPURE + int yychar; + YYSTYPE yylval; + int yynerrs; +#ifdef YYLSP_NEEDED + YYLTYPE yylloc; +#endif +#endif + + YYSTYPE yyval; /* the variable used to return */ + /* semantic values from the action */ + /* routines */ + + int yylen; + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Starting parse\n"); +#endif + + yystate = 0; + yyerrstatus = 0; + yynerrs = 0; + yychar = YYEMPTY; /* Cause a token to be read. */ + + /* Initialize stack pointers. + Waste one element of value and location stack + so that they stay on the same level as the state stack. + The wasted elements are never initialized. */ + + yyssp = yyss - 1; + yyvsp = yyvs; +#ifdef YYLSP_NEEDED + yylsp = yyls; +#endif + +/* Push a new state, which is found in yystate . */ +/* In all cases, when you get here, the value and location stacks + have just been pushed. so pushing a state here evens the stacks. */ +yynewstate: + + *++yyssp = yystate; + + if (yyssp >= yyss + yystacksize - 1) + { + /* Give user a chance to reallocate the stack */ + /* Use copies of these so that the &'s don't force the real ones into memory. */ + YYSTYPE *yyvs1 = yyvs; + short *yyss1 = yyss; +#ifdef YYLSP_NEEDED + YYLTYPE *yyls1 = yyls; +#endif + + /* Get the current used size of the three stacks, in elements. */ + int size = yyssp - yyss + 1; + +#ifdef yyoverflow + /* Each stack pointer address is followed by the size of + the data in use in that stack, in bytes. */ + yyoverflow("parser stack overflow", + &yyss1, size * sizeof (*yyssp), + &yyvs1, size * sizeof (*yyvsp), +#ifdef YYLSP_NEEDED + &yyls1, size * sizeof (*yylsp), +#endif + &yystacksize); + + yyss = yyss1; yyvs = yyvs1; +#ifdef YYLSP_NEEDED + yyls = yyls1; +#endif +#else /* no yyoverflow */ + /* Extend the stack our own way. */ + if (yystacksize >= YYMAXDEPTH) + { + yyerror("parser stack overflow"); + return 2; + } + yystacksize *= 2; + if (yystacksize > YYMAXDEPTH) + yystacksize = YYMAXDEPTH; + yyss = (short *) alloca (yystacksize * sizeof (*yyssp)); + __yy_bcopy ((char *)yyss1, (char *)yyss, size * sizeof (*yyssp)); + yyvs = (YYSTYPE *) alloca (yystacksize * sizeof (*yyvsp)); + __yy_bcopy ((char *)yyvs1, (char *)yyvs, size * sizeof (*yyvsp)); +#ifdef YYLSP_NEEDED + yyls = (YYLTYPE *) alloca (yystacksize * sizeof (*yylsp)); + __yy_bcopy ((char *)yyls1, (char *)yyls, size * sizeof (*yylsp)); +#endif +#endif /* no yyoverflow */ + + yyssp = yyss + size - 1; + yyvsp = yyvs + size - 1; +#ifdef YYLSP_NEEDED + yylsp = yyls + size - 1; +#endif + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Stack size increased to %d\n", yystacksize); +#endif + + if (yyssp >= yyss + yystacksize - 1) + YYABORT; + } + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Entering state %d\n", yystate); +#endif + + goto yybackup; + yybackup: + +/* Do appropriate processing given the current state. */ +/* Read a lookahead token if we need one and don't already have one. */ +/* yyresume: */ + + /* First try to decide what to do without reference to lookahead token. */ + + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yydefault; + + /* Not known => get a lookahead token if don't already have one. */ + + /* yychar is either YYEMPTY or YYEOF + or a valid token in external form. */ + + if (yychar == YYEMPTY) + { +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Reading a token: "); +#endif + yychar = YYLEX; + } + + /* Convert token to internal form (in yychar1) for indexing tables with */ + + if (yychar <= 0) /* This means end of input. */ + { + yychar1 = 0; + yychar = YYEOF; /* Don't call YYLEX any more */ + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Now at end of input.\n"); +#endif + } + else + { + yychar1 = YYTRANSLATE(yychar); + +#if YYDEBUG != 0 + if (yydebug) + { + fprintf (stderr, "Next token is %d (%s", yychar, yytname[yychar1]); + /* Give the individual parser a way to print the precise meaning + of a token, for further debugging info. */ +#ifdef YYPRINT + YYPRINT (stderr, yychar, yylval); +#endif + fprintf (stderr, ")\n"); + } +#endif + } + + yyn += yychar1; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1) + goto yydefault; + + yyn = yytable[yyn]; + + /* yyn is what to do for this token type in this state. + Negative => reduce, -yyn is rule number. + Positive => shift, yyn is new state. + New state is final state => don't bother to shift, + just return success. + 0, or most negative number => error. */ + + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrlab; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrlab; + + if (yyn == YYFINAL) + YYACCEPT; + + /* Shift the lookahead token. */ + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Shifting token %d (%s), ", yychar, yytname[yychar1]); +#endif + + /* Discard the token being shifted unless it is eof. */ + if (yychar != YYEOF) + yychar = YYEMPTY; + + *++yyvsp = yylval; +#ifdef YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + /* count tokens shifted since error; after three, turn off error status. */ + if (yyerrstatus) yyerrstatus--; + + yystate = yyn; + goto yynewstate; + +/* Do the default action for the current state. */ +yydefault: + + yyn = yydefact[yystate]; + if (yyn == 0) + goto yyerrlab; + +/* Do a reduction. yyn is the number of a rule to reduce with. */ +yyreduce: + yylen = yyr2[yyn]; + yyval = yyvsp[1-yylen]; /* implement default value of the action */ + +#if YYDEBUG != 0 + if (yydebug) + { + int i; + + fprintf (stderr, "Reducing via rule %d (line %d), ", + yyn, yyrline[yyn]); + + /* Print the symbols being reduced, and their result. */ + for (i = yyprhs[yyn]; yyrhs[i] > 0; i++) + fprintf (stderr, "%s ", yytname[yyrhs[i]]); + fprintf (stderr, " -> %s\n", yytname[yyr1[yyn]]); + } +#endif + + + switch (yyn) { + +case 2: +#line 335 "yaccParser/hsparser.y" +{ the_module_name = yyvsp[-1].uid; module_exports = yyvsp[0].ulist; ; + break;} +case 4: +#line 337 "yaccParser/hsparser.y" +{ the_module_name = install_literal("Main"); module_exports = Lnil; ; + break;} +case 6: +#line 343 "yaccParser/hsparser.y" +{ + root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-3].ulist),module_exports,yyvsp[-1].ubinding,startlineno); + ; + break;} +case 7: +#line 347 "yaccParser/hsparser.y" +{ + root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-3].ulist),module_exports,yyvsp[-1].ubinding,startlineno); + ; + break;} +case 8: +#line 352 "yaccParser/hsparser.y" +{ + root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno); + ; + break;} +case 9: +#line 356 "yaccParser/hsparser.y" +{ + root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno); + ; + break;} +case 10: +#line 362 "yaccParser/hsparser.y" +{ + root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno); + ; + break;} +case 11: +#line 366 "yaccParser/hsparser.y" +{ + root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno); + ; + break;} +case 12: +#line 372 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 13: +#line 373 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 14: +#line 377 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uentid); ; + break;} +case 15: +#line 378 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uentid); ; + break;} +case 16: +#line 382 "yaccParser/hsparser.y" +{ yyval.uentid = mkentid(yyvsp[0].uid); ; + break;} +case 17: +#line 383 "yaccParser/hsparser.y" +{ yyval.uentid = mkenttype(yyvsp[0].uid); ; + break;} +case 18: +#line 384 "yaccParser/hsparser.y" +{ yyval.uentid = mkenttypeall(yyvsp[-3].uid); ; + break;} +case 19: +#line 386 "yaccParser/hsparser.y" +{ yyval.uentid = mkenttypecons(yyvsp[-3].uid,yyvsp[-1].ulist); + /* should be a datatype with cons representing all constructors */ + ; + break;} +case 20: +#line 390 "yaccParser/hsparser.y" +{ yyval.uentid = mkentclass(yyvsp[-3].uid,yyvsp[-1].ulist); + /* should be a class with vars representing all Class operations */ + ; + break;} +case 21: +#line 394 "yaccParser/hsparser.y" +{ yyval.uentid = mkentclass(yyvsp[-2].uid,Lnil); + /* "tycon" should be a class with no operations */ + ; + break;} +case 22: +#line 398 "yaccParser/hsparser.y" +{ yyval.uentid = mkentmod(yyvsp[-1].uid); + /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */ + ; + break;} +case 23: +#line 404 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; hidden = FALSE; ; + break;} +case 24: +#line 405 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; hidden = TRUE; ; + break;} +case 25: +#line 406 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; hidden = FALSE; ; + break;} +case 26: +#line 409 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 27: +#line 410 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 28: +#line 414 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uentid); ; + break;} +case 29: +#line 415 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uentid); ; + break;} +case 30: +#line 419 "yaccParser/hsparser.y" +{ yyval.uentid = mkentid(yyvsp[0].uid); ; + break;} +case 31: +#line 420 "yaccParser/hsparser.y" +{ yyval.uentid = mkenttype(yyvsp[0].uid); ; + break;} +case 32: +#line 421 "yaccParser/hsparser.y" +{ yyval.uentid = mkenttypeall(yyvsp[-3].uid); ; + break;} +case 33: +#line 423 "yaccParser/hsparser.y" +{ yyval.uentid = mkenttypecons(yyvsp[-3].uid,yyvsp[-1].ulist); + /* should be a datatype with cons representing all constructors */ + ; + break;} +case 34: +#line 427 "yaccParser/hsparser.y" +{ yyval.uentid = mkentclass(yyvsp[-3].uid,yyvsp[-1].ulist); + /* should be a class with vars representing all Class operations */ + ; + break;} +case 35: +#line 431 "yaccParser/hsparser.y" +{ yyval.uentid = mkentclass(yyvsp[-2].uid,Lnil); + /* "tycon" should be a class with no operations */ + ; + break;} +case 36: +#line 440 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkidata_pragma(yyvsp[-2].ulist, yyvsp[-1].ulist); ; + break;} +case 37: +#line 442 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkidata_pragma(Lnil, yyvsp[-1].ulist); ; + break;} +case 38: +#line 443 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 39: +#line 448 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 40: +#line 449 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 41: +#line 453 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uhpragma); ; + break;} +case 42: +#line 455 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ; + break;} +case 43: +#line 459 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkidata_pragma_4s(yyvsp[-1].ulist); ; + break;} +case 44: +#line 463 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkitype_pragma(); ; + break;} +case 45: +#line 464 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 46: +#line 468 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiclas_pragma(yyvsp[-1].ulist); ; + break;} +case 47: +#line 469 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 48: +#line 474 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiclasop_pragma(yyvsp[-2].uhpragma, yyvsp[-1].uhpragma); ; + break;} +case 49: +#line 476 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 50: +#line 481 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiinst_simpl_pragma(yyvsp[-2].uid, yyvsp[-1].uhpragma); ; + break;} +case 51: +#line 484 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiinst_const_pragma(yyvsp[-3].uid, yyvsp[-2].uhpragma, yyvsp[-1].ulist); ; + break;} +case 52: +#line 487 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiinst_spec_pragma(yyvsp[-3].uid, yyvsp[-2].uhpragma, yyvsp[-1].ulist); ; + break;} +case 53: +#line 490 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 54: +#line 495 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[0].uid; ; + break;} +case 55: +#line 497 "yaccParser/hsparser.y" +{ yyval.uid = install_literal(""); ; + break;} +case 56: +#line 500 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 57: +#line 505 "yaccParser/hsparser.y" +{ yyval.uhpragma = yyvsp[-1].uhpragma; ; + break;} +case 58: +#line 507 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 59: +#line 512 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 60: +#line 514 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkigen_pragma(yyvsp[-5].uhpragma, yyvsp[-4].uhpragma, yyvsp[-3].uhpragma, yyvsp[-2].uhpragma, yyvsp[-1].uhpragma, yyvsp[0].ulist); ; + break;} +case 61: +#line 518 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 62: +#line 519 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiarity_pragma(yyvsp[0].ustring); ; + break;} +case 63: +#line 523 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 64: +#line 524 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiupdate_pragma(yyvsp[0].ustring); ; + break;} +case 65: +#line 528 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 66: +#line 529 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkideforest_pragma(); ; + break;} +case 67: +#line 533 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 68: +#line 534 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkistrictness_pragma(installHstring(1, "B"), + /* _!_ = COCON = bottom */ mkno_pragma()); + ; + break;} +case 69: +#line 538 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkistrictness_pragma(yyvsp[-1].uhstring, yyvsp[0].uhpragma); ; + break;} +case 70: +#line 542 "yaccParser/hsparser.y" +{ yyval.uhpragma = yyvsp[-1].uhpragma; ; + break;} +case 71: +#line 543 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 72: +#line 546 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkno_pragma(); ; + break;} +case 73: +#line 548 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkimagic_unfolding_pragma(yyvsp[0].uid); ; + break;} +case 74: +#line 550 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiunfolding_pragma(yyvsp[-1].uhpragma, yyvsp[0].ucoresyn); ; + break;} +case 75: +#line 555 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiunfold_always(); ; + break;} +case 76: +#line 557 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiunfold_if_args(yyvsp[-3].ustring, yyvsp[-2].ustring, yyvsp[-1].uid, yyvsp[0].ustring); ; + break;} +case 77: +#line 561 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uhpragma); ; + break;} +case 78: +#line 562 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ; + break;} +case 79: +#line 566 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 80: +#line 567 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 81: +#line 571 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uhpragma); ; + break;} +case 82: +#line 572 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ; + break;} +case 83: +#line 577 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkitype_pragma_pr(yyvsp[-3].ulist, yyvsp[-1].ustring, yyvsp[0].uhpragma); ; + break;} +case 84: +#line 581 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uhpragma); ; + break;} +case 85: +#line 582 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uhpragma); ; + break;} +case 86: +#line 587 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiinst_pragma_3s(yyvsp[-4].ulist, yyvsp[-2].ustring, yyvsp[-1].uhpragma, yyvsp[0].ulist); ; + break;} +case 87: +#line 591 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 88: +#line 592 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uttype); ; + break;} +case 89: +#line 596 "yaccParser/hsparser.y" +{ yyval.uttype = mkty_maybe_nothing(); ; + break;} +case 90: +#line 597 "yaccParser/hsparser.y" +{ yyval.uttype = mkty_maybe_just(yyvsp[0].uttype); ; + break;} +case 91: +#line 601 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 92: +#line 602 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 93: +#line 606 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uhpragma); ; + break;} +case 94: +#line 607 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ; + break;} +case 95: +#line 612 "yaccParser/hsparser.y" +{ yyval.uhpragma = mkiname_pragma_pr(yyvsp[-2].uid, yyvsp[0].uhpragma); ; + break;} +case 96: +#line 621 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcolam(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ; + break;} +case 97: +#line 623 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcotylam(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ; + break;} +case 98: +#line 625 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcocon(mkco_id(yyvsp[-2].uid), yyvsp[-1].ulist, yyvsp[0].ulist); ; + break;} +case 99: +#line 627 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcocon(mkco_orig_id(yyvsp[-3].uid,yyvsp[-2].uid), yyvsp[-1].ulist, yyvsp[0].ulist); ; + break;} +case 100: +#line 629 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoprim(yyvsp[-2].ucoresyn, yyvsp[-1].ulist, yyvsp[0].ulist); ; + break;} +case 101: +#line 631 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoapp(yyvsp[-1].ucoresyn, yyvsp[0].ulist); ; + break;} +case 102: +#line 633 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcotyapp(yyvsp[-3].ucoresyn, yyvsp[-1].uttype); ; + break;} +case 103: +#line 635 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcocase(yyvsp[-4].ucoresyn, yyvsp[-1].ucoresyn); ; + break;} +case 104: +#line 637 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcolet(mkcononrec(yyvsp[-5].ucoresyn, yyvsp[-3].ucoresyn), yyvsp[0].ucoresyn); ; + break;} +case 105: +#line 639 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcolet(mkcorec(yyvsp[-3].ulist), yyvsp[0].ucoresyn); ; + break;} +case 106: +#line 641 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoscc(yyvsp[-2].ucoresyn, yyvsp[0].ucoresyn); ; + break;} +case 107: +#line 642 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoliteral(yyvsp[0].uliteral); ; + break;} +case 108: +#line 643 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcovar(yyvsp[0].ucoresyn); ; + break;} +case 109: +#line 648 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoalg_alts(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ; + break;} +case 110: +#line 650 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoprim_alts(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ; + break;} +case 111: +#line 654 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 112: +#line 655 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ; + break;} +case 113: +#line 659 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoalg_alt(yyvsp[-4].ucoresyn, yyvsp[-3].ulist, yyvsp[-1].ucoresyn); ; + break;} +case 114: +#line 664 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 115: +#line 665 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ; + break;} +case 116: +#line 669 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcoprim_alt(yyvsp[-3].uliteral, yyvsp[-1].ucoresyn); ; + break;} +case 117: +#line 673 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkconodeflt(); ; + break;} +case 118: +#line 674 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcobinddeflt(yyvsp[-2].ucoresyn, yyvsp[0].ucoresyn); ; + break;} +case 119: +#line 678 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].ucoresyn); ; + break;} +case 120: +#line 679 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ; + break;} +case 121: +#line 683 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcorec_pair(yyvsp[-2].ucoresyn, yyvsp[0].ucoresyn); ; + break;} +case 122: +#line 687 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_preludedictscc(yyvsp[0].ucoresyn); ; + break;} +case 123: +#line 688 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_alldictscc(yyvsp[-2].uhstring,yyvsp[-1].uhstring,yyvsp[0].ucoresyn); ; + break;} +case 124: +#line 690 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_usercc(yyvsp[-4].uhstring,yyvsp[-3].uhstring,yyvsp[-2].uhstring,yyvsp[-1].ucoresyn,yyvsp[0].ucoresyn); ; + break;} +case 125: +#line 692 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_autocc(yyvsp[-4].ucoresyn,yyvsp[-3].uhstring,yyvsp[-2].uhstring,yyvsp[-1].ucoresyn,yyvsp[0].ucoresyn); ; + break;} +case 126: +#line 694 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_dictcc(yyvsp[-4].ucoresyn,yyvsp[-3].uhstring,yyvsp[-2].uhstring,yyvsp[-1].ucoresyn,yyvsp[0].ucoresyn); ; + break;} +case 127: +#line 696 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_scc_noncaf(); ; + break;} +case 128: +#line 697 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_scc_caf(); ; + break;} +case 129: +#line 699 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_scc_nondupd(); ; + break;} +case 130: +#line 700 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_scc_dupd(); ; + break;} +case 131: +#line 703 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_sdselid(yyvsp[-1].uid, yyvsp[0].uid); ; + break;} +case 132: +#line 704 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_classopid(yyvsp[-1].uid, yyvsp[0].uid); ; + break;} +case 133: +#line 705 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_defmid(yyvsp[-1].uid, yyvsp[0].uid); ; + break;} +case 134: +#line 707 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_dfunid(yyvsp[-3].uid, yyvsp[-1].uttype); ; + break;} +case 135: +#line 709 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_constmid(yyvsp[-4].uid, yyvsp[-3].uid, yyvsp[-1].uttype); ; + break;} +case 136: +#line 711 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_specid(yyvsp[-3].ucoresyn, yyvsp[-1].ulist); ; + break;} +case 137: +#line 712 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_wrkrid(yyvsp[0].ucoresyn); ; + break;} +case 138: +#line 713 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_orig_id(yyvsp[-1].uid, yyvsp[0].uid); ; + break;} +case 139: +#line 714 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_orig_id(yyvsp[-1].uid, yyvsp[0].uid); ; + break;} +case 140: +#line 715 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_id(yyvsp[0].uid); ; + break;} +case 141: +#line 716 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_id(yyvsp[0].uid); ; + break;} +case 142: +#line 721 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_ccall(yyvsp[-5].uid,0,yyvsp[-3].ulist,yyvsp[-2].uttype); ; + break;} +case 143: +#line 723 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_ccall(yyvsp[-5].uid,1,yyvsp[-3].ulist,yyvsp[-2].uttype); ; + break;} +case 144: +#line 725 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_casm(yyvsp[-5].uliteral,0,yyvsp[-3].ulist,yyvsp[-2].uttype); ; + break;} +case 145: +#line 727 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_casm(yyvsp[-5].uliteral,1,yyvsp[-3].ulist,yyvsp[-2].uttype); ; + break;} +case 146: +#line 728 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkco_primop(yyvsp[0].uid); ; + break;} +case 147: +#line 732 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 148: +#line 733 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ; + break;} +case 149: +#line 737 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcobinder(yyvsp[-3].uid, yyvsp[-1].uttype); ; + break;} +case 150: +#line 740 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 151: +#line 741 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 152: +#line 745 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].ucoresyn); ; + break;} +case 153: +#line 746 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ; + break;} +case 154: +#line 750 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcolit(yyvsp[0].uliteral); ; + break;} +case 155: +#line 751 "yaccParser/hsparser.y" +{ yyval.ucoresyn = mkcolocal(yyvsp[0].ucoresyn); ; + break;} +case 156: +#line 755 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 157: +#line 756 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].uid); ; + break;} +case 158: +#line 760 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 159: +#line 761 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uid); ; + break;} +case 160: +#line 765 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 161: +#line 766 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 162: +#line 770 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 163: +#line 771 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uttype); ; + break;} +case 164: +#line 775 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[0].uttype; ; + break;} +case 165: +#line 795 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 166: +#line 796 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uttype); ; + break;} +case 167: +#line 800 "yaccParser/hsparser.y" +{ yyval.uttype = mkty_maybe_nothing(); ; + break;} +case 168: +#line 801 "yaccParser/hsparser.y" +{ yyval.uttype = mkty_maybe_just(yyvsp[0].uttype); ; + break;} +case 169: +#line 807 "yaccParser/hsparser.y" +{ + if ( implicitPrelude && !etags ) { + /* we try to avoid reading interfaces when etagging */ + find_module_on_imports_dirlist( + (haskell1_3Flag) ? "PrelCore13" : "PreludeCore", + TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + ; + break;} +case 170: +#line 821 "yaccParser/hsparser.y" +{ + binding prelude_core = mkimport(installid(iface_name),Lnil,Lnil,yyvsp[0].ubinding,xstrdup(interface_filename),hsplineno); + prelude_core_import = implicitPrelude? lsing(prelude_core): Lnil; + + ; + break;} +case 171: +#line 829 "yaccParser/hsparser.y" +{ + if ( implicitPrelude && !etags ) { + find_module_on_imports_dirlist( + ( haskell1_3Flag ) ? "Prel13" : "Prelude", + TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + ; + break;} +case 172: +#line 842 "yaccParser/hsparser.y" +{ + binding prelude = mkimport(installid(iface_name),Lnil,Lnil,yyvsp[0].ubinding,xstrdup(interface_filename),hsplineno); + prelude_imports = (! implicitPrelude) ? Lnil + : lconc(prelude_core_import,lsing(prelude)); + ; + break;} +case 173: +#line 849 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 174: +#line 850 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 175: +#line 853 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 176: +#line 854 "yaccParser/hsparser.y" +{ yyval.ulist = lconc(yyvsp[-2].ulist,yyvsp[0].ulist); ; + break;} +case 177: +#line 858 "yaccParser/hsparser.y" +{ /* filename returned in "interface_filename" */ + char *module_name = id_to_string(yyvsp[0].uid); + if ( ! etags ) { + find_module_on_imports_dirlist( + (haskell1_3Flag && strcmp(module_name, "Prelude") == 0) + ? "Prel13" : module_name, + FALSE, interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + if (strcmp(module_name,"PreludeCore")==0) { + hsperror("Cannot explicitly import `PreludeCore'"); + + } else if (strcmp(module_name,"Prelude")==0) { + prelude_imports = prelude_core_import; /* unavoidable */ + } + ; + break;} +case 178: +#line 879 "yaccParser/hsparser.y" +{ + if (hidden) + yyvsp[0].ubinding->tag = hiding; + yyval.ulist = lsing(yyvsp[0].ubinding); + ; + break;} +case 179: +#line 887 "yaccParser/hsparser.y" +{ yyval.ubinding = mkimport(installid(iface_name),yyvsp[0].ulist,Lnil,yyvsp[-1].ubinding,xstrdup(interface_filename),hsplineno); ; + break;} +case 180: +#line 890 "yaccParser/hsparser.y" +{ yyval.ubinding = mkimport(installid(iface_name),yyvsp[-2].ulist,yyvsp[0].ulist,yyvsp[-3].ubinding,xstrdup(interface_filename),hsplineno); ; + break;} +case 181: +#line 895 "yaccParser/hsparser.y" +{ + exposeis(); /* partain: expose infix ops at level i+1 to level i */ + yyval.ubinding = yyvsp[-1].ubinding; + ; + break;} +case 182: +#line 901 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 183: +#line 905 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].ulist); ; + break;} +case 184: +#line 906 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].ulist); ; + break;} +case 185: +#line 909 "yaccParser/hsparser.y" +{ yyval.ulist = ldub(yyvsp[-2].uid,yyvsp[0].uid); ; + break;} +case 186: +#line 910 "yaccParser/hsparser.y" +{ yyval.ulist = ldub(yyvsp[-2].uid,yyvsp[0].uid); ; + break;} +case 187: +#line 913 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); ; + break;} +case 188: +#line 914 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[-1].ubinding; ; + break;} +case 189: +#line 917 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 190: +#line 918 "yaccParser/hsparser.y" +{ yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); ; + break;} +case 191: +#line 922 "yaccParser/hsparser.y" +{ yyval.ubinding = mkmbind(yyvsp[-3].uid,yyvsp[-1].ulist,Lnil,startlineno); ; + break;} +case 192: +#line 924 "yaccParser/hsparser.y" +{ yyval.ubinding = mkmbind(yyvsp[-5].uid,yyvsp[-3].ulist,yyvsp[0].ulist,startlineno); ; + break;} +case 193: +#line 930 "yaccParser/hsparser.y" +{ fixlist = Lnil; + strcpy(iface_name, id_to_string(yyvsp[0].uid)); + ; + break;} +case 194: +#line 934 "yaccParser/hsparser.y" +{ + /* WDP: not only do we not check the module name + but we take the one in the interface to be what we really want + -- we need this for Prelude jiggery-pokery. (Blech. KH) + ToDo: possibly revert.... + checkmodname(modname,id_to_string($2)); + */ + yyval.ubinding = yyvsp[0].ubinding; + ; + break;} +case 195: +#line 947 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkabind(yyvsp[-3].ubinding,yyvsp[-1].ubinding); + ; + break;} +case 196: +#line 951 "yaccParser/hsparser.y" +{ + yyval.ubinding = yyvsp[-1].ubinding; + ; + break;} +case 197: +#line 955 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkabind(yyvsp[-3].ubinding,yyvsp[-1].ubinding); + ; + break;} +case 198: +#line 959 "yaccParser/hsparser.y" +{ + yyval.ubinding = yyvsp[-1].ubinding; + ; + break;} +case 203: +#line 974 "yaccParser/hsparser.y" +{ Precedence = checkfixity(yyvsp[0].ustring); Fixity = INFIXL; ; + break;} +case 205: +#line 977 "yaccParser/hsparser.y" +{ Precedence = checkfixity(yyvsp[0].ustring); Fixity = INFIXR; ; + break;} +case 207: +#line 980 "yaccParser/hsparser.y" +{ Precedence = checkfixity(yyvsp[0].ustring); Fixity = INFIX; ; + break;} +case 209: +#line 983 "yaccParser/hsparser.y" +{ Fixity = INFIXL; Precedence = 9; ; + break;} +case 211: +#line 986 "yaccParser/hsparser.y" +{ Fixity = INFIXR; Precedence = 9; ; + break;} +case 213: +#line 989 "yaccParser/hsparser.y" +{ Fixity = INFIX; Precedence = 9; ; + break;} +case 215: +#line 993 "yaccParser/hsparser.y" +{ makeinfix(id_to_string(yyvsp[0].uid),Fixity,Precedence); ; + break;} +case 216: +#line 994 "yaccParser/hsparser.y" +{ makeinfix(id_to_string(yyvsp[0].uid),Fixity,Precedence); ; + break;} +case 218: +#line 999 "yaccParser/hsparser.y" +{ + if(yyvsp[-2].ubinding != NULL) + if(yyvsp[0].ubinding != NULL) + if(SAMEFN) + { + extendfn(yyvsp[-2].ubinding,yyvsp[0].ubinding); + yyval.ubinding = yyvsp[-2].ubinding; + } + else + yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); + else + yyval.ubinding = yyvsp[-2].ubinding; + else + yyval.ubinding = yyvsp[0].ubinding; + SAMEFN = 0; + ; + break;} +case 219: +#line 1017 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 220: +#line 1018 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 221: +#line 1019 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 222: +#line 1020 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 223: +#line 1021 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 224: +#line 1022 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 225: +#line 1025 "yaccParser/hsparser.y" +{ yyval.ubinding = mknbind(yyvsp[-2].uttype,yyvsp[0].uttype,startlineno,mkno_pragma()); ; + break;} +case 226: +#line 1030 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(yyvsp[-4].ulist,yyvsp[-2].uttype,yyvsp[0].ulist,all,startlineno,mkno_pragma()); ; + break;} +case 227: +#line 1032 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(Lnil,yyvsp[-2].uttype,yyvsp[0].ulist,all,startlineno,mkno_pragma()); ; + break;} +case 228: +#line 1034 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(yyvsp[-6].ulist,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ; + break;} +case 229: +#line 1036 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(Lnil,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ; + break;} +case 230: +#line 1039 "yaccParser/hsparser.y" +{ yyval.ubinding = mkcbind(yyvsp[-3].ulist,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ; + break;} +case 231: +#line 1040 "yaccParser/hsparser.y" +{ yyval.ubinding = mkcbind(Lnil,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ; + break;} +case 232: +#line 1043 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); ; + break;} +case 233: +#line 1044 "yaccParser/hsparser.y" +{ checkorder(yyvsp[-1].ubinding); yyval.ubinding = yyvsp[-1].ubinding; ; + break;} +case 234: +#line 1045 "yaccParser/hsparser.y" +{ checkorder(yyvsp[-1].ubinding); yyval.ubinding =yyvsp[-1].ubinding; ; + break;} +case 235: +#line 1048 "yaccParser/hsparser.y" +{ yyval.ubinding = mkibind(yyvsp[-4].ulist,yyvsp[-2].uid,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ; + break;} +case 236: +#line 1049 "yaccParser/hsparser.y" +{ yyval.ubinding = mkibind(Lnil,yyvsp[-2].uid,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ; + break;} +case 237: +#line 1052 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); ; + break;} +case 238: +#line 1053 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[-1].ubinding; ; + break;} +case 239: +#line 1054 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[-1].ubinding; ; + break;} +case 240: +#line 1057 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ; + break;} +case 241: +#line 1058 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[-1].uttype; ; + break;} +case 242: +#line 1060 "yaccParser/hsparser.y" +{ yyval.uttype = mkttuple(yyvsp[-1].ulist); ; + break;} +case 243: +#line 1061 "yaccParser/hsparser.y" +{ yyval.uttype = mkttuple(Lnil); ; + break;} +case 244: +#line 1062 "yaccParser/hsparser.y" +{ yyval.uttype = mktllist(yyvsp[-1].uttype); ; + break;} +case 245: +#line 1063 "yaccParser/hsparser.y" +{ yyval.uttype = mktfun(yyvsp[-3].uttype,yyvsp[-1].uttype); ; + break;} +case 246: +#line 1066 "yaccParser/hsparser.y" +{ yyval.ubinding = mkdbind(yyvsp[0].ulist,startlineno); ; + break;} +case 247: +#line 1069 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-3].uttype,yyvsp[-1].ulist); ; + break;} +case 248: +#line 1070 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 250: +#line 1079 "yaccParser/hsparser.y" +{ + if(SAMEFN) + { + extendfn(yyvsp[-2].ubinding,yyvsp[0].ubinding); + yyval.ubinding = yyvsp[-2].ubinding; + } + else + yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); + ; + break;} +case 251: +#line 1108 "yaccParser/hsparser.y" +{ /* type2context.c for code */ + yyval.ubinding = mksbind(yyvsp[-5].ulist,mkcontext(type2context(yyvsp[-3].uttype),yyvsp[-1].uttype),startlineno,yyvsp[0].uhpragma); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 252: +#line 1113 "yaccParser/hsparser.y" +{ + yyval.ubinding = mksbind(yyvsp[-3].ulist,yyvsp[-1].uttype,startlineno,yyvsp[0].uhpragma); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 253: +#line 1126 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkvspec_uprag(yyvsp[-3].uid, yyvsp[-1].ulist, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 254: +#line 1132 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkispec_uprag(yyvsp[-2].uid, yyvsp[-1].uttype, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 255: +#line 1138 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkdspec_uprag(yyvsp[-2].uid, yyvsp[-1].ulist, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 256: +#line 1144 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkinline_uprag(yyvsp[-2].uid, yyvsp[-1].ulist, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 257: +#line 1150 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkmagicuf_uprag(yyvsp[-2].uid, yyvsp[-1].uid, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 258: +#line 1156 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkdeforest_uprag(yyvsp[-1].uid, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 259: +#line 1162 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkabstract_uprag(yyvsp[-1].uid, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 261: +#line 1170 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; ; + break;} +case 262: +#line 1174 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 263: +#line 1175 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 264: +#line 1178 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].ubinding); ; + break;} +case 265: +#line 1179 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].ubinding); ; + break;} +case 266: +#line 1183 "yaccParser/hsparser.y" +{ yyval.ubinding = mkvspec_ty_and_id(yyvsp[0].uttype,Lnil); ; + break;} +case 267: +#line 1184 "yaccParser/hsparser.y" +{ yyval.ubinding = mkvspec_ty_and_id(yyvsp[-2].uttype,lsing(yyvsp[0].uid)); ; + break;} +case 268: +#line 1186 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 269: +#line 1187 "yaccParser/hsparser.y" +{ yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); ; + break;} +case 270: +#line 1190 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 271: +#line 1191 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 272: +#line 1192 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 273: +#line 1193 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 274: +#line 1194 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 275: +#line 1195 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); ; + break;} +case 276: +#line 1200 "yaccParser/hsparser.y" +{ yyval.ubinding = mksbind(yyvsp[-5].ulist,mkcontext(type2context(yyvsp[-3].uttype),yyvsp[-1].uttype),startlineno,yyvsp[0].uhpragma); ; + break;} +case 277: +#line 1202 "yaccParser/hsparser.y" +{ yyval.ubinding = mksbind(yyvsp[-3].ulist,yyvsp[-1].uttype,startlineno,yyvsp[0].uhpragma); ; + break;} +case 278: +#line 1206 "yaccParser/hsparser.y" +{ yyval.ubinding = mknbind(yyvsp[-3].uttype,yyvsp[-1].uttype,startlineno,yyvsp[0].uhpragma); ; + break;} +case 279: +#line 1210 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(yyvsp[-3].ulist,yyvsp[-1].uttype,Lnil,Lnil,startlineno,yyvsp[0].uhpragma); ; + break;} +case 280: +#line 1212 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(Lnil,yyvsp[-1].uttype,Lnil,Lnil,startlineno,yyvsp[0].uhpragma); ; + break;} +case 281: +#line 1214 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(yyvsp[-5].ulist,yyvsp[-3].uttype,yyvsp[-1].ulist,Lnil,startlineno,yyvsp[0].uhpragma); ; + break;} +case 282: +#line 1216 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(Lnil,yyvsp[-3].uttype,yyvsp[-1].ulist,Lnil,startlineno,yyvsp[0].uhpragma); ; + break;} +case 283: +#line 1218 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(yyvsp[-6].ulist,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ; + break;} +case 284: +#line 1220 "yaccParser/hsparser.y" +{ yyval.ubinding = mktbind(Lnil,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ; + break;} +case 285: +#line 1224 "yaccParser/hsparser.y" +{ yyval.ubinding = mkcbind(yyvsp[-4].ulist,yyvsp[-2].uttype,yyvsp[0].ubinding,startlineno,yyvsp[-1].uhpragma); ; + break;} +case 286: +#line 1226 "yaccParser/hsparser.y" +{ yyval.ubinding = mkcbind(Lnil,yyvsp[-2].uttype,yyvsp[0].ubinding,startlineno,yyvsp[-1].uhpragma); ; + break;} +case 287: +#line 1230 "yaccParser/hsparser.y" +{ yyval.ubinding = mkibind(yyvsp[-4].ulist,yyvsp[-2].uid,yyvsp[-1].uttype,mknullbind(),startlineno,yyvsp[0].uhpragma); ; + break;} +case 288: +#line 1232 "yaccParser/hsparser.y" +{ yyval.ubinding = mkibind(Lnil,yyvsp[-2].uid,yyvsp[-1].uttype,mknullbind(),startlineno,yyvsp[0].uhpragma); ; + break;} +case 289: +#line 1238 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[-1].uid,lsing(yyvsp[0].uttype)); ; + break;} +case 290: +#line 1242 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 291: +#line 1243 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uttype); ; + break;} +case 292: +#line 1246 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[0].uttype; ; + break;} +case 293: +#line 1247 "yaccParser/hsparser.y" +{ yyval.uttype = mktfun(yyvsp[-2].uttype,yyvsp[0].uttype); ; + break;} +case 294: +#line 1250 "yaccParser/hsparser.y" +{ yyval.uttype = mkuniforall(yyvsp[-2].ulist, yyvsp[0].uttype); ; + break;} +case 295: +#line 1252 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[0].uttype; ; + break;} +case 296: +#line 1253 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ; + break;} +case 297: +#line 1256 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist,yyvsp[0].uttype); ; + break;} +case 298: +#line 1257 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 299: +#line 1261 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[0].uttype; ; + break;} +case 300: +#line 1262 "yaccParser/hsparser.y" +{ yyval.uttype = mktfun(yyvsp[-2].uttype,yyvsp[0].uttype); ; + break;} +case 301: +#line 1263 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ; + break;} +case 303: +#line 1267 "yaccParser/hsparser.y" +{ yyval.uttype = mkttuple(mklcons(yyvsp[-3].uttype,yyvsp[-1].ulist)); ; + break;} +case 304: +#line 1270 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[0].uttype; ; + break;} +case 305: +#line 1271 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ; + break;} +case 306: +#line 1272 "yaccParser/hsparser.y" +{ yyval.uttype = mkttuple(Lnil); ; + break;} +case 307: +#line 1273 "yaccParser/hsparser.y" +{ yyval.uttype = yyvsp[-1].uttype; ; + break;} +case 308: +#line 1274 "yaccParser/hsparser.y" +{ yyval.uttype = mktllist(yyvsp[-1].uttype); ; + break;} +case 309: +#line 1277 "yaccParser/hsparser.y" +{ yyval.uttype = mkunidict(yyvsp[-3].uid, yyvsp[-2].uttype); ; + break;} +case 310: +#line 1278 "yaccParser/hsparser.y" +{ yyval.uttype = mkunityvartemplate(yyvsp[0].uid); ; + break;} +case 311: +#line 1282 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ; + break;} +case 312: +#line 1283 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ; + break;} +case 313: +#line 1287 "yaccParser/hsparser.y" +{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ; + break;} +case 314: +#line 1293 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uatype); ; + break;} +case 315: +#line 1294 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uatype); ; + break;} +case 316: +#line 1298 "yaccParser/hsparser.y" +{ yyval.uatype = mkatc(yyvsp[-1].uid,yyvsp[0].ulist,hsplineno); ; + break;} +case 317: +#line 1299 "yaccParser/hsparser.y" +{ yyval.uatype = mkatc(yyvsp[-2].uid,yyvsp[0].ulist,hsplineno); ; + break;} +case 318: +#line 1300 "yaccParser/hsparser.y" +{ yyval.uatype = mkatc(yyvsp[0].uid,Lnil,hsplineno); ; + break;} +case 319: +#line 1301 "yaccParser/hsparser.y" +{ yyval.uatype = mkatc(yyvsp[-1].uid,Lnil,hsplineno); ; + break;} +case 320: +#line 1302 "yaccParser/hsparser.y" +{ yyval.uatype = mkatc(yyvsp[-1].uid, ldub(yyvsp[-2].uttype,yyvsp[0].uttype),hsplineno); ; + break;} +case 321: +#line 1305 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 322: +#line 1306 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 323: +#line 1307 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 324: +#line 1310 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 325: +#line 1311 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uid); ; + break;} +case 326: +#line 1314 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[-1].ulist; ; + break;} +case 327: +#line 1315 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 328: +#line 1318 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 329: +#line 1319 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uttype); ; + break;} +case 330: +#line 1322 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); ; + break;} +case 331: +#line 1323 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[0].ubinding; ; + break;} +case 332: +#line 1325 "yaccParser/hsparser.y" +{ + if(SAMEFN) + { + extendfn(yyvsp[-2].ubinding,yyvsp[0].ubinding); + yyval.ubinding = yyvsp[-2].ubinding; + } + else + yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); + ; + break;} +case 333: +#line 1339 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkinline_uprag(yyvsp[-2].uid, yyvsp[-1].ulist, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 334: +#line 1345 "yaccParser/hsparser.y" +{ + yyval.ubinding = mkmagicuf_uprag(yyvsp[-2].uid, yyvsp[-1].uid, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + ; + break;} +case 336: +#line 1354 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-2].uid,yyvsp[0].ulist); ; + break;} +case 337: +#line 1355 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 338: +#line 1359 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 339: +#line 1360 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uid); ; + break;} +case 340: +#line 1363 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uid); ; + break;} +case 341: +#line 1364 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uid); ; + break;} +case 342: +#line 1369 "yaccParser/hsparser.y" +{ + tree fn = function(yyvsp[0].utree); + + PREVPATT = yyvsp[0].utree; + + if(ttree(fn) == ident) + { + checksamefn(gident((struct Sident *) fn)); + FN = fn; + } + + else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident) + { + checksamefn(gident((struct Sident *) (ginfun((struct Sap *) fn)))); + FN = ginfun((struct Sap *) fn); + } + + else if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tvaldef\n",startlineno); +#endif + ; + break;} +case 343: +#line 1394 "yaccParser/hsparser.y" +{ + if ( lhs_is_patt(yyvsp[-2].utree) ) + { + yyval.ubinding = mkpbind(yyvsp[0].ulist, startlineno); + FN = NULL; + SAMEFN = 0; + } + else /* lhs is function */ + yyval.ubinding = mkfbind(yyvsp[0].ulist,startlineno); + + PREVPATT = NULL; + ; + break;} +case 344: +#line 1408 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(createpat(yyvsp[-1].ulist, yyvsp[0].ubinding)); ; + break;} +case 346: +#line 1412 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(mktruecase(yyvsp[0].utree)); ; + break;} +case 347: +#line 1415 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(ldub(yyvsp[-2].utree,yyvsp[0].utree)); ; + break;} +case 348: +#line 1416 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(ldub(yyvsp[-3].utree,yyvsp[-1].utree),yyvsp[0].ulist); ; + break;} +case 349: +#line 1420 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[-1].ubinding; ; + break;} +case 350: +#line 1421 "yaccParser/hsparser.y" +{ yyval.ubinding = yyvsp[-1].ubinding; ; + break;} +case 351: +#line 1422 "yaccParser/hsparser.y" +{ yyval.ubinding = mknullbind(); ; + break;} +case 352: +#line 1425 "yaccParser/hsparser.y" +{ yyval.utree = yyvsp[0].utree; ; + break;} +case 353: +#line 1429 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-1].utree,yyvsp[0].ulist); ; + break;} +case 354: +#line 1430 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].utree); ; + break;} +case 355: +#line 1439 "yaccParser/hsparser.y" +{ yyval.utree = mkrestr(yyvsp[-4].utree,mkcontext(type2context(yyvsp[-2].uttype),yyvsp[0].uttype)); ; + break;} +case 356: +#line 1440 "yaccParser/hsparser.y" +{ yyval.utree = mkrestr(yyvsp[-2].utree,yyvsp[0].uttype); ; + break;} +case 359: +#line 1452 "yaccParser/hsparser.y" +{ yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree); precparse(yyval.utree); ; + break;} +case 360: +#line 1461 "yaccParser/hsparser.y" +{ yyval.utree = mknegate(yyvsp[0].utree); ; + break;} +case 362: +#line 1470 "yaccParser/hsparser.y" +{ /* enteriscope(); /? I don't understand this -- KH */ + hsincindent(); /* added by partain; push new context for */ + /* FN = NULL; not actually concerned about */ + FN = NULL; /* indenting */ + yyval.uint = hsplineno; /* remember current line number */ + ; + break;} +case 363: +#line 1477 "yaccParser/hsparser.y" +{ hsendindent(); /* added by partain */ + /* exitiscope(); /? Also not understood */ + ; + break;} +case 364: +#line 1481 "yaccParser/hsparser.y" +{ + yyval.utree = mklambda(yyvsp[-3].ulist, yyvsp[0].utree, yyvsp[-4].uint); + ; + break;} +case 365: +#line 1486 "yaccParser/hsparser.y" +{ yyval.utree = mklet(yyvsp[-3].ubinding,yyvsp[0].utree); ; + break;} +case 366: +#line 1487 "yaccParser/hsparser.y" +{ yyval.utree = mklet(yyvsp[-3].ubinding,yyvsp[0].utree); ; + break;} +case 367: +#line 1490 "yaccParser/hsparser.y" +{ yyval.utree = mkife(yyvsp[-4].utree,yyvsp[-2].utree,yyvsp[0].utree); ; + break;} +case 368: +#line 1493 "yaccParser/hsparser.y" +{ yyval.utree = mkcasee(yyvsp[-4].utree,yyvsp[-1].ulist); ; + break;} +case 369: +#line 1494 "yaccParser/hsparser.y" +{ yyval.utree = mkcasee(yyvsp[-4].utree,yyvsp[-1].ulist); ; + break;} +case 370: +#line 1497 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[-1].uid,installid("n"),yyvsp[0].ulist); ; + break;} +case 371: +#line 1498 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[0].uid,installid("n"),Lnil); ; + break;} +case 372: +#line 1499 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[-1].uid,installid("p"),yyvsp[0].ulist); ; + break;} +case 373: +#line 1500 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[0].uid,installid("p"),Lnil); ; + break;} +case 374: +#line 1501 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[-1].ustring,installid("N"),yyvsp[0].ulist); ; + break;} +case 375: +#line 1502 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[0].ustring,installid("N"),Lnil); ; + break;} +case 376: +#line 1503 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[-1].ustring,installid("P"),yyvsp[0].ulist); ; + break;} +case 377: +#line 1504 "yaccParser/hsparser.y" +{ yyval.utree = mkccall(yyvsp[0].ustring,installid("P"),Lnil); ; + break;} +case 378: +#line 1508 "yaccParser/hsparser.y" +{ extern BOOLEAN ignoreSCC; + extern BOOLEAN warnSCC; + + if (ignoreSCC) { + if (warnSCC) + fprintf(stderr, + "\"%s\", line %d: _scc_ (`set [profiling] cost centre') ignored\n", + input_filename, hsplineno); + yyval.utree = yyvsp[0].utree; + } else { + yyval.utree = mkscc(yyvsp[-1].uhstring, yyvsp[0].utree); + } + ; + break;} +case 380: +#line 1526 "yaccParser/hsparser.y" +{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ; + break;} +case 382: +#line 1530 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist,yyvsp[0].utree); ; + break;} +case 383: +#line 1531 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].utree); ; + break;} +case 384: +#line 1541 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 385: +#line 1542 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 386: +#line 1543 "yaccParser/hsparser.y" +{ yyval.utree = mklit(yyvsp[0].uliteral); ; + break;} +case 387: +#line 1544 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[-1].utree); ; + break;} +case 388: +#line 1545 "yaccParser/hsparser.y" +{ checkprec(yyvsp[-2].utree,yyvsp[-1].uid,FALSE); yyval.utree = mklsection(yyvsp[-2].utree,yyvsp[-1].uid); ; + break;} +case 389: +#line 1546 "yaccParser/hsparser.y" +{ checkprec(yyvsp[-1].utree,yyvsp[-2].uid,TRUE); yyval.utree = mkrsection(yyvsp[-2].uid,yyvsp[-1].utree); ; + break;} +case 391: +#line 1550 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[0].utree); ; + break;} +case 392: +#line 1551 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[0].utree); ; + break;} +case 393: +#line 1552 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[0].utree); ; + break;} +case 394: +#line 1555 "yaccParser/hsparser.y" +{ checkinpat(); yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ; + break;} +case 395: +#line 1556 "yaccParser/hsparser.y" +{ checkinpat(); yyval.utree = mkwildp(); ; + break;} +case 396: +#line 1557 "yaccParser/hsparser.y" +{ checkinpat(); yyval.utree = mklazyp(yyvsp[0].utree); ; + break;} +case 398: +#line 1592 "yaccParser/hsparser.y" +{ + yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree); + + if(isconstr(id_to_string(yyvsp[-1].uid))) + precparse(yyval.utree); + else + { + checkprec(yyvsp[-2].utree,yyvsp[-1].uid,FALSE); /* Check the precedence of the left pattern */ + checkprec(yyvsp[0].utree,yyvsp[-1].uid,TRUE); /* then check the right pattern */ + } + ; + break;} +case 400: +#line 1607 "yaccParser/hsparser.y" +{ + yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree); + + if(isconstr(id_to_string(yyvsp[-1].uid))) + precparse(yyval.utree); + else + { + checkprec(yyvsp[-2].utree,yyvsp[-1].uid,FALSE); /* Check the precedence of the left pattern */ + checkprec(yyvsp[0].utree,yyvsp[-1].uid,TRUE); /* then check the right pattern */ + } + ; + break;} +case 401: +#line 1626 "yaccParser/hsparser.y" +{ yyval.utree = mknegate(yyvsp[0].utree); ; + break;} +case 403: +#line 1631 "yaccParser/hsparser.y" +{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ; + break;} +case 405: +#line 1635 "yaccParser/hsparser.y" +{ yyval.utree = mknegate(yyvsp[0].utree); ; + break;} +case 407: +#line 1640 "yaccParser/hsparser.y" +{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ; + break;} +case 409: +#line 1644 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 410: +#line 1645 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 411: +#line 1646 "yaccParser/hsparser.y" +{ yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ; + break;} +case 412: +#line 1647 "yaccParser/hsparser.y" +{ yyval.utree = mklit(yyvsp[0].uliteral); ; + break;} +case 413: +#line 1648 "yaccParser/hsparser.y" +{ yyval.utree = mkwildp(); ; + break;} +case 414: +#line 1649 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(Lnil); ; + break;} +case 415: +#line 1650 "yaccParser/hsparser.y" +{ yyval.utree = mkplusp(mkident(yyvsp[-3].uid),mkinteger(yyvsp[-1].ustring)); ; + break;} +case 416: +#line 1654 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[-1].utree); ; + break;} +case 417: +#line 1655 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(mklcons(yyvsp[-3].utree,yyvsp[-1].ulist)); ; + break;} +case 418: +#line 1656 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(yyvsp[-1].ulist); ; + break;} +case 419: +#line 1657 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(Lnil); ; + break;} +case 420: +#line 1658 "yaccParser/hsparser.y" +{ yyval.utree = mklazyp(yyvsp[0].utree); ; + break;} +case 421: +#line 1661 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 422: +#line 1662 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 423: +#line 1663 "yaccParser/hsparser.y" +{ yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ; + break;} +case 424: +#line 1664 "yaccParser/hsparser.y" +{ yyval.utree = mklit(yyvsp[0].uliteral); setstartlineno(); ; + break;} +case 425: +#line 1665 "yaccParser/hsparser.y" +{ yyval.utree = mkwildp(); setstartlineno(); ; + break;} +case 426: +#line 1666 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(Lnil); ; + break;} +case 427: +#line 1667 "yaccParser/hsparser.y" +{ yyval.utree = mkplusp(mkident(yyvsp[-3].uid),mkinteger(yyvsp[-1].ustring)); ; + break;} +case 428: +#line 1671 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[-1].utree); ; + break;} +case 429: +#line 1672 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(mklcons(yyvsp[-3].utree,yyvsp[-1].ulist)); ; + break;} +case 430: +#line 1673 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(yyvsp[-1].ulist); ; + break;} +case 431: +#line 1674 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(Lnil); ; + break;} +case 432: +#line 1675 "yaccParser/hsparser.y" +{ yyval.utree = mklazyp(yyvsp[0].utree); ; + break;} +case 433: +#line 1686 "yaccParser/hsparser.y" +{ if (ttree(yyvsp[-1].utree) == tuple) + yyval.utree = mktuple(mklcons(yyvsp[-3].utree, gtuplelist((struct Stuple *) yyvsp[-1].utree))); + else + yyval.utree = mktuple(ldub(yyvsp[-3].utree, yyvsp[-1].utree)); + ; + break;} +case 434: +#line 1692 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(Lnil); ; + break;} +case 435: +#line 1695 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[0].utree); ; + break;} +case 436: +#line 1697 "yaccParser/hsparser.y" +{ if (ttree(yyvsp[0].utree) == tuple) + yyval.utree = mktuple(mklcons(yyvsp[-2].utree, gtuplelist((struct Stuple *) yyvsp[0].utree))); + else + yyval.utree = mktuple(ldub(yyvsp[-2].utree, yyvsp[0].utree)); + ; + break;} +case 437: +#line 1706 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(Lnil); ; + break;} +case 438: +#line 1707 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(yyvsp[-1].ulist); ; + break;} +case 439: +#line 1711 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].utree); ; + break;} +case 440: +#line 1712 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-2].utree, yyvsp[0].ulist); ; + break;} +case 441: +#line 1727 "yaccParser/hsparser.y" +{yyval.utree = mkeenum(yyvsp[-5].utree,lsing(yyvsp[-3].utree),yyvsp[-1].ulist);; + break;} +case 442: +#line 1728 "yaccParser/hsparser.y" +{ yyval.utree = mkeenum(yyvsp[-3].utree,Lnil,yyvsp[-1].ulist); ; + break;} +case 443: +#line 1731 "yaccParser/hsparser.y" +{ yyval.utree = mkcomprh(yyvsp[-3].utree,yyvsp[-1].ulist); ; + break;} +case 444: +#line 1734 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].utree); ; + break;} +case 445: +#line 1735 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].utree); ; + break;} +case 446: +#line 1738 "yaccParser/hsparser.y" +{ inpat = TRUE; ; + break;} +case 447: +#line 1738 "yaccParser/hsparser.y" +{ inpat = FALSE; ; + break;} +case 448: +#line 1739 "yaccParser/hsparser.y" +{ if (yyvsp[0].utree == NULL) + yyval.utree = mkguard(yyvsp[-2].utree); + else + { + checkpatt(yyvsp[-2].utree); + if(ttree(yyvsp[0].utree)==def) + { + tree prevpatt_save = PREVPATT; + PREVPATT = yyvsp[-2].utree; + yyval.utree = mkdef((tree) mkpbind(lsing(createpat(lsing(mktruecase(ggdef((struct Sdef *) yyvsp[0].utree))),mknullbind())),hsplineno)); + PREVPATT = prevpatt_save; + } + else + yyval.utree = mkqual(yyvsp[-2].utree,yyvsp[0].utree); + } + ; + break;} +case 449: +#line 1757 "yaccParser/hsparser.y" +{ yyval.utree = yyvsp[0].utree; ; + break;} +case 450: +#line 1758 "yaccParser/hsparser.y" +{ yyval.utree = NULL; ; + break;} +case 451: +#line 1761 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; ; + break;} +case 452: +#line 1762 "yaccParser/hsparser.y" +{ yyval.ulist = lconc(yyvsp[-2].ulist,yyvsp[0].ulist); ; + break;} +case 453: +#line 1766 "yaccParser/hsparser.y" +{ PREVPATT = yyvsp[0].utree; ; + break;} +case 454: +#line 1768 "yaccParser/hsparser.y" +{ yyval.ulist = yyvsp[0].ulist; + PREVPATT = NULL; + ; + break;} +case 455: +#line 1771 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 456: +#line 1774 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(createpat(yyvsp[-1].ulist, yyvsp[0].ubinding)); ; + break;} +case 457: +#line 1775 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(createpat(lsing(mktruecase(yyvsp[-1].utree)), yyvsp[0].ubinding)); ; + break;} +case 458: +#line 1778 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(ldub(yyvsp[-3].utree,yyvsp[-1].utree),yyvsp[0].ulist); ; + break;} +case 459: +#line 1779 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(ldub(yyvsp[-2].utree,yyvsp[0].utree)); ; + break;} +case 460: +#line 1782 "yaccParser/hsparser.y" +{ yyval.ulist = Lnil; ; + break;} +case 461: +#line 1783 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].utree); ; + break;} +case 462: +#line 1786 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-2].utree, yyvsp[0].ulist); ; + break;} +case 463: +#line 1787 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].utree); ; + break;} +case 465: +#line 1792 "yaccParser/hsparser.y" +{ yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree); precparse(yyval.utree); ; + break;} +case 468: +#line 1797 "yaccParser/hsparser.y" +{ yyval.utree = mklit(mkinteger(ineg(yyvsp[0].ustring))); ; + break;} +case 469: +#line 1798 "yaccParser/hsparser.y" +{ yyval.utree = mklit(mkfloatr(ineg(yyvsp[0].ustring))); ; + break;} +case 470: +#line 1801 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 471: +#line 1802 "yaccParser/hsparser.y" +{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ; + break;} +case 472: +#line 1805 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 474: +#line 1809 "yaccParser/hsparser.y" +{ yyval.utree = mkident(yyvsp[0].uid); ; + break;} +case 475: +#line 1810 "yaccParser/hsparser.y" +{ yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ; + break;} +case 476: +#line 1811 "yaccParser/hsparser.y" +{ yyval.utree = mklit(yyvsp[0].uliteral); ; + break;} +case 477: +#line 1812 "yaccParser/hsparser.y" +{ yyval.utree = mkwildp(); ; + break;} +case 478: +#line 1813 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(Lnil); ; + break;} +case 479: +#line 1814 "yaccParser/hsparser.y" +{ yyval.utree = mkplusp(mkident(yyvsp[-3].uid),mkinteger(yyvsp[-1].ustring)); ; + break;} +case 480: +#line 1818 "yaccParser/hsparser.y" +{ yyval.utree = mkpar(yyvsp[-1].utree); ; + break;} +case 481: +#line 1819 "yaccParser/hsparser.y" +{ yyval.utree = mktuple(mklcons(yyvsp[-3].utree,yyvsp[-1].ulist)); ; + break;} +case 482: +#line 1820 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(yyvsp[-1].ulist); ; + break;} +case 483: +#line 1821 "yaccParser/hsparser.y" +{ yyval.utree = mkllist(Lnil); ; + break;} +case 484: +#line 1822 "yaccParser/hsparser.y" +{ yyval.utree = mklazyp(yyvsp[0].utree); ; + break;} +case 485: +#line 1826 "yaccParser/hsparser.y" +{ yyval.uliteral = mkinteger(yyvsp[0].ustring); ; + break;} +case 486: +#line 1827 "yaccParser/hsparser.y" +{ yyval.uliteral = mkfloatr(yyvsp[0].ustring); ; + break;} +case 487: +#line 1828 "yaccParser/hsparser.y" +{ yyval.uliteral = mkcharr(yyvsp[0].uhstring); ; + break;} +case 488: +#line 1829 "yaccParser/hsparser.y" +{ yyval.uliteral = mkstring(yyvsp[0].uhstring); ; + break;} +case 489: +#line 1830 "yaccParser/hsparser.y" +{ yyval.uliteral = mkcharprim(yyvsp[0].uhstring); ; + break;} +case 490: +#line 1831 "yaccParser/hsparser.y" +{ yyval.uliteral = mkstringprim(yyvsp[0].uhstring); ; + break;} +case 491: +#line 1832 "yaccParser/hsparser.y" +{ yyval.uliteral = mkintprim(yyvsp[0].ustring); ; + break;} +case 492: +#line 1833 "yaccParser/hsparser.y" +{ yyval.uliteral = mkfloatprim(yyvsp[0].ustring); ; + break;} +case 493: +#line 1834 "yaccParser/hsparser.y" +{ yyval.uliteral = mkdoubleprim(yyvsp[0].ustring); ; + break;} +case 494: +#line 1835 "yaccParser/hsparser.y" +{ yyval.uliteral = mkclitlit(yyvsp[0].ustring, ""); ; + break;} +case 495: +#line 1836 "yaccParser/hsparser.y" +{ yyval.uliteral = mkclitlit(yyvsp[-2].ustring, yyvsp[0].uid); ; + break;} +case 496: +#line 1837 "yaccParser/hsparser.y" +{ yyval.uliteral = mknorepi(yyvsp[0].ustring); ; + break;} +case 497: +#line 1838 "yaccParser/hsparser.y" +{ yyval.uliteral = mknorepr(yyvsp[-1].ustring, yyvsp[0].ustring); ; + break;} +case 498: +#line 1839 "yaccParser/hsparser.y" +{ yyval.uliteral = mknoreps(yyvsp[0].uhstring); ; + break;} +case 499: +#line 1845 "yaccParser/hsparser.y" +{ setstartlineno(); ; + break;} +case 500: +#line 1848 "yaccParser/hsparser.y" +{ setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tdata\n",startlineno); +#endif + ; + break;} +case 501: +#line 1858 "yaccParser/hsparser.y" +{ setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\ttype\n",startlineno); +#endif + ; + break;} +case 502: +#line 1868 "yaccParser/hsparser.y" +{ setstartlineno(); +#if 1/*etags*/ +/* OUT: if(etags) + printf("%u\n",startlineno); +*/ +#else + fprintf(stderr,"%u\tinstance\n",startlineno); +#endif + ; + break;} +case 503: +#line 1879 "yaccParser/hsparser.y" +{ setstartlineno(); ; + break;} +case 504: +#line 1882 "yaccParser/hsparser.y" +{ setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tclass\n",startlineno); +#endif + ; + break;} +case 505: +#line 1892 "yaccParser/hsparser.y" +{ setstartlineno(); ; + break;} +case 506: +#line 1895 "yaccParser/hsparser.y" +{ setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tmodule\n",startlineno); +#endif + ; + break;} +case 507: +#line 1905 "yaccParser/hsparser.y" +{ setstartlineno(); ; + break;} +case 508: +#line 1908 "yaccParser/hsparser.y" +{ setstartlineno(); ; + break;} +case 509: +#line 1911 "yaccParser/hsparser.y" +{ setstartlineno(); ; + break;} +case 515: +#line 1926 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 518: +#line 1932 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 520: +#line 1936 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 524: +#line 1944 "yaccParser/hsparser.y" +{ yyval.uid = install_literal("-"); ; + break;} +case 525: +#line 1947 "yaccParser/hsparser.y" +{ yyval.uid = install_literal("+"); ; + break;} +case 527: +#line 1951 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 528: +#line 1954 "yaccParser/hsparser.y" +{ setstartlineno(); yyval.uid = yyvsp[0].uid; ; + break;} +case 529: +#line 1955 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 531: +#line 1960 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 532: +#line 1963 "yaccParser/hsparser.y" +{ setstartlineno(); yyval.uid = yyvsp[0].uid; ; + break;} +case 533: +#line 1964 "yaccParser/hsparser.y" +{ yyval.uid = yyvsp[-1].uid; ; + break;} +case 536: +#line 1972 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-2].uttype,lsing(yyvsp[0].uttype)); ; + break;} +case 537: +#line 1973 "yaccParser/hsparser.y" +{ yyval.ulist = mklcons(yyvsp[-2].uttype,yyvsp[0].ulist); ; + break;} +case 538: +#line 1977 "yaccParser/hsparser.y" +{ yyval.ulist = lsing(yyvsp[0].uttype); ; + break;} +case 539: +#line 1978 "yaccParser/hsparser.y" +{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].uttype); ; + break;} +case 540: +#line 1981 "yaccParser/hsparser.y" +{ yyval.uttype = mknamedtvar(yyvsp[0].uid); ; + break;} +case 544: +#line 1997 "yaccParser/hsparser.y" +{ hsincindent(); ; + break;} +case 545: +#line 1999 "yaccParser/hsparser.y" +{ hssetindent(); ; + break;} +case 546: +#line 2002 "yaccParser/hsparser.y" +{ hsindentoff(); ; + break;} +case 547: +#line 2007 "yaccParser/hsparser.y" +{ + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + ; + break;} +case 548: +#line 2013 "yaccParser/hsparser.y" +{ expect_ccurly = 1; ; + break;} +case 549: +#line 2013 "yaccParser/hsparser.y" +{ expect_ccurly = 0; ; + break;} +case 550: +#line 2018 "yaccParser/hsparser.y" +{ + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + ; + break;} +case 551: +#line 2023 "yaccParser/hsparser.y" +{ + yyerrok; + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + ; + break;} +} + /* the action file gets copied in in place of this dollarsign */ +#line 457 "/usr/local/gnu/lib/bison.simple" + + yyvsp -= yylen; + yyssp -= yylen; +#ifdef YYLSP_NEEDED + yylsp -= yylen; +#endif + +#if YYDEBUG != 0 + if (yydebug) + { + short *ssp1 = yyss - 1; + fprintf (stderr, "state stack now"); + while (ssp1 != yyssp) + fprintf (stderr, " %d", *++ssp1); + fprintf (stderr, "\n"); + } +#endif + + *++yyvsp = yyval; + +#ifdef YYLSP_NEEDED + yylsp++; + if (yylen == 0) + { + yylsp->first_line = yylloc.first_line; + yylsp->first_column = yylloc.first_column; + yylsp->last_line = (yylsp-1)->last_line; + yylsp->last_column = (yylsp-1)->last_column; + yylsp->text = 0; + } + else + { + yylsp->last_line = (yylsp+yylen-1)->last_line; + yylsp->last_column = (yylsp+yylen-1)->last_column; + } +#endif + + /* Now "shift" the result of the reduction. + Determine what state that goes to, + based on the state we popped back to + and the rule number reduced by. */ + + yyn = yyr1[yyn]; + + yystate = yypgoto[yyn - YYNTBASE] + *yyssp; + if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp) + yystate = yytable[yystate]; + else + yystate = yydefgoto[yyn - YYNTBASE]; + + goto yynewstate; + +yyerrlab: /* here on detecting error */ + + if (! yyerrstatus) + /* If not already recovering from an error, report this error. */ + { + ++yynerrs; + +#ifdef YYERROR_VERBOSE + yyn = yypact[yystate]; + + if (yyn > YYFLAG && yyn < YYLAST) + { + int size = 0; + char *msg; + int x, count; + + count = 0; + /* Start X at -yyn if nec to avoid negative indexes in yycheck. */ + for (x = (yyn < 0 ? -yyn : 0); + x < (sizeof(yytname) / sizeof(char *)); x++) + if (yycheck[x + yyn] == x) + size += strlen(yytname[x]) + 15, count++; + msg = (char *) malloc(size + 15); + if (msg != 0) + { + strcpy(msg, "parse error"); + + if (count < 5) + { + count = 0; + for (x = (yyn < 0 ? -yyn : 0); + x < (sizeof(yytname) / sizeof(char *)); x++) + if (yycheck[x + yyn] == x) + { + strcat(msg, count == 0 ? ", expecting `" : " or `"); + strcat(msg, yytname[x]); + strcat(msg, "'"); + count++; + } + } + yyerror(msg); + free(msg); + } + else + yyerror ("parse error; also virtual memory exceeded"); + } + else +#endif /* YYERROR_VERBOSE */ + yyerror("parse error"); + } + + goto yyerrlab1; +yyerrlab1: /* here on error raised explicitly by an action */ + + if (yyerrstatus == 3) + { + /* if just tried and failed to reuse lookahead token after an error, discard it. */ + + /* return failure if at end of input */ + if (yychar == YYEOF) + YYABORT; + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Discarding token %d (%s).\n", yychar, yytname[yychar1]); +#endif + + yychar = YYEMPTY; + } + + /* Else will try to reuse lookahead token + after shifting the error token. */ + + yyerrstatus = 3; /* Each real token shifted decrements this */ + + goto yyerrhandle; + +yyerrdefault: /* current state does not do anything special for the error token. */ + +#if 0 + /* This is wrong; only states that explicitly want error tokens + should shift them. */ + yyn = yydefact[yystate]; /* If its default is to accept any token, ok. Otherwise pop it.*/ + if (yyn) goto yydefault; +#endif + +yyerrpop: /* pop the current state because it cannot handle the error token */ + + if (yyssp == yyss) YYABORT; + yyvsp--; + yystate = *--yyssp; +#ifdef YYLSP_NEEDED + yylsp--; +#endif + +#if YYDEBUG != 0 + if (yydebug) + { + short *ssp1 = yyss - 1; + fprintf (stderr, "Error: state stack now"); + while (ssp1 != yyssp) + fprintf (stderr, " %d", *++ssp1); + fprintf (stderr, "\n"); + } +#endif + +yyerrhandle: + + yyn = yypact[yystate]; + if (yyn == YYFLAG) + goto yyerrdefault; + + yyn += YYTERROR; + if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR) + goto yyerrdefault; + + yyn = yytable[yyn]; + if (yyn < 0) + { + if (yyn == YYFLAG) + goto yyerrpop; + yyn = -yyn; + goto yyreduce; + } + else if (yyn == 0) + goto yyerrpop; + + if (yyn == YYFINAL) + YYACCEPT; + +#if YYDEBUG != 0 + if (yydebug) + fprintf(stderr, "Shifting error token, "); +#endif + + *++yyvsp = yylval; +#ifdef YYLSP_NEEDED + *++yylsp = yylloc; +#endif + + yystate = yyn; + goto yynewstate; +} +#line 2030 "yaccParser/hsparser.y" + + +/********************************************************************** +* * +* Error Processing and Reporting * +* * +* (This stuff is here in case we want to use Yacc macros and such.) * +* * +**********************************************************************/ + +/* The parser calls "hsperror" when it sees a + `report this and die' error. It sets the stage + and calls "yyerror". + + There should be no direct calls in the parser to + "yyerror", except for the one from "hsperror". Thus, + the only other calls will be from the error productions + introduced by yacc/bison/whatever. + + We need to be able to recognise the from-error-production + case, because we sometimes want to say, "Oh, never mind", + because the layout rule kicks into action and may save + the day. [WDP] +*/ + +static BOOLEAN error_and_I_mean_it = FALSE; + +void +hsperror(s) + char *s; +{ + error_and_I_mean_it = TRUE; + yyerror(s); +} + +void +yyerror(s) + char *s; +{ + extern char *yytext; + extern int yyleng; + + /* We want to be able to distinguish 'error'-raised yyerrors + from yyerrors explicitly coded by the parser hacker. + */ + if (expect_ccurly && ! error_and_I_mean_it ) { + /*NOTHING*/; + + } else { + fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ", + input_filename, hsplineno, hspcolno + 1, s); + + if (yyleng == 1 && *yytext == '\0') + fprintf(stderr, ""); + + else { + fputc('"', stderr); + format_string(stderr, (unsigned char *) yytext, yyleng); + fputc('"', stderr); + } + fputc('\n', stderr); + + /* a common problem */ + if (strcmp(yytext, "#") == 0) + fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n"); + + exit(1); + } +} + +void +format_string(fp, s, len) + FILE *fp; + unsigned char *s; + int len; +{ + while (len-- > 0) { + switch (*s) { + case '\0': fputs("\\NUL", fp); break; + case '\007': fputs("\\a", fp); break; + case '\010': fputs("\\b", fp); break; + case '\011': fputs("\\t", fp); break; + case '\012': fputs("\\n", fp); break; + case '\013': fputs("\\v", fp); break; + case '\014': fputs("\\f", fp); break; + case '\015': fputs("\\r", fp); break; + case '\033': fputs("\\ESC", fp); break; + case '\034': fputs("\\FS", fp); break; + case '\035': fputs("\\GS", fp); break; + case '\036': fputs("\\RS", fp); break; + case '\037': fputs("\\US", fp); break; + case '\177': fputs("\\DEL", fp); break; + default: + if (*s >= ' ') + fputc(*s, fp); + else + fprintf(fp, "\\^%c", *s + '@'); + break; + } + s++; + } +} diff --git a/ghc/compiler/yaccParser/hsparser.tab.h b/ghc/compiler/yaccParser/hsparser.tab.h new file mode 100644 index 0000000..15ec07b --- /dev/null +++ b/ghc/compiler/yaccParser/hsparser.tab.h @@ -0,0 +1,138 @@ +typedef union { + tree utree; + list ulist; + ttype uttype; + atype uatype; + binding ubinding; + pbinding upbinding; + finfot ufinfo; + entidt uentid; + id uid; + literal uliteral; + int uint; + float ufloat; + char *ustring; + hstring uhstring; + hpragma uhpragma; + coresyn ucoresyn; +} YYSTYPE; +#define VARID 258 +#define CONID 259 +#define VARSYM 260 +#define CONSYM 261 +#define MINUS 262 +#define INTEGER 263 +#define FLOAT 264 +#define CHAR 265 +#define STRING 266 +#define CHARPRIM 267 +#define STRINGPRIM 268 +#define INTPRIM 269 +#define FLOATPRIM 270 +#define DOUBLEPRIM 271 +#define CLITLIT 272 +#define OCURLY 273 +#define CCURLY 274 +#define VCCURLY 275 +#define SEMI 276 +#define OBRACK 277 +#define CBRACK 278 +#define OPAREN 279 +#define CPAREN 280 +#define COMMA 281 +#define BQUOTE 282 +#define RARROW 283 +#define VBAR 284 +#define EQUAL 285 +#define DARROW 286 +#define DOTDOT 287 +#define DCOLON 288 +#define LARROW 289 +#define WILDCARD 290 +#define AT 291 +#define LAZY 292 +#define LAMBDA 293 +#define LET 294 +#define IN 295 +#define WHERE 296 +#define CASE 297 +#define OF 298 +#define TYPE 299 +#define DATA 300 +#define CLASS 301 +#define INSTANCE 302 +#define DEFAULT 303 +#define INFIX 304 +#define INFIXL 305 +#define INFIXR 306 +#define MODULE 307 +#define IMPORT 308 +#define INTERFACE 309 +#define HIDING 310 +#define CCALL 311 +#define CCALL_GC 312 +#define CASM 313 +#define CASM_GC 314 +#define SCC 315 +#define IF 316 +#define THEN 317 +#define ELSE 318 +#define RENAMING 319 +#define DERIVING 320 +#define TO 321 +#define LEOF 322 +#define GHC_PRAGMA 323 +#define END_PRAGMA 324 +#define NO_PRAGMA 325 +#define NOINFO_PRAGMA 326 +#define ABSTRACT_PRAGMA 327 +#define SPECIALISE_PRAGMA 328 +#define MODNAME_PRAGMA 329 +#define ARITY_PRAGMA 330 +#define UPDATE_PRAGMA 331 +#define STRICTNESS_PRAGMA 332 +#define KIND_PRAGMA 333 +#define UNFOLDING_PRAGMA 334 +#define MAGIC_UNFOLDING_PRAGMA 335 +#define DEFOREST_PRAGMA 336 +#define SPECIALISE_UPRAGMA 337 +#define INLINE_UPRAGMA 338 +#define MAGIC_UNFOLDING_UPRAGMA 339 +#define ABSTRACT_UPRAGMA 340 +#define DEFOREST_UPRAGMA 341 +#define END_UPRAGMA 342 +#define TYLAMBDA 343 +#define COCON 344 +#define COPRIM 345 +#define COAPP 346 +#define COTYAPP 347 +#define FORALL 348 +#define TYVAR_TEMPLATE_ID 349 +#define CO_ALG_ALTS 350 +#define CO_PRIM_ALTS 351 +#define CO_NO_DEFAULT 352 +#define CO_LETREC 353 +#define CO_SDSEL_ID 354 +#define CO_METH_ID 355 +#define CO_DEFM_ID 356 +#define CO_DFUN_ID 357 +#define CO_CONSTM_ID 358 +#define CO_SPEC_ID 359 +#define CO_WRKR_ID 360 +#define CO_ORIG_NM 361 +#define UNFOLD_ALWAYS 362 +#define UNFOLD_IF_ARGS 363 +#define NOREP_INTEGER 364 +#define NOREP_RATIONAL 365 +#define NOREP_STRING 366 +#define CO_PRELUDE_DICTS_CC 367 +#define CO_ALL_DICTS_CC 368 +#define CO_USER_CC 369 +#define CO_AUTO_CC 370 +#define CO_DICT_CC 371 +#define CO_CAF_CC 372 +#define CO_DUPD_CC 373 +#define PLUS 374 + + +extern YYSTYPE yylval; diff --git a/ghc/compiler/yaccParser/hsparser.y b/ghc/compiler/yaccParser/hsparser.y new file mode 100644 index 0000000..fb2d934 --- /dev/null +++ b/ghc/compiler/yaccParser/hsparser.y @@ -0,0 +1,2131 @@ +/************************************************************************** +* File: hsparser.y * +* * +* Author: Maria M. Gutierrez * +* Modified by: Kevin Hammond * +* Last date revised: December 13 1991. KH. * +* Modification: Haskell 1.1 Syntax. * +* * +* * +* Description: This file contains the LALR(1) grammar for Haskell. * +* * +* Entry Point: module * +* * +* Problems: None known. * +* * +* * +* LALR(1) Syntax for Haskell 1.2 * +* * +**************************************************************************/ + + +%{ +#ifdef HSP_DEBUG +# define YYDEBUG 1 +#endif + +#include +#include +#include +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/********************************************************************** +* * +* * +* Imported Variables and Functions * +* * +* * +**********************************************************************/ + +BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */ + +extern BOOLEAN nonstandardFlag; +extern BOOLEAN etags; + +extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *)); + +extern char *input_filename; +static char *the_module_name; +static char iface_name[MODNAME_SIZE]; +static char interface_filename[FILENAME_SIZE]; + +static list module_exports; /* Exported entities */ +static list prelude_core_import, prelude_imports; + /* Entities imported from the Prelude */ + +extern list all; /* All valid deriving classes */ + +extern tree niltree; +extern list Lnil; + +extern tree root; + +/* For FN, PREVPATT and SAMEFN macros */ +extern tree fns[]; +extern short samefn[]; +extern tree prevpatt[]; +extern short icontexts; + +/* Line Numbers */ +extern int hsplineno, hspcolno; +extern int startlineno; + + +/********************************************************************** +* * +* * +* Fixity and Precedence Declarations * +* * +* * +**********************************************************************/ + +list fixlist; +static int Fixity = 0, Precedence = 0; +struct infix; + +char *ineg PROTO((char *)); + +static BOOLEAN hidden = FALSE; /* Set when HIDING used */ + +extern BOOLEAN inpat; /* True when parsing a pattern */ +extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */ +extern BOOLEAN haskell1_3Flag; /* True if we are attempting (proto)Haskell 1.3 */ + +extern int thisIfacePragmaVersion; + +%} + +%union { + tree utree; + list ulist; + ttype uttype; + atype uatype; + binding ubinding; + pbinding upbinding; + finfot ufinfo; + entidt uentid; + id uid; + literal uliteral; + int uint; + float ufloat; + char *ustring; + hstring uhstring; + hpragma uhpragma; + coresyn ucoresyn; +} + + +/********************************************************************** +* * +* * +* These are lexemes. * +* * +* * +**********************************************************************/ + + +%token VARID CONID + VARSYM CONSYM MINUS + +%token INTEGER FLOAT CHAR STRING + CHARPRIM STRINGPRIM INTPRIM FLOATPRIM + DOUBLEPRIM CLITLIT + + + +/********************************************************************** +* * +* * +* Special Symbols * +* * +* * +**********************************************************************/ + +%token OCURLY CCURLY VCCURLY SEMI +%token OBRACK CBRACK OPAREN CPAREN +%token COMMA BQUOTE + + +/********************************************************************** +* * +* * +* Reserved Operators * +* * +* * +**********************************************************************/ + +%token RARROW +%token VBAR EQUAL DARROW DOTDOT +%token DCOLON LARROW +%token WILDCARD AT LAZY LAMBDA + + +/********************************************************************** +* * +* * +* Reserved Identifiers * +* * +* * +**********************************************************************/ + +%token LET IN +%token WHERE CASE OF +%token TYPE DATA CLASS INSTANCE DEFAULT +%token INFIX INFIXL INFIXR +%token MODULE IMPORT INTERFACE HIDING +%token CCALL CCALL_GC CASM CASM_GC SCC + +%token IF THEN ELSE +%token RENAMING DERIVING TO + +/********************************************************************** +* * +* * +* Special Symbols for the Lexer * +* * +* * +**********************************************************************/ + +%token LEOF +%token GHC_PRAGMA END_PRAGMA NO_PRAGMA NOINFO_PRAGMA +%token ABSTRACT_PRAGMA SPECIALISE_PRAGMA MODNAME_PRAGMA +%token ARITY_PRAGMA UPDATE_PRAGMA STRICTNESS_PRAGMA KIND_PRAGMA +%token UNFOLDING_PRAGMA MAGIC_UNFOLDING_PRAGMA DEFOREST_PRAGMA +%token SPECIALISE_UPRAGMA INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA +%token ABSTRACT_UPRAGMA DEFOREST_UPRAGMA END_UPRAGMA +%token TYLAMBDA COCON COPRIM COAPP COTYAPP FORALL TYVAR_TEMPLATE_ID +%token CO_ALG_ALTS CO_PRIM_ALTS CO_NO_DEFAULT CO_LETREC +%token CO_SDSEL_ID CO_METH_ID CO_DEFM_ID CO_DFUN_ID CO_CONSTM_ID +%token CO_SPEC_ID CO_WRKR_ID CO_ORIG_NM +%token UNFOLD_ALWAYS UNFOLD_IF_ARGS +%token NOREP_INTEGER NOREP_RATIONAL NOREP_STRING +%token CO_PRELUDE_DICTS_CC CO_ALL_DICTS_CC CO_USER_CC CO_AUTO_CC CO_DICT_CC +%token CO_CAF_CC CO_DUPD_CC + +/********************************************************************** +* * +* * +* Precedences of the various tokens * +* * +* * +**********************************************************************/ + + +%left CASE LET IN LAMBDA + IF ELSE CCALL CCALL_GC + CASM CASM_GC SCC AT + +%left VARSYM CONSYM PLUS MINUS BQUOTE + +%left DCOLON + +%left SEMI COMMA + +%left OCURLY OBRACK OPAREN + +%left EQUAL + +%right DARROW +%right RARROW + + + +/********************************************************************** +* * +* * +* Type Declarations * +* * +* * +**********************************************************************/ + + +%type alt alts altrest quals vars varsrest cons + tyvars constrs dtypes types atypes + types_and_maybe_ids + list_exps pats context context_list atype_list + maybeexports export_list + impspec maybeimpspec import_list + impdecls maybeimpdecls impdecl + renaming renamings renaming_list + tyclses tycls_list + gdrhs gdpat valrhs valrhs1 + lampats + upto + cexp + idata_pragma_specs idata_pragma_specslist + gen_pragma_list type_pragma_pairs + type_pragma_pairs_maybe name_pragma_pairs + maybe_name_pragma_pairs type_instpragma_pairs + type_maybes + restof_iinst_spec + howto_inline_maybe + core_binders core_tyvars core_tv_templates + core_types core_type_list + core_atoms core_atom_list + core_alg_alts core_prim_alts corec_binds + core_type_maybes + +%type lit_constant + +%type exp dexp fexp kexp oexp aexp + tuple list sequence comprehension qual qualrest + gd + apat bpat pat apatc conpat dpat fpat opat aapat + dpatk fpatk opatk aapatk + texps + +%type MINUS VARID CONID VARSYM CONSYM TYVAR_TEMPLATE_ID + var vark con conk varop varop1 conop op op1 + varsym minus plus + tycls tycon modid ccallid modname_pragma + +%type topdecl topdecls + typed datad classd instd defaultd + decl decls valdef instdef instdefs + iimport iimports maybeiimports + ityped idatad iclassd iinstd ivarsd + itopdecl itopdecls + maybe_where + interface readinterface ibody + cbody rinst + impdecl_rest + type_and_maybe_id + +%type simple simple_long type atype btype ttype ntatype inst class + tyvar core_type type_maybe core_type_maybe + +%type constr + +%type FLOAT INTEGER INTPRIM + FLOATPRIM DOUBLEPRIM CLITLIT +%type STRING STRINGPRIM CHAR CHARPRIM +%type export import + +%type idata_pragma idata_pragma_spectypes + itype_pragma iclas_pragma iclasop_pragma + iinst_pragma gen_pragma ival_pragma arity_pragma + update_pragma strictness_pragma worker_info + deforest_pragma + unfolding_pragma unfolding_guidance type_pragma_pair + type_instpragma_pair name_pragma_pair + +%type core_expr core_case_alts core_id core_binder core_atom + core_alg_alt core_prim_alt core_default corec_bind + co_primop co_scc co_caf co_dupd + +/********************************************************************** +* * +* * +* Start Symbol for the Parser * +* * +* * +**********************************************************************/ + +%start pmodule + + +%% + +pmodule : readpreludecore readprelude module + ; + +module : modulekey modid maybeexports + { the_module_name = $2; module_exports = $3; } + WHERE body + | { the_module_name = install_literal("Main"); module_exports = Lnil; } + body + ; + + /* all the startlinenos in mkhmodules are bogus (WDP) */ +body : ocurly maybeimpdecls maybefixes topdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4,startlineno); + } + | vocurly maybeimpdecls maybefixes topdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4,startlineno); + } + + | vocurly impdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + | ocurly impdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + +/* Adds 1 S/R, 2 R/R conflicts, alternatives add 3 R/R conflicts */ + | vocurly maybeimpdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + | ocurly maybeimpdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + ; + + +maybeexports : /* empty */ { $$ = Lnil; } + | OPAREN export_list CPAREN { $$ = $2; } + ; + +export_list: + export { $$ = lsing($1); } + | export_list COMMA export { $$ = lapp($1, $3); } + ; + +export : + var { $$ = mkentid($1); } + | tycon { $$ = mkenttype($1); } + | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | tycon OPAREN cons CPAREN + { $$ = mkenttypecons($1,$3); + /* should be a datatype with cons representing all constructors */ + } + | tycon OPAREN vars CPAREN + { $$ = mkentclass($1,$3); + /* should be a class with vars representing all Class operations */ + } + | tycon OPAREN CPAREN + { $$ = mkentclass($1,Lnil); + /* "tycon" should be a class with no operations */ + } + | tycon DOTDOT + { $$ = mkentmod($1); + /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */ + } + ; + + +impspec : OPAREN import_list CPAREN { $$ = $2; hidden = FALSE; } + | HIDING OPAREN import_list CPAREN { $$ = $3; hidden = TRUE; } + | OPAREN CPAREN { $$ = Lnil; hidden = FALSE; } + ; + +maybeimpspec : /* empty */ { $$ = Lnil; } + | impspec { $$ = $1; } + ; + +import_list: + import { $$ = lsing($1); } + | import_list COMMA import { $$ = lapp($1, $3); } + ; + +import : + var { $$ = mkentid($1); } + | tycon { $$ = mkenttype($1); } + | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | tycon OPAREN cons CPAREN + { $$ = mkenttypecons($1,$3); + /* should be a datatype with cons representing all constructors */ + } + | tycon OPAREN vars CPAREN + { $$ = mkentclass($1,$3); + /* should be a class with vars representing all Class operations */ + } + | tycon OPAREN CPAREN + { $$ = mkentclass($1,Lnil); + /* "tycon" should be a class with no operations */ + } + ; + +/* -- interface pragma stuff: ------------------------------------- */ + +idata_pragma: + GHC_PRAGMA constrs idata_pragma_specs END_PRAGMA + { $$ = mkidata_pragma($2, $3); } + | GHC_PRAGMA idata_pragma_specs END_PRAGMA + { $$ = mkidata_pragma(Lnil, $2); } + | /* empty */ { $$ = mkno_pragma(); } + ; + +idata_pragma_specs : + SPECIALISE_PRAGMA idata_pragma_specslist + { $$ = $2; } + | /* empty */ { $$ = Lnil; } + ; + +idata_pragma_specslist: + idata_pragma_spectypes { $$ = lsing($1); } + | idata_pragma_specslist COMMA idata_pragma_spectypes + { $$ = lapp($1, $3); } + ; + +idata_pragma_spectypes: + OBRACK type_maybes CBRACK { $$ = mkidata_pragma_4s($2); } + ; + +itype_pragma: + GHC_PRAGMA ABSTRACT_PRAGMA END_PRAGMA { $$ = mkitype_pragma(); } + | /* empty */ { $$ = mkno_pragma(); } + ; + +iclas_pragma: + GHC_PRAGMA gen_pragma_list END_PRAGMA { $$ = mkiclas_pragma($2); } + | /* empty */ { $$ = mkno_pragma(); } + ; + +iclasop_pragma: + GHC_PRAGMA gen_pragma gen_pragma END_PRAGMA + { $$ = mkiclasop_pragma($2, $3); } + | /* empty */ + { $$ = mkno_pragma(); } + ; + +iinst_pragma: + GHC_PRAGMA modname_pragma gen_pragma END_PRAGMA + { $$ = mkiinst_simpl_pragma($2, $3); } + + | GHC_PRAGMA modname_pragma gen_pragma name_pragma_pairs END_PRAGMA + { $$ = mkiinst_const_pragma($2, $3, $4); } + + | GHC_PRAGMA modname_pragma gen_pragma restof_iinst_spec END_PRAGMA + { $$ = mkiinst_spec_pragma($2, $3, $4); } + + | /* empty */ + { $$ = mkno_pragma(); } + ; + +modname_pragma: + MODNAME_PRAGMA modid + { $$ = $2; } + | /* empty */ + { $$ = install_literal(""); } + ; + +restof_iinst_spec: SPECIALISE_PRAGMA type_instpragma_pairs { $$ = $2; } + ; + +ival_pragma: + GHC_PRAGMA gen_pragma END_PRAGMA + { $$ = $2; } + | /* empty */ + { $$ = mkno_pragma(); } + ; + +gen_pragma: + NOINFO_PRAGMA + { $$ = mkno_pragma(); } + | arity_pragma update_pragma deforest_pragma strictness_pragma unfolding_pragma type_pragma_pairs_maybe + { $$ = mkigen_pragma($1, $2, $3, $4, $5, $6); } + ; + +arity_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | ARITY_PRAGMA INTEGER { $$ = mkiarity_pragma($2); } + ; + +update_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | UPDATE_PRAGMA INTEGER { $$ = mkiupdate_pragma($2); } + ; + +deforest_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | DEFOREST_PRAGMA { $$ = mkideforest_pragma(); } + ; + +strictness_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | STRICTNESS_PRAGMA COCON { $$ = mkistrictness_pragma(installHstring(1, "B"), + /* _!_ = COCON = bottom */ mkno_pragma()); + } + | STRICTNESS_PRAGMA STRING worker_info + { $$ = mkistrictness_pragma($2, $3); } + ; + +worker_info: + OCURLY gen_pragma CCURLY { $$ = $2; } + | /* empty */ { $$ = mkno_pragma(); } + +unfolding_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | MAGIC_UNFOLDING_PRAGMA vark + { $$ = mkimagic_unfolding_pragma($2); } + | UNFOLDING_PRAGMA unfolding_guidance core_expr + { $$ = mkiunfolding_pragma($2, $3); } + ; + +unfolding_guidance: + UNFOLD_ALWAYS + { $$ = mkiunfold_always(); } + | UNFOLD_IF_ARGS INTEGER INTEGER CONID INTEGER + { $$ = mkiunfold_if_args($2, $3, $4, $5); } + ; + +gen_pragma_list: + gen_pragma { $$ = lsing($1); } + | gen_pragma_list COMMA gen_pragma { $$ = lapp($1, $3); } + ; + +type_pragma_pairs_maybe: + NO_PRAGMA { $$ = Lnil; } + | SPECIALISE_PRAGMA type_pragma_pairs { $$ = $2; } + ; + +type_pragma_pairs: + type_pragma_pair { $$ = lsing($1); } + | type_pragma_pairs COMMA type_pragma_pair { $$ = lapp($1, $3); } + ; + +type_pragma_pair: + OBRACK type_maybes CBRACK INTEGER worker_info + { $$ = mkitype_pragma_pr($2, $4, $5); } + ; + +type_instpragma_pairs: + type_instpragma_pair { $$ = lsing($1); } + | type_instpragma_pairs COMMA type_instpragma_pair { $$ = lapp($1,$3); } + ; + +type_instpragma_pair: + OBRACK type_maybes CBRACK INTEGER worker_info maybe_name_pragma_pairs + { $$ = mkiinst_pragma_3s($2, $4, $5, $6); } + ; + +type_maybes: + type_maybe { $$ = lsing($1); } + | type_maybes COMMA type_maybe { $$ = lapp($1, $3); } + ; + +type_maybe: + NO_PRAGMA { $$ = mkty_maybe_nothing(); } + | type { $$ = mkty_maybe_just($1); } + ; + +maybe_name_pragma_pairs: + /* empty */ { $$ = Lnil; } + | name_pragma_pairs { $$ = $1; } + ; + +name_pragma_pairs: + name_pragma_pair { $$ = lsing($1); } + | name_pragma_pairs COMMA name_pragma_pair { $$ = lapp($1, $3); } + ; + +name_pragma_pair: + var EQUAL gen_pragma + { $$ = mkiname_pragma_pr($1, $3); } + ; + +/* -- end of interface pragma stuff ------------------------------- */ + +/* -- core syntax stuff ------------------------------------------- */ + +core_expr: + LAMBDA core_binders RARROW core_expr + { $$ = mkcolam($2, $4); } + | TYLAMBDA core_tyvars RARROW core_expr + { $$ = mkcotylam($2, $4); } + | COCON con core_types core_atoms + { $$ = mkcocon(mkco_id($2), $3, $4); } + | COCON CO_ORIG_NM modid con core_types core_atoms + { $$ = mkcocon(mkco_orig_id($3,$4), $5, $6); } + | COPRIM co_primop core_types core_atoms + { $$ = mkcoprim($2, $3, $4); } + | COAPP core_expr core_atoms + { $$ = mkcoapp($2, $3); } + | COTYAPP core_expr OCURLY core_type CCURLY + { $$ = mkcotyapp($2, $4); } + | CASE core_expr OF OCURLY core_case_alts CCURLY + { $$ = mkcocase($2, $5); } + | LET OCURLY core_binder EQUAL core_expr CCURLY IN core_expr + { $$ = mkcolet(mkcononrec($3, $5), $8); } + | CO_LETREC OCURLY corec_binds CCURLY IN core_expr + { $$ = mkcolet(mkcorec($3), $6); } + | SCC OCURLY co_scc CCURLY core_expr + { $$ = mkcoscc($3, $5); } + | lit_constant { $$ = mkcoliteral($1); } + | core_id { $$ = mkcovar($1); } + ; + +core_case_alts : + CO_ALG_ALTS core_alg_alts core_default + { $$ = mkcoalg_alts($2, $3); } + | CO_PRIM_ALTS core_prim_alts core_default + { $$ = mkcoprim_alts($2, $3); } + ; + +core_alg_alts : + /* empty */ { $$ = Lnil; } + | core_alg_alts core_alg_alt { $$ = lapp($1, $2); } + ; + +core_alg_alt: + core_id core_binders RARROW core_expr SEMI { $$ = mkcoalg_alt($1, $2, $4); } + /* core_id is really too generous */ + ; + +core_prim_alts : + /* empty */ { $$ = Lnil; } + | core_prim_alts core_prim_alt { $$ = lapp($1, $2); } + ; + +core_prim_alt: + lit_constant RARROW core_expr SEMI { $$ = mkcoprim_alt($1, $3); } + ; + +core_default: + CO_NO_DEFAULT { $$ = mkconodeflt(); } + | core_binder RARROW core_expr { $$ = mkcobinddeflt($1, $3); } + ; + +corec_binds: + corec_bind { $$ = lsing($1); } + | corec_binds SEMI corec_bind { $$ = lapp($1, $3); } + ; + +corec_bind: + core_binder EQUAL core_expr { $$ = mkcorec_pair($1, $3); } + ; + +co_scc : + CO_PRELUDE_DICTS_CC co_dupd { $$ = mkco_preludedictscc($2); } + | CO_ALL_DICTS_CC STRING STRING co_dupd { $$ = mkco_alldictscc($2,$3,$4); } + | CO_USER_CC STRING STRING STRING co_dupd co_caf + { $$ = mkco_usercc($2,$3,$4,$5,$6); } + | CO_AUTO_CC core_id STRING STRING co_dupd co_caf + { $$ = mkco_autocc($2,$3,$4,$5,$6); } + | CO_DICT_CC core_id STRING STRING co_dupd co_caf + { $$ = mkco_dictcc($2,$3,$4,$5,$6); } + +co_caf : NO_PRAGMA { $$ = mkco_scc_noncaf(); } + | CO_CAF_CC { $$ = mkco_scc_caf(); } + +co_dupd : NO_PRAGMA { $$ = mkco_scc_nondupd(); } + | CO_DUPD_CC { $$ = mkco_scc_dupd(); } + +core_id: /* more to come?? */ + CO_SDSEL_ID tycon tycon { $$ = mkco_sdselid($2, $3); } + | CO_METH_ID tycon var { $$ = mkco_classopid($2, $3); } + | CO_DEFM_ID tycon var { $$ = mkco_defmid($2, $3); } + | CO_DFUN_ID tycon OPAREN core_type CPAREN + { $$ = mkco_dfunid($2, $4); } + | CO_CONSTM_ID tycon var OPAREN core_type CPAREN + { $$ = mkco_constmid($2, $3, $5); } + | CO_SPEC_ID core_id OBRACK core_type_maybes CBRACK + { $$ = mkco_specid($2, $4); } + | CO_WRKR_ID core_id { $$ = mkco_wrkrid($2); } + | CO_ORIG_NM modid var { $$ = mkco_orig_id($2, $3); } + | CO_ORIG_NM modid con { $$ = mkco_orig_id($2, $3); } + | var { $$ = mkco_id($1); } + | con { $$ = mkco_id($1); } + ; + +co_primop : + OPAREN CCALL ccallid OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_ccall($3,0,$5,$6); } + | OPAREN CCALL_GC ccallid OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_ccall($3,1,$5,$6); } + | OPAREN CASM lit_constant OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_casm($3,0,$5,$6); } + | OPAREN CASM_GC lit_constant OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_casm($3,1,$5,$6); } + | VARID { $$ = mkco_primop($1); } + ; + +core_binders : + /* empty */ { $$ = Lnil; } + | core_binders core_binder { $$ = lapp($1, $2); } + ; + +core_binder : + OPAREN VARID DCOLON core_type CPAREN { $$ = mkcobinder($2, $4); } + +core_atoms : + OBRACK CBRACK { $$ = Lnil; } + | OBRACK core_atom_list CBRACK { $$ = $2; } + ; + +core_atom_list : + core_atom { $$ = lsing($1); } + | core_atom_list COMMA core_atom { $$ = lapp($1, $3); } + ; + +core_atom : + lit_constant { $$ = mkcolit($1); } + | core_id { $$ = mkcolocal($1); } + ; + +core_tyvars : + VARID { $$ = lsing($1); } + | core_tyvars VARID { $$ = lapp($1, $2); } + ; + +core_tv_templates : + TYVAR_TEMPLATE_ID { $$ = lsing($1); } + | core_tv_templates COMMA TYVAR_TEMPLATE_ID { $$ = lapp($1, $3); } + ; + +core_types : + OBRACK CBRACK { $$ = Lnil; } + | OBRACK core_type_list CBRACK { $$ = $2; } + ; + +core_type_list : + core_type { $$ = lsing($1); } + | core_type_list COMMA core_type { $$ = lapp($1, $3); } + ; + +core_type : + type { $$ = $1; } + ; + +/* +core_type : + FORALL core_tv_templates DARROW core_type + { $$ = mkuniforall($2, $4); } + | OCURLY OCURLY CONID core_type CCURLY CCURLY RARROW core_type + { $$ = mktfun(mkunidict($3, $4), $8); } + | OCURLY OCURLY CONID core_type CCURLY CCURLY + { $$ = mkunidict($3, $4); } + | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN RARROW core_type + { $$ = mktfun(mkttuple(mklcons(mkunidict($4, $5), $9)), $12); } + | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN + { $$ = mkttuple(mklcons(mkunidict($4,$5), $9)); } + | type { $$ = $1; } + ; +*/ + +core_type_maybes: + core_type_maybe { $$ = lsing($1); } + | core_type_maybes COMMA core_type_maybe { $$ = lapp($1, $3); } + ; + +core_type_maybe: + NO_PRAGMA { $$ = mkty_maybe_nothing(); } + | core_type { $$ = mkty_maybe_just($1); } + ; + +/* -- end of core syntax stuff ------------------------------------ */ + +readpreludecore : + { + if ( implicitPrelude && !etags ) { + /* we try to avoid reading interfaces when etagging */ + find_module_on_imports_dirlist( + (haskell1_3Flag) ? "PrelCore13" : "PreludeCore", + TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + } + readinterface + { + binding prelude_core = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno); + prelude_core_import = implicitPrelude? lsing(prelude_core): Lnil; + + } + ; + +readprelude : + { + if ( implicitPrelude && !etags ) { + find_module_on_imports_dirlist( + ( haskell1_3Flag ) ? "Prel13" : "Prelude", + TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + } + readinterface + { + binding prelude = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno); + prelude_imports = (! implicitPrelude) ? Lnil + : lconc(prelude_core_import,lsing(prelude)); + } + ; + +maybeimpdecls : /* empty */ { $$ = Lnil; } + | impdecls SEMI { $$ = $1; } + ; + +impdecls: impdecl { $$ = $1; } + | impdecls SEMI impdecl { $$ = lconc($1,$3); } + ; + +impdecl : IMPORT modid + { /* filename returned in "interface_filename" */ + char *module_name = id_to_string($2); + if ( ! etags ) { + find_module_on_imports_dirlist( + (haskell1_3Flag && strcmp(module_name, "Prelude") == 0) + ? "Prel13" : module_name, + FALSE, interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + if (strcmp(module_name,"PreludeCore")==0) { + hsperror("Cannot explicitly import `PreludeCore'"); + + } else if (strcmp(module_name,"Prelude")==0) { + prelude_imports = prelude_core_import; /* unavoidable */ + } + } + impdecl_rest + { + if (hidden) + $4->tag = hiding; + $$ = lsing($4); + } + +impdecl_rest: + readinterface maybeimpspec + { $$ = mkimport(installid(iface_name),$2,Lnil,$1,xstrdup(interface_filename),hsplineno); } + /* WDP: uncertain about those hsplinenos */ + | readinterface maybeimpspec RENAMING renamings + { $$ = mkimport(installid(iface_name),$2,$4,$1,xstrdup(interface_filename),hsplineno); } + ; + +readinterface: + interface LEOF + { + exposeis(); /* partain: expose infix ops at level i+1 to level i */ + $$ = $1; + } + ; + +renamings: OPAREN renaming_list CPAREN { $$ = $2; } + ; + +renaming_list: + renaming { $$ = lsing($1); } + | renaming_list COMMA renaming { $$ = lapp($1, $3); } + ; + +renaming: var TO var { $$ = ldub($1,$3); } + | con TO con { $$ = ldub($1,$3); } + ; + +maybeiimports : /* empty */ { $$ = mknullbind(); } + | iimports SEMI { $$ = $1; } + ; + +iimports : iimport { $$ = $1; } + | iimports SEMI iimport { $$ = mkabind($1,$3); } + ; + +iimport : importkey modid OPAREN import_list CPAREN + { $$ = mkmbind($2,$4,Lnil,startlineno); } + | importkey modid OPAREN import_list CPAREN RENAMING renamings + { $$ = mkmbind($2,$4,$7,startlineno); } + ; + + +interface: + INTERFACE modid + { fixlist = Lnil; + strcpy(iface_name, id_to_string($2)); + } + WHERE ibody + { + /* WDP: not only do we not check the module name + but we take the one in the interface to be what we really want + -- we need this for Prelude jiggery-pokery. (Blech. KH) + ToDo: possibly revert.... + checkmodname(modname,id_to_string($2)); + */ + $$ = $5; + } + ; + + +ibody : ocurly maybeiimports maybefixes itopdecls ccurly + { + $$ = mkabind($2,$4); + } + | ocurly iimports ccurly + { + $$ = $2; + } + | vocurly maybeiimports maybefixes itopdecls vccurly + { + $$ = mkabind($2,$4); + } + | vocurly iimports vccurly + { + $$ = $2; + } + ; + +maybefixes: /* empty */ + | fixes SEMI + ; + + +fixes : fix + | fixes SEMI fix + ; + +fix : INFIXL INTEGER + { Precedence = checkfixity($2); Fixity = INFIXL; } + ops + | INFIXR INTEGER + { Precedence = checkfixity($2); Fixity = INFIXR; } + ops + | INFIX INTEGER + { Precedence = checkfixity($2); Fixity = INFIX; } + ops + | INFIXL + { Fixity = INFIXL; Precedence = 9; } + ops + | INFIXR + { Fixity = INFIXR; Precedence = 9; } + ops + | INFIX + { Fixity = INFIX; Precedence = 9; } + ops + ; + +ops : op { makeinfix(id_to_string($1),Fixity,Precedence); } + | ops COMMA op { makeinfix(id_to_string($3),Fixity,Precedence); } + ; + +topdecls: topdecl + | topdecls SEMI topdecl + { + if($1 != NULL) + if($3 != NULL) + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + else + $$ = $1; + else + $$ = $3; + SAMEFN = 0; + } + ; + +topdecl : typed { $$ = $1; } + | datad { $$ = $1; } + | classd { $$ = $1; } + | instd { $$ = $1; } + | defaultd { $$ = $1; } + | decl { $$ = $1; } + ; + +typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno,mkno_pragma()); } + ; + + +datad : datakey context DARROW simple EQUAL constrs + { $$ = mktbind($2,$4,$6,all,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs + { $$ = mktbind(Lnil,$2,$4,all,startlineno,mkno_pragma()); } + | datakey context DARROW simple EQUAL constrs DERIVING tyclses + { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs DERIVING tyclses + { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); } + ; + +classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,mkno_pragma()); } + | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,mkno_pragma()); } + ; + +cbody : /* empty */ { $$ = mknullbind(); } + | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; } + | WHERE vocurly decls vccurly { checkorder($3); $$ =$3; } + ; + +instd : instkey context DARROW tycls inst rinst { $$ = mkibind($2,$4,$5,$6,startlineno,mkno_pragma()); } + | instkey tycls inst rinst { $$ = mkibind(Lnil,$2,$3,$4,startlineno,mkno_pragma()); } + ; + +rinst : /* empty */ { $$ = mknullbind(); } + | WHERE ocurly instdefs ccurly { $$ = $3; } + | WHERE vocurly instdefs vccurly { $$ = $3; } + ; + +inst : tycon { $$ = mktname($1,Lnil); } + | OPAREN simple_long CPAREN { $$ = $2; } + /* partain?: "simple" requires k >= 0, not k > 0 (hence "simple_long" hack) */ + | OPAREN atype_list CPAREN { $$ = mkttuple($2); } + | OPAREN CPAREN { $$ = mkttuple(Lnil); } + | OBRACK atype CBRACK { $$ = mktllist($2); } + | OPAREN atype RARROW atype CPAREN { $$ = mktfun($2,$4); } + ; + +defaultd: defaultkey dtypes { $$ = mkdbind($2,startlineno); } + ; + +dtypes : OPAREN type COMMA types CPAREN { $$ = mklcons($2,$4); } + | ttype { $$ = lsing($1); } +/* Omitting the next forces () to be the *type* (), which never defaults. + This is a KLUDGE. (Putting this in adds piles of r/r conflicts.) +*/ +/* | OPAREN CPAREN { $$ = Lnil; }*/ + ; + +decls : decl + | decls SEMI decl + { + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + } + ; + +/* partain: this "DCOLON context" vs "DCOLON type" is a problem, + because you can't distinguish between + + foo :: (Baz a, Baz a) + bar :: (Baz a, Baz a) => [a] -> [a] -> [a] + + with one token of lookahead. The HACK is to have "DCOLON ttype" + [tuple type] in the first case, then check that it has the right + form C a, or (C1 a, C2 b, ... Cn z) and convert it into a + context. Blaach! + (FIXED 90/06/06) + + Note: if there is an iclasop_pragma there, then we must be + doing a class-op in an interface -- unless the user is up + to real mischief (ugly, but likely to work). +*/ + +decl : vars DCOLON type DARROW type iclasop_pragma + { /* type2context.c for code */ + $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + | vars DCOLON type iclasop_pragma + { + $$ = mksbind($1,$3,startlineno,$4); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + /* User-specified pragmas come in as "signatures"... + They are similar in that they can appear anywhere in the module, + and have to be "joined up" with their related entity. + + Have left out the case specialising to an overloaded type. + Let's get real, OK? (WDP) + */ + | SPECIALISE_UPRAGMA vark DCOLON types_and_maybe_ids END_UPRAGMA + { + $$ = mkvspec_uprag($2, $4, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | SPECIALISE_UPRAGMA INSTANCE CONID inst END_UPRAGMA + { + $$ = mkispec_uprag($3, $4, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | SPECIALISE_UPRAGMA DATA tycon atypes END_UPRAGMA + { + $$ = mkdspec_uprag($3, $4, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | INLINE_UPRAGMA vark howto_inline_maybe END_UPRAGMA + { + $$ = mkinline_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | MAGIC_UNFOLDING_UPRAGMA vark vark END_UPRAGMA + { + $$ = mkmagicuf_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | DEFOREST_UPRAGMA vark END_UPRAGMA + { + $$ = mkdeforest_uprag($2, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | ABSTRACT_UPRAGMA tycon END_UPRAGMA + { + $$ = mkabstract_uprag($2, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + /* end of user-specified pragmas */ + + | valdef + | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; } + ; + +howto_inline_maybe : + /* empty */ { $$ = Lnil; } + | CONID { $$ = lsing($1); } + +types_and_maybe_ids : + type_and_maybe_id { $$ = lsing($1); } + | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); } + ; + +type_and_maybe_id : + type { $$ = mkvspec_ty_and_id($1,Lnil); } + | type EQUAL vark { $$ = mkvspec_ty_and_id($1,lsing($3)); } + +itopdecls : itopdecl { $$ = $1; } + | itopdecls SEMI itopdecl { $$ = mkabind($1,$3); } + ; + +itopdecl: ityped { $$ = $1; } + | idatad { $$ = $1; } + | iclassd { $$ = $1; } + | iinstd { $$ = $1; } + | ivarsd { $$ = $1; } + | /* empty */ { $$ = mknullbind(); } + ; + + /* partain: see comment elsewhere about why "type", not "context" */ +ivarsd : vars DCOLON type DARROW type ival_pragma + { $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); } + | vars DCOLON type ival_pragma + { $$ = mksbind($1,$3,startlineno,$4); } + ; + +ityped : typekey simple EQUAL type itype_pragma + { $$ = mknbind($2,$4,startlineno,$5); } + ; + +idatad : datakey context DARROW simple idata_pragma + { $$ = mktbind($2,$4,Lnil,Lnil,startlineno,$5); } + | datakey simple idata_pragma + { $$ = mktbind(Lnil,$2,Lnil,Lnil,startlineno,$3); } + | datakey context DARROW simple EQUAL constrs idata_pragma + { $$ = mktbind($2,$4,$6,Lnil,startlineno,$7); } + | datakey simple EQUAL constrs idata_pragma + { $$ = mktbind(Lnil,$2,$4,Lnil,startlineno,$5); } + | datakey context DARROW simple EQUAL constrs DERIVING tyclses + { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs DERIVING tyclses + { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); } + ; + +iclassd : classkey context DARROW class iclas_pragma cbody + { $$ = mkcbind($2,$4,$6,startlineno,$5); } + | classkey class iclas_pragma cbody + { $$ = mkcbind(Lnil,$2,$4,startlineno,$3); } + ; + +iinstd : instkey context DARROW tycls inst iinst_pragma + { $$ = mkibind($2,$4,$5,mknullbind(),startlineno,$6); } + | instkey tycls inst iinst_pragma + { $$ = mkibind(Lnil,$2,$3,mknullbind(),startlineno,$4); } + ; + + +/* obsolete: "(C a, ...)" cause r/r conflict, resolved in favour of context rather than type */ + +class : tycon tyvar { $$ = mktname($1,lsing($2)); } + /* partain: changed "tycls" to "tycon" */ + ; + +types : type { $$ = lsing($1); } + | types COMMA type { $$ = lapp($1,$3); } + ; + +type : btype { $$ = $1; } + | btype RARROW type { $$ = mktfun($1,$3); } + + | FORALL core_tv_templates DARROW type + { $$ = mkuniforall($2, $4); } + +btype : atype { $$ = $1; } + | tycon atypes { $$ = mktname($1,$2); } + ; + +atypes : atypes atype { $$ = lapp($1,$2); } + | atype { $$ = lsing($1); } + ; + +/* The split with ntatype allows us to use the same syntax for defaults as for types */ +ttype : ntatype { $$ = $1; } + | btype RARROW type { $$ = mktfun($1,$3); } + | tycon atypes { $$ = mktname($1,$2); } + ; + +atype : ntatype + | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); } + ; + +ntatype : tyvar { $$ = $1; } + | tycon { $$ = mktname($1,Lnil); } + | OPAREN CPAREN { $$ = mkttuple(Lnil); } + | OPAREN type CPAREN { $$ = $2; } + | OBRACK type CBRACK { $$ = mktllist($2); } + + | OCURLY OCURLY CONID type CCURLY CCURLY + { $$ = mkunidict($3, $4); } + | TYVAR_TEMPLATE_ID { $$ = mkunityvartemplate($1); } + ; + + +simple : tycon { $$ = mktname($1,Lnil); } + | tycon tyvars { $$ = mktname($1,$2); } + ; + + +simple_long : tycon atypes { $$ = mktname($1,$2); } + ; /* partain: see comment in "inst" */ + /* partain: "atypes" should be "tyvars" if you want to + avoid "extended instances" by syntactic means. */ + + +constrs : constr { $$ = lsing($1); } + | constrs VBAR constr { $$ = lapp($1,$3); } + ; + +/* Using tycon rather than con avoids 5 S/R errors */ +constr : tycon atypes { $$ = mkatc($1,$2,hsplineno); } + | OPAREN CONSYM CPAREN atypes { $$ = mkatc($2,$4,hsplineno); } + | tycon { $$ = mkatc($1,Lnil,hsplineno); } + | OPAREN CONSYM CPAREN { $$ = mkatc($2,Lnil,hsplineno); } + | btype conop btype { $$ = mkatc($2, ldub($1,$3),hsplineno); } + ; + +tyclses : OPAREN tycls_list CPAREN { $$ = $2; } + | OPAREN CPAREN { $$ = Lnil; } + | tycls { $$ = lsing($1); } + ; + +tycls_list: tycls { $$ = lsing($1); } + | tycls_list COMMA tycls { $$ = lapp($1,$3); } + ; + +context : OPAREN context_list CPAREN { $$ = $2; } + | class { $$ = lsing($1); } + ; + +context_list: class { $$ = lsing($1); } + | context_list COMMA class { $$ = lapp($1,$3); } + ; + +instdefs : /* empty */ { $$ = mknullbind(); } + | instdef { $$ = $1; } + | instdefs SEMI instdef + { + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + } + ; + +/* instdef: same as valdef, except certain user-pragmas may appear */ +instdef : + INLINE_UPRAGMA vark howto_inline_maybe END_UPRAGMA + { + $$ = mkinline_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | MAGIC_UNFOLDING_UPRAGMA vark vark END_UPRAGMA + { + $$ = mkmagicuf_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | valdef + ; + + +vars : vark COMMA varsrest { $$ = mklcons($1,$3); } + | vark { $$ = lsing($1); } + /* right recursion ? WDP */ + ; + +varsrest: var { $$ = lsing($1); } + | varsrest COMMA var { $$ = lapp($1,$3); } + ; + +cons : con { $$ = lsing($1); } + | cons COMMA con { $$ = lapp($1,$3); } + ; + + +valdef : opatk + { + tree fn = function($1); + + PREVPATT = $1; + + if(ttree(fn) == ident) + { + checksamefn(gident((struct Sident *) fn)); + FN = fn; + } + + else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident) + { + checksamefn(gident((struct Sident *) (ginfun((struct Sap *) fn)))); + FN = ginfun((struct Sap *) fn); + } + + else if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tvaldef\n",startlineno); +#endif + } + valrhs + { + if ( lhs_is_patt($1) ) + { + $$ = mkpbind($3, startlineno); + FN = NULL; + SAMEFN = 0; + } + else /* lhs is function */ + $$ = mkfbind($3,startlineno); + + PREVPATT = NULL; + } + ; + +valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); } + ; + +valrhs1 : gdrhs + | EQUAL exp { $$ = lsing(mktruecase($2)); } + ; + +gdrhs : gd EQUAL exp { $$ = lsing(ldub($1,$3)); } + | gd EQUAL exp gdrhs { $$ = mklcons(ldub($1,$3),$4); } + ; + +maybe_where: + WHERE ocurly decls ccurly { $$ = $3; } + | WHERE vocurly decls vccurly { $$ = $3; } + | /* empty */ { $$ = mknullbind(); } + ; + +gd : VBAR oexp { $$ = $2; } + ; + + +lampats : apat lampats { $$ = mklcons($1,$2); } + | apat { $$ = lsing($1); } + ; /* right recursion? (WDP) */ + + +/* + Changed as above to allow for contexts! + KH@21/12/92 +*/ + +exp : oexp DCOLON type DARROW type { $$ = mkrestr($1,mkcontext(type2context($3),$5)); } + | oexp DCOLON type { $$ = mkrestr($1,$3); } + | oexp + ; + +/* + Operators must be left-associative at the same precedence + for prec. parsing to work. +*/ + + /* Infix operator application */ +oexp : dexp + | oexp op oexp %prec PLUS + { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +/* + This comes here because of the funny precedence rules concerning + prefix minus. +*/ + + +dexp : MINUS kexp { $$ = mknegate($2); } + | kexp + ; + +/* + let/if/lambda/case have higher precedence than infix operators. +*/ + +kexp : LAMBDA + { /* enteriscope(); /? I don't understand this -- KH */ + hsincindent(); /* added by partain; push new context for */ + /* FN = NULL; not actually concerned about */ + FN = NULL; /* indenting */ + $$ = hsplineno; /* remember current line number */ + } + lampats + { hsendindent(); /* added by partain */ + /* exitiscope(); /? Also not understood */ + } + RARROW exp /* lambda abstraction */ + { + $$ = mklambda($3, $6, $2); + } + + /* Let Expression */ + | LET ocurly decls ccurly IN exp { $$ = mklet($3,$6); } + | LET vocurly decls vccurly IN exp { $$ = mklet($3,$6); } + + /* If Expression */ + | IF exp THEN exp ELSE exp { $$ = mkife($2,$4,$6); } + + /* Case Expression */ + | CASE exp OF ocurly alts ccurly { $$ = mkcasee($2,$5); } + | CASE exp OF vocurly alts vccurly { $$ = mkcasee($2,$5); } + + /* CCALL/CASM Expression */ + | CCALL ccallid cexp { $$ = mkccall($2,installid("n"),$3); } + | CCALL ccallid { $$ = mkccall($2,installid("n"),Lnil); } + | CCALL_GC ccallid cexp { $$ = mkccall($2,installid("p"),$3); } + | CCALL_GC ccallid { $$ = mkccall($2,installid("p"),Lnil); } + | CASM CLITLIT cexp { $$ = mkccall($2,installid("N"),$3); } + | CASM CLITLIT { $$ = mkccall($2,installid("N"),Lnil); } + | CASM_GC CLITLIT cexp { $$ = mkccall($2,installid("P"),$3); } + | CASM_GC CLITLIT { $$ = mkccall($2,installid("P"),Lnil); } + + /* SCC Expression */ + | SCC STRING exp + { extern BOOLEAN ignoreSCC; + extern BOOLEAN warnSCC; + + if (ignoreSCC) { + if (warnSCC) + fprintf(stderr, + "\"%s\", line %d: _scc_ (`set [profiling] cost centre') ignored\n", + input_filename, hsplineno); + $$ = $3; + } else { + $$ = mkscc($2, $3); + } + } + | fexp + ; + + + /* Function application */ +fexp : fexp aexp { $$ = mkap($1,$2); } + | aexp + ; + +cexp : cexp aexp { $$ = lapp($1,$2); } + | aexp { $$ = lsing($1); } + ; + +/* + The mkpars are so that infix parsing doesn't get confused. + + KH. +*/ + + /* Simple Expressions */ +aexp : var { $$ = mkident($1); } + | con { $$ = mkident($1); } + | lit_constant { $$ = mklit($1); } + | OPAREN exp CPAREN { $$ = mkpar($2); } + | OPAREN oexp op CPAREN { checkprec($2,$3,FALSE); $$ = mklsection($2,$3); } + | OPAREN op1 oexp CPAREN { checkprec($3,$2,TRUE); $$ = mkrsection($2,$3); } + + /* structures */ + | tuple + | list { $$ = mkpar($1); } + | sequence { $$ = mkpar($1); } + | comprehension { $$ = mkpar($1); } + + /* These only occur in patterns */ + | var AT aexp { checkinpat(); $$ = mkas($1,$3); } + | WILDCARD { checkinpat(); $$ = mkwildp(); } + | LAZY aexp { checkinpat(); $$ = mklazyp($2); } + ; + + +/* + LHS patterns are parsed in a similar way to + expressions. This avoids the horrible non-LRness + which occurs with the 1.1 syntax. + + The xpatk business is to do with accurately recording + the starting line for definitions. +*/ + +/*TESTTEST +bind : opatk + | vark lampats + { $$ = mkap($1,$2); } + | opatk varop opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + } + ; + +opatk : dpatk + | opatk conop opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + precparse($$); + } + ; + +*/ + +opatk : dpatk + | opatk op opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + + if(isconstr(id_to_string($2))) + precparse($$); + else + { + checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */ + checkprec($3,$2,TRUE); /* then check the right pattern */ + } + } + ; + +opat : dpat + | opat op opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + + if(isconstr(id_to_string($2))) + precparse($$); + else + { + checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */ + checkprec($3,$2,TRUE); /* then check the right pattern */ + } + } + ; + +/* + This comes here because of the funny precedence rules concerning + prefix minus. +*/ + + +dpat : MINUS fpat { $$ = mknegate($2); } + | fpat + ; + + /* Function application */ +fpat : fpat aapat { $$ = mkap($1,$2); } + | aapat + ; + +dpatk : minuskey fpat { $$ = mknegate($2); } + | fpatk + ; + + /* Function application */ +fpatk : fpatk aapat { $$ = mkap($1,$2); } + | aapatk + ; + +aapat : con { $$ = mkident($1); } + | var { $$ = mkident($1); } + | var AT apat { $$ = mkas($1,$3); } + | lit_constant { $$ = mklit($1); } + | WILDCARD { $$ = mkwildp(); } + | OPAREN CPAREN { $$ = mktuple(Lnil); } + | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } +/* GHC cannot do these anyway. WDP 93/11/15 + | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } +*/ + | OPAREN opat CPAREN { $$ = mkpar($2); } + | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | OBRACK pats CBRACK { $$ = mkllist($2); } + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } + ; + +aapatk : conk { $$ = mkident($1); } + | vark { $$ = mkident($1); } + | vark AT apat { $$ = mkas($1,$3); } + | lit_constant { $$ = mklit($1); setstartlineno(); } + | WILDCARD { $$ = mkwildp(); setstartlineno(); } + | oparenkey CPAREN { $$ = mktuple(Lnil); } + | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } +/* GHC no cannae do (WDP 95/05) + | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } +*/ + | oparenkey opat CPAREN { $$ = mkpar($2); } + | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | obrackkey pats CBRACK { $$ = mkllist($2); } + | obrackkey CBRACK { $$ = mkllist(Lnil); } + | lazykey apat { $$ = mklazyp($2); } + ; + + +/* + The mkpars are so that infix parsing doesn't get confused. + + KH. +*/ + +tuple : OPAREN exp COMMA texps CPAREN + { if (ttree($4) == tuple) + $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4))); + else + $$ = mktuple(ldub($2, $4)); + } + | OPAREN CPAREN + { $$ = mktuple(Lnil); } + ; + +texps : exp { $$ = mkpar($1); } + | exp COMMA texps + { if (ttree($3) == tuple) + $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3))); + else + $$ = mktuple(ldub($1, $3)); + } + /* right recursion? WDP */ + ; + + +list : OBRACK CBRACK { $$ = mkllist(Lnil); } + | OBRACK list_exps CBRACK { $$ = mkllist($2); } + ; + +list_exps : + exp { $$ = lsing($1); } + | exp COMMA list_exps { $$ = mklcons($1, $3); } + /* right recursion? (WDP) + + It has to be this way, though, otherwise you + may do the wrong thing to distinguish between... + + [ e1 , e2 .. ] -- an enumeration ... + [ e1 , e2 , e3 ] -- a list + + (In fact, if you change the grammar and throw yacc/bison + at it, it *will* do the wrong thing [WDP 94/06]) + */ + ; + + +sequence: OBRACK exp COMMA exp DOTDOT upto CBRACK {$$ = mkeenum($2,lsing($4),$6);} + | OBRACK exp DOTDOT upto CBRACK { $$ = mkeenum($2,Lnil,$4); } + ; + +comprehension: OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); } + ; + +quals : qual { $$ = lsing($1); } + | quals COMMA qual { $$ = lapp($1,$3); } + ; + +qual : { inpat = TRUE; } exp { inpat = FALSE; } qualrest + { if ($4 == NULL) + $$ = mkguard($2); + else + { + checkpatt($2); + if(ttree($4)==def) + { + tree prevpatt_save = PREVPATT; + PREVPATT = $2; + $$ = mkdef((tree) mkpbind(lsing(createpat(lsing(mktruecase(ggdef((struct Sdef *) $4))),mknullbind())),hsplineno)); + PREVPATT = prevpatt_save; + } + else + $$ = mkqual($2,$4); + } + } + ; + +qualrest: LARROW exp { $$ = $2; } + | /* empty */ { $$ = NULL; } + ; + +alts : alt { $$ = $1; } + | alts SEMI alt { $$ = lconc($1,$3); } + ; + +alt : pat + { PREVPATT = $1; } + altrest + { $$ = $3; + PREVPATT = NULL; + } + | /* empty */ { $$ = Lnil; } + ; + +altrest : gdpat maybe_where { $$ = lsing(createpat($1, $2)); } + | RARROW exp maybe_where { $$ = lsing(createpat(lsing(mktruecase($2)), $3)); } + ; + +gdpat : gd RARROW exp gdpat { $$ = mklcons(ldub($1,$3),$4); } + | gd RARROW exp { $$ = lsing(ldub($1,$3)); } + ; + +upto : /* empty */ { $$ = Lnil; } + | exp { $$ = lsing($1); } + ; + +pats : pat COMMA pats { $$ = mklcons($1, $3); } + | pat { $$ = lsing($1); } + /* right recursion? (WDP) */ + ; + +pat : bpat + | pat conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +bpat : apatc + | conpat + | MINUS INTEGER { $$ = mklit(mkinteger(ineg($2))); } + | MINUS FLOAT { $$ = mklit(mkfloatr(ineg($2))); } + ; + +conpat : con { $$ = mkident($1); } + | conpat apat { $$ = mkap($1,$2); } + ; + +apat : con { $$ = mkident($1); } + | apatc + ; + +apatc : var { $$ = mkident($1); } + | var AT apat { $$ = mkas($1,$3); } + | lit_constant { $$ = mklit($1); } + | WILDCARD { $$ = mkwildp(); } + | OPAREN CPAREN { $$ = mktuple(Lnil); } + | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } +/* GHC no cannae do (WDP 95/05) + | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } +*/ + | OPAREN pat CPAREN { $$ = mkpar($2); } + | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | OBRACK pats CBRACK { $$ = mkllist($2); } + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } + ; + +lit_constant: + INTEGER { $$ = mkinteger($1); } + | FLOAT { $$ = mkfloatr($1); } + | CHAR { $$ = mkcharr($1); } + | STRING { $$ = mkstring($1); } + | CHARPRIM { $$ = mkcharprim($1); } + | STRINGPRIM { $$ = mkstringprim($1); } + | INTPRIM { $$ = mkintprim($1); } + | FLOATPRIM { $$ = mkfloatprim($1); } + | DOUBLEPRIM { $$ = mkdoubleprim($1); } + | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1, ""); } + | CLITLIT KIND_PRAGMA CONID { $$ = mkclitlit($1, $3); } + | NOREP_INTEGER INTEGER { $$ = mknorepi($2); } + | NOREP_RATIONAL INTEGER INTEGER { $$ = mknorepr($2, $3); } + | NOREP_STRING STRING { $$ = mknoreps($2); } + ; + + +/* Keywords which record the line start */ + +importkey: IMPORT { setstartlineno(); } + ; + +datakey : DATA { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tdata\n",startlineno); +#endif + } + ; + +typekey : TYPE { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\ttype\n",startlineno); +#endif + } + ; + +instkey : INSTANCE { setstartlineno(); +#if 1/*etags*/ +/* OUT: if(etags) + printf("%u\n",startlineno); +*/ +#else + fprintf(stderr,"%u\tinstance\n",startlineno); +#endif + } + ; + +defaultkey: DEFAULT { setstartlineno(); } + ; + +classkey: CLASS { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tclass\n",startlineno); +#endif + } + ; + +minuskey: MINUS { setstartlineno(); } + ; + +modulekey: MODULE { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tmodule\n",startlineno); +#endif + } + ; + +oparenkey: OPAREN { setstartlineno(); } + ; + +obrackkey: OBRACK { setstartlineno(); } + ; + +lazykey : LAZY { setstartlineno(); } + ; + + + +/* Non "-" op, used in right sections -- KH */ +op1 : conop + | varop1 + ; + +op : conop + | varop + ; + +varop : varsym + | BQUOTE VARID BQUOTE { $$ = $2; } + ; + +/* Non-minus varop, used in right sections */ +varop1 : VARSYM + | plus + | BQUOTE VARID BQUOTE { $$ = $2; } + ; + +conop : CONSYM + | BQUOTE CONID BQUOTE { $$ = $2; } + ; + +varsym : VARSYM + | plus + | minus + ; + +minus : MINUS { $$ = install_literal("-"); } + ; + +plus : PLUS { $$ = install_literal("+"); } + ; + +var : VARID + | OPAREN varsym CPAREN { $$ = $2; } + ; + +vark : VARID { setstartlineno(); $$ = $1; } + | oparenkey varsym CPAREN { $$ = $2; } + ; + +/* tycon used here to eliminate 11 spurious R/R errors -- KH */ +con : tycon + | OPAREN CONSYM CPAREN { $$ = $2; } + ; + +conk : tycon { setstartlineno(); $$ = $1; } + | oparenkey CONSYM CPAREN { $$ = $2; } + ; + +ccallid : VARID + | CONID + ; + +/* partain: "atype_list" must be at least 2 elements long (defn of "inst") */ +atype_list: atype COMMA atype { $$ = mklcons($1,lsing($3)); } + | atype COMMA atype_list { $$ = mklcons($1,$3); } + /* right recursion? WDP */ + ; + +tyvars : tyvar { $$ = lsing($1); } + | tyvars tyvar { $$ = lapp($1, $2); } + ; + +tyvar : VARID { $$ = mknamedtvar($1); } + ; + +tycls : tycon + /* partain: "aconid"->"tycon" got rid of a r/r conflict + (and introduced >= 2 s/r's ...) + */ + ; + +tycon : CONID + ; + +modid : CONID + ; + + +ocurly : layout OCURLY { hsincindent(); } + +vocurly : layout { hssetindent(); } + ; + +layout : { hsindentoff(); } + ; + +ccurly : + CCURLY + { + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + ; + +vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; } + ; + +vccurly1: + VCCURLY + { + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + | error + { + yyerrok; + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + ; + +%% + +/********************************************************************** +* * +* Error Processing and Reporting * +* * +* (This stuff is here in case we want to use Yacc macros and such.) * +* * +**********************************************************************/ + +/* The parser calls "hsperror" when it sees a + `report this and die' error. It sets the stage + and calls "yyerror". + + There should be no direct calls in the parser to + "yyerror", except for the one from "hsperror". Thus, + the only other calls will be from the error productions + introduced by yacc/bison/whatever. + + We need to be able to recognise the from-error-production + case, because we sometimes want to say, "Oh, never mind", + because the layout rule kicks into action and may save + the day. [WDP] +*/ + +static BOOLEAN error_and_I_mean_it = FALSE; + +void +hsperror(s) + char *s; +{ + error_and_I_mean_it = TRUE; + yyerror(s); +} + +void +yyerror(s) + char *s; +{ + extern char *yytext; + extern int yyleng; + + /* We want to be able to distinguish 'error'-raised yyerrors + from yyerrors explicitly coded by the parser hacker. + */ + if (expect_ccurly && ! error_and_I_mean_it ) { + /*NOTHING*/; + + } else { + fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ", + input_filename, hsplineno, hspcolno + 1, s); + + if (yyleng == 1 && *yytext == '\0') + fprintf(stderr, ""); + + else { + fputc('"', stderr); + format_string(stderr, (unsigned char *) yytext, yyleng); + fputc('"', stderr); + } + fputc('\n', stderr); + + /* a common problem */ + if (strcmp(yytext, "#") == 0) + fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n"); + + exit(1); + } +} + +void +format_string(fp, s, len) + FILE *fp; + unsigned char *s; + int len; +{ + while (len-- > 0) { + switch (*s) { + case '\0': fputs("\\NUL", fp); break; + case '\007': fputs("\\a", fp); break; + case '\010': fputs("\\b", fp); break; + case '\011': fputs("\\t", fp); break; + case '\012': fputs("\\n", fp); break; + case '\013': fputs("\\v", fp); break; + case '\014': fputs("\\f", fp); break; + case '\015': fputs("\\r", fp); break; + case '\033': fputs("\\ESC", fp); break; + case '\034': fputs("\\FS", fp); break; + case '\035': fputs("\\GS", fp); break; + case '\036': fputs("\\RS", fp); break; + case '\037': fputs("\\US", fp); break; + case '\177': fputs("\\DEL", fp); break; + default: + if (*s >= ' ') + fputc(*s, fp); + else + fprintf(fp, "\\^%c", *s + '@'); + break; + } + s++; + } +} diff --git a/ghc/compiler/yaccParser/hspincl.h b/ghc/compiler/yaccParser/hspincl.h new file mode 100644 index 0000000..b273957 --- /dev/null +++ b/ghc/compiler/yaccParser/hspincl.h @@ -0,0 +1,74 @@ +#ifndef HSPINCL_H +#define HSPINCL_H + +#include "../../includes/config.h" + +#if __STDC__ +#define PROTO(x) x +#define NO_ARGS void +#define CONST const +#define VOID void +#define VOID_STAR void * +#define VOLATILE volatile +#else +#define PROTO(x) () +#define NO_ARGS /* no args */ +#define CONST /* no const */ +#define VOID void /* hope for the best... */ +#define VOID_STAR long * +#define VOLATILE /* no volatile */ +#endif /* ! __STDC__ */ + +#if defined(STDC_HEADERS) || defined(HAVE_STRING_H) +#include +/* An ANSI string.h and pre-ANSI memory.h might conflict. */ +#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H) +#include +#endif /* not STDC_HEADERS and HAVE_MEMORY_H */ +#define index strchr +#define rindex strrchr +#define bcopy(s, d, n) memcpy ((d), (s), (n)) +#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n)) +#define bzero(s, n) memset ((s), 0, (n)) +#else /* not STDC_HEADERS and not HAVE_STRING_H */ +#include +/* memory.h and strings.h conflict on some systems. */ +#endif /* not STDC_HEADERS and not HAVE_STRING_H */ + +#ifdef HAVE_MALLOC_H +#include +#endif +#ifdef HAVE_STDLIB_H +#include +#endif + +#include "id.h" +#include "literal.h" +#include "list.h" +#ifdef DPH +#include "ttype-DPH.h" +#else +#include "ttype.h" +#endif +#include "atype.h" +#include "coresyn.h" +#include "hpragma.h" +#include "binding.h" +#include "finfot.h" +/*#include "impidt.h"*/ +#include "entidt.h" +#ifdef DPH +#include "tree-DPH.h" +#else +#define infixTree tree +#include "tree.h" +#endif +#include "pbinding.h" + +extern char *input_filename; + +extern tree *Rginfun PROTO((struct Sap *)); +extern tree *Rginarg1 PROTO((struct Sap *)); +extern tree *Rginarg2 PROTO((struct Sap *)); + +#endif /* HSPINCL_H */ diff --git a/ghc/compiler/yaccParser/id.c b/ghc/compiler/yaccParser/id.c new file mode 100644 index 0000000..0dfd419 --- /dev/null +++ b/ghc/compiler/yaccParser/id.c @@ -0,0 +1,286 @@ +/********************************************************************** +* * +* * +* Identifier Processing * +* * +* * +**********************************************************************/ + +#include + +#include "hspincl.h" +#include "constants.h" +#include "id.h" +#include "utils.h" + +/* partain: special version for strings that may have NULs (etc) in them +*/ +long +get_hstring_len(hs) + hstring hs; +{ + return(hs->len); +} + +char * +get_hstring_bytes(hs) + hstring hs; +{ + return(hs->bytes); +} + +hstring +installHstring(length, s) + int length; + char *s; +{ + char *p; + hstring str; + int i; + +/* fprintf(stderr, "installHstring: %d, %s\n",length, s); */ + + if (length > 999999) { /* too long */ + fprintf(stderr,"String length more than six digits\n"); + exit(1); + } else if (length < 0) { /* too short */ + fprintf(stderr,"String length < 0 !!\n"); + abort(); + } + + /* alloc the struct and store the length */ + str = (hstring) xmalloc(sizeof(Hstring)); + str->len = length; + + if (length == 0) { + str->bytes = NULL; + + } else { + p = xmalloc(length); + + /* now store the string */ + for (i = 0; i < length; i++) { + p[i] = s[i]; + } + str->bytes = p; + } + return str; +} + + +/********************************************************************** +* * +* * +* Hashed Identifiers * +* * +* * +**********************************************************************/ + + +extern BOOLEAN hashIds; /* Whether to use hashed ids. */ + +unsigned hash_table_size = HASH_TABLE_SIZE; + +static char **hashtab = NULL; + +static unsigned max_hash_table_entries = 0; + +void +hash_init() +{ + if(!hashIds) { + /*NOTHING*/; + + } else { + + /* Create an initialised hash table */ + hashtab = (char **) calloc( hash_table_size, sizeof(char *) ); + if(hashtab == NULL) + { + fprintf(stderr,"Cannot allocate a hash table with %d entries -- insufficient memory\n",hash_table_size); + exit(1); + } +#ifdef HSP_DEBUG + fprintf(stderr,"hashtab = %x\n",hashtab); +#endif + + /* Allow no more than 90% occupancy -- Divide first to avoid overflows with BIG tables! */ + max_hash_table_entries = (hash_table_size / 10) * 9; + } +} + +void +print_hash_table() +{ + if(hashIds) + { + unsigned i; + + printf("%u ",hash_table_size); + + for(i=0; i < hash_table_size; ++i) + if(hashtab[i] != NULL) + printf("(%u,%s) ",i,hashtab[i]); + } +} + + +long int +hash_index(ident) + id ident; +{ + return((char **) /* YURGH */ ident - hashtab); +} + + +/* + The hash function. Returns 0 for Null strings. +*/ + +static unsigned hash_fn(ident) +char *ident; +{ + unsigned len = (unsigned) strlen(ident); + unsigned res; + + if(*ident == '\0') + return( 0 ); + + /* does not work well for hash tables with more than 35K elements */ + res = (((unsigned)ident[0]*631)+((unsigned)ident[len/2-1]*217)+((unsigned)ident[len-1]*43)+len) + % hash_table_size; + +#ifdef HSP_DEBUG + fprintf(stderr,"\"%s\" hashes to %d\n",ident,res); +#endif + return(res); +} + + +/* + Install a literal identifier, such as "+" in hsparser. + If we are not using hashing, just return the string. +*/ + +id +install_literal(s) + char *s; +{ + return( hashIds? installid(s): s); +} + + +char * +id_to_string(sp) + id sp; +{ + return( hashIds? *(char **)sp: (char *)sp ); +} + +id +installid(s) + char *s; +{ + unsigned hash, count; + + if(!hashIds) + return(xstrdup(s)); + + for(hash = hash_fn(s),count=0; count= hash_table_size) hash = 0; + + if(hashtab[hash] == NULL) + { + hashtab[hash] = xstrdup(s); +#ifdef HSP_DEBUG + fprintf(stderr,"New Hash Entry %x\n",(char *)&hashtab[hash]); +#endif + if ( count >= 100 ) { + fprintf(stderr, "installid: %d collisions for %s\n", count, s); + } + + return((char *)&hashtab[hash]); + } + + if(strcmp(hashtab[hash],s) == 0) + { +#ifdef HSP_DEBUG + fprintf(stderr,"Old Hash Entry %x (%s)\n",(char *)&hashtab[hash],hashtab[hash]); +#endif + if ( count >= 100 ) { + fprintf(stderr, "installid: %d collisions for %s\n", count, s); + } + + return((char *)&hashtab[hash]); + } + } + fprintf(stderr,"Hash Table Contains more than %d entries -- make larger?\n",max_hash_table_entries); + exit(1); +} + + +/********************************************************************** +* * +* * +* Memory Allocation * +* * +* * +**********************************************************************/ + +/* Malloc with error checking */ + +char * +xmalloc(length) +unsigned length; +{ + char *stuff = malloc(length); + + if (stuff == NULL) { + fprintf(stderr, "xmalloc failed on a request for %d bytes\n", length); + exit(1); + } + return (stuff); +} + +char * +xrealloc(ptr, length) +char *ptr; +unsigned length; +{ + char *stuff = realloc(ptr, length); + + if (stuff == NULL) { + fprintf(stderr, "xrealloc failed on a request for %d bytes\n", length); + exit(1); + } + return (stuff); +} + +/* Strdup with error checking */ + +char * +xstrdup(s) +char *s; +{ + unsigned len = strlen(s); + return xstrndup(s, len); +} + +/* + * Strdup for possibly unterminated strings (e.g. substrings of longer strings) + * with error checking. Handles NULs as well. + */ + +char * +xstrndup(s, len) +char *s; +unsigned len; +{ + char *p = xmalloc(len + 1); + + bcopy(s, p, len); + p[len] = '\0'; + + return (p); +} diff --git a/ghc/compiler/yaccParser/id.h b/ghc/compiler/yaccParser/id.h new file mode 100644 index 0000000..b0fd009 --- /dev/null +++ b/ghc/compiler/yaccParser/id.h @@ -0,0 +1,15 @@ +#ifndef ID_H +#define ID_H + +typedef char *id; +typedef id unkId; /* synonym */ +typedef id stringId; /* synonym */ +typedef id numId; /* synonym, for now */ + +typedef struct { long len; char *bytes; } Hstring; +typedef Hstring *hstring; + +long get_hstring_len PROTO((hstring)); +char *get_hstring_bytes PROTO((hstring)); + +#endif diff --git a/ghc/compiler/yaccParser/impidt.c b/ghc/compiler/yaccParser/impidt.c new file mode 100644 index 0000000..08b55fa --- /dev/null +++ b/ghc/compiler/yaccParser/impidt.c @@ -0,0 +1,320 @@ + + +#include "hspincl.h" +#include "yaccParser/impidt.h" +Timpidt timpidt(t) + impidt t; +{ + return(t -> tag); +} + + +/************** impid ******************/ + +impidt mkimpid(PPgimpid, PPgimptype, PPgimpfinfo, PPgivline) + id PPgimpid; + ttype PPgimptype; + finfot PPgimpfinfo; + long PPgivline; +{ + register struct Simpid *pp = + (struct Simpid *) malloc(sizeof(struct Simpid)); + pp -> tag = impid; + pp -> Xgimpid = PPgimpid; + pp -> Xgimptype = PPgimptype; + pp -> Xgimpfinfo = PPgimpfinfo; + pp -> Xgivline = PPgivline; + return((impidt)pp); +} + +id *Rgimpid(t) + struct Simpid *t; +{ + if(t -> tag != impid) + fprintf(stderr,"gimpid: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpid); +} + +ttype *Rgimptype(t) + struct Simpid *t; +{ + if(t -> tag != impid) + fprintf(stderr,"gimptype: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimptype); +} + +finfot *Rgimpfinfo(t) + struct Simpid *t; +{ + if(t -> tag != impid) + fprintf(stderr,"gimpfinfo: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpfinfo); +} + +long *Rgivline(t) + struct Simpid *t; +{ + if(t -> tag != impid) + fprintf(stderr,"givline: illegal selection; was %d\n", t -> tag); + return(& t -> Xgivline); +} + +/************** imptype ******************/ + +impidt mkimptype(PPgimptypec, PPgimptypet, PPgimptyped, PPgitline) + list PPgimptypec; + ttype PPgimptypet; + list PPgimptyped; + long PPgitline; +{ + register struct Simptype *pp = + (struct Simptype *) malloc(sizeof(struct Simptype)); + pp -> tag = imptype; + pp -> Xgimptypec = PPgimptypec; + pp -> Xgimptypet = PPgimptypet; + pp -> Xgimptyped = PPgimptyped; + pp -> Xgitline = PPgitline; + return((impidt)pp); +} + +list *Rgimptypec(t) + struct Simptype *t; +{ + if(t -> tag != imptype) + fprintf(stderr,"gimptypec: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimptypec); +} + +ttype *Rgimptypet(t) + struct Simptype *t; +{ + if(t -> tag != imptype) + fprintf(stderr,"gimptypet: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimptypet); +} + +list *Rgimptyped(t) + struct Simptype *t; +{ + if(t -> tag != imptype) + fprintf(stderr,"gimptyped: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimptyped); +} + +long *Rgitline(t) + struct Simptype *t; +{ + if(t -> tag != imptype) + fprintf(stderr,"gitline: illegal selection; was %d\n", t -> tag); + return(& t -> Xgitline); +} + +/************** impsyn ******************/ + +impidt mkimpsyn(PPgimpsynti, PPgimpsynts, PPgisline) + ttype PPgimpsynti; + ttype PPgimpsynts; + long PPgisline; +{ + register struct Simpsyn *pp = + (struct Simpsyn *) malloc(sizeof(struct Simpsyn)); + pp -> tag = impsyn; + pp -> Xgimpsynti = PPgimpsynti; + pp -> Xgimpsynts = PPgimpsynts; + pp -> Xgisline = PPgisline; + return((impidt)pp); +} + +ttype *Rgimpsynti(t) + struct Simpsyn *t; +{ + if(t -> tag != impsyn) + fprintf(stderr,"gimpsynti: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpsynti); +} + +ttype *Rgimpsynts(t) + struct Simpsyn *t; +{ + if(t -> tag != impsyn) + fprintf(stderr,"gimpsynts: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpsynts); +} + +long *Rgisline(t) + struct Simpsyn *t; +{ + if(t -> tag != impsyn) + fprintf(stderr,"gisline: illegal selection; was %d\n", t -> tag); + return(& t -> Xgisline); +} + +/************** impeqtype ******************/ + +impidt mkimpeqtype(PPgimpeqtype) + binding PPgimpeqtype; +{ + register struct Simpeqtype *pp = + (struct Simpeqtype *) malloc(sizeof(struct Simpeqtype)); + pp -> tag = impeqtype; + pp -> Xgimpeqtype = PPgimpeqtype; + return((impidt)pp); +} + +binding *Rgimpeqtype(t) + struct Simpeqtype *t; +{ + if(t -> tag != impeqtype) + fprintf(stderr,"gimpeqtype: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpeqtype); +} + +/************** impclass ******************/ + +impidt mkimpclass(PPgimpclassc, PPgimpclasst, PPgimpclassw, PPgicline) + list PPgimpclassc; + ttype PPgimpclasst; + list PPgimpclassw; + long PPgicline; +{ + register struct Simpclass *pp = + (struct Simpclass *) malloc(sizeof(struct Simpclass)); + pp -> tag = impclass; + pp -> Xgimpclassc = PPgimpclassc; + pp -> Xgimpclasst = PPgimpclasst; + pp -> Xgimpclassw = PPgimpclassw; + pp -> Xgicline = PPgicline; + return((impidt)pp); +} + +list *Rgimpclassc(t) + struct Simpclass *t; +{ + if(t -> tag != impclass) + fprintf(stderr,"gimpclassc: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpclassc); +} + +ttype *Rgimpclasst(t) + struct Simpclass *t; +{ + if(t -> tag != impclass) + fprintf(stderr,"gimpclasst: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpclasst); +} + +list *Rgimpclassw(t) + struct Simpclass *t; +{ + if(t -> tag != impclass) + fprintf(stderr,"gimpclassw: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpclassw); +} + +long *Rgicline(t) + struct Simpclass *t; +{ + if(t -> tag != impclass) + fprintf(stderr,"gicline: illegal selection; was %d\n", t -> tag); + return(& t -> Xgicline); +} + +/************** impinst ******************/ + +impidt mkimpinst(PPgimpinstc, PPgimpinstid, PPgimpinstt, PPgiiline) + list PPgimpinstc; + id PPgimpinstid; + ttype PPgimpinstt; + long PPgiiline; +{ + register struct Simpinst *pp = + (struct Simpinst *) malloc(sizeof(struct Simpinst)); + pp -> tag = impinst; + pp -> Xgimpinstc = PPgimpinstc; + pp -> Xgimpinstid = PPgimpinstid; + pp -> Xgimpinstt = PPgimpinstt; + pp -> Xgiiline = PPgiiline; + return((impidt)pp); +} + +list *Rgimpinstc(t) + struct Simpinst *t; +{ + if(t -> tag != impinst) + fprintf(stderr,"gimpinstc: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpinstc); +} + +id *Rgimpinstid(t) + struct Simpinst *t; +{ + if(t -> tag != impinst) + fprintf(stderr,"gimpinstid: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpinstid); +} + +ttype *Rgimpinstt(t) + struct Simpinst *t; +{ + if(t -> tag != impinst) + fprintf(stderr,"gimpinstt: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpinstt); +} + +long *Rgiiline(t) + struct Simpinst *t; +{ + if(t -> tag != impinst) + fprintf(stderr,"giiline: illegal selection; was %d\n", t -> tag); + return(& t -> Xgiiline); +} + +/************** impmod ******************/ + +impidt mkimpmod(PPgimpmodn, PPgimpmodimp, PPgimpmodren, PPgimline) + id PPgimpmodn; + list PPgimpmodimp; + list PPgimpmodren; + long PPgimline; +{ + register struct Simpmod *pp = + (struct Simpmod *) malloc(sizeof(struct Simpmod)); + pp -> tag = impmod; + pp -> Xgimpmodn = PPgimpmodn; + pp -> Xgimpmodimp = PPgimpmodimp; + pp -> Xgimpmodren = PPgimpmodren; + pp -> Xgimline = PPgimline; + return((impidt)pp); +} + +id *Rgimpmodn(t) + struct Simpmod *t; +{ + if(t -> tag != impmod) + fprintf(stderr,"gimpmodn: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpmodn); +} + +list *Rgimpmodimp(t) + struct Simpmod *t; +{ + if(t -> tag != impmod) + fprintf(stderr,"gimpmodimp: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpmodimp); +} + +list *Rgimpmodren(t) + struct Simpmod *t; +{ + if(t -> tag != impmod) + fprintf(stderr,"gimpmodren: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimpmodren); +} + +long *Rgimline(t) + struct Simpmod *t; +{ + if(t -> tag != impmod) + fprintf(stderr,"gimline: illegal selection; was %d\n", t -> tag); + return(& t -> Xgimline); +} diff --git a/ghc/compiler/yaccParser/impidt.h b/ghc/compiler/yaccParser/impidt.h new file mode 100644 index 0000000..0c27c78 --- /dev/null +++ b/ghc/compiler/yaccParser/impidt.h @@ -0,0 +1,143 @@ +#ifndef impidt_defined +#define impidt_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + impid, + imptype, + impsyn, + impeqtype, + impclass, + impinst, + impmod +} Timpidt; + +typedef struct { Timpidt tag; } *impidt; + +/* Compatibility defines */ +extern Timpidt timpidt PROTO((impidt)); + +struct Simpid { + Timpidt tag; + id Xgimpid; + ttype Xgimptype; + finfot Xgimpfinfo; + long Xgivline; +}; + +struct Simptype { + Timpidt tag; + list Xgimptypec; + ttype Xgimptypet; + list Xgimptyped; + long Xgitline; +}; + +struct Simpsyn { + Timpidt tag; + ttype Xgimpsynti; + ttype Xgimpsynts; + long Xgisline; +}; + +struct Simpeqtype { + Timpidt tag; + binding Xgimpeqtype; +}; + +struct Simpclass { + Timpidt tag; + list Xgimpclassc; + ttype Xgimpclasst; + list Xgimpclassw; + long Xgicline; +}; + +struct Simpinst { + Timpidt tag; + list Xgimpinstc; + id Xgimpinstid; + ttype Xgimpinstt; + long Xgiiline; +}; + +struct Simpmod { + Timpidt tag; + id Xgimpmodn; + list Xgimpmodimp; + list Xgimpmodren; + long Xgimline; +}; + +#endif +extern impidt mkimpid PROTO((id, ttype, finfot, long)); +extern id *Rgimpid PROTO((struct Simpid *)); +#define gimpid(xyzxyz) (*Rgimpid((struct Simpid *) (xyzxyz))) +extern ttype *Rgimptype PROTO((struct Simpid *)); +#define gimptype(xyzxyz) (*Rgimptype((struct Simpid *) (xyzxyz))) +extern finfot *Rgimpfinfo PROTO((struct Simpid *)); +#define gimpfinfo(xyzxyz) (*Rgimpfinfo((struct Simpid *) (xyzxyz))) +extern long *Rgivline PROTO((struct Simpid *)); +#define givline(xyzxyz) (*Rgivline((struct Simpid *) (xyzxyz))) + +extern impidt mkimptype PROTO((list, ttype, list, long)); +extern list *Rgimptypec PROTO((struct Simptype *)); +#define gimptypec(xyzxyz) (*Rgimptypec((struct Simptype *) (xyzxyz))) +extern ttype *Rgimptypet PROTO((struct Simptype *)); +#define gimptypet(xyzxyz) (*Rgimptypet((struct Simptype *) (xyzxyz))) +extern list *Rgimptyped PROTO((struct Simptype *)); +#define gimptyped(xyzxyz) (*Rgimptyped((struct Simptype *) (xyzxyz))) +extern long *Rgitline PROTO((struct Simptype *)); +#define gitline(xyzxyz) (*Rgitline((struct Simptype *) (xyzxyz))) + +extern impidt mkimpsyn PROTO((ttype, ttype, long)); +extern ttype *Rgimpsynti PROTO((struct Simpsyn *)); +#define gimpsynti(xyzxyz) (*Rgimpsynti((struct Simpsyn *) (xyzxyz))) +extern ttype *Rgimpsynts PROTO((struct Simpsyn *)); +#define gimpsynts(xyzxyz) (*Rgimpsynts((struct Simpsyn *) (xyzxyz))) +extern long *Rgisline PROTO((struct Simpsyn *)); +#define gisline(xyzxyz) (*Rgisline((struct Simpsyn *) (xyzxyz))) + +extern impidt mkimpeqtype PROTO((binding)); +extern binding *Rgimpeqtype PROTO((struct Simpeqtype *)); +#define gimpeqtype(xyzxyz) (*Rgimpeqtype((struct Simpeqtype *) (xyzxyz))) + +extern impidt mkimpclass PROTO((list, ttype, list, long)); +extern list *Rgimpclassc PROTO((struct Simpclass *)); +#define gimpclassc(xyzxyz) (*Rgimpclassc((struct Simpclass *) (xyzxyz))) +extern ttype *Rgimpclasst PROTO((struct Simpclass *)); +#define gimpclasst(xyzxyz) (*Rgimpclasst((struct Simpclass *) (xyzxyz))) +extern list *Rgimpclassw PROTO((struct Simpclass *)); +#define gimpclassw(xyzxyz) (*Rgimpclassw((struct Simpclass *) (xyzxyz))) +extern long *Rgicline PROTO((struct Simpclass *)); +#define gicline(xyzxyz) (*Rgicline((struct Simpclass *) (xyzxyz))) + +extern impidt mkimpinst PROTO((list, id, ttype, long)); +extern list *Rgimpinstc PROTO((struct Simpinst *)); +#define gimpinstc(xyzxyz) (*Rgimpinstc((struct Simpinst *) (xyzxyz))) +extern id *Rgimpinstid PROTO((struct Simpinst *)); +#define gimpinstid(xyzxyz) (*Rgimpinstid((struct Simpinst *) (xyzxyz))) +extern ttype *Rgimpinstt PROTO((struct Simpinst *)); +#define gimpinstt(xyzxyz) (*Rgimpinstt((struct Simpinst *) (xyzxyz))) +extern long *Rgiiline PROTO((struct Simpinst *)); +#define giiline(xyzxyz) (*Rgiiline((struct Simpinst *) (xyzxyz))) + +extern impidt mkimpmod PROTO((id, list, list, long)); +extern id *Rgimpmodn PROTO((struct Simpmod *)); +#define gimpmodn(xyzxyz) (*Rgimpmodn((struct Simpmod *) (xyzxyz))) +extern list *Rgimpmodimp PROTO((struct Simpmod *)); +#define gimpmodimp(xyzxyz) (*Rgimpmodimp((struct Simpmod *) (xyzxyz))) +extern list *Rgimpmodren PROTO((struct Simpmod *)); +#define gimpmodren(xyzxyz) (*Rgimpmodren((struct Simpmod *) (xyzxyz))) +extern long *Rgimline PROTO((struct Simpmod *)); +#define gimline(xyzxyz) (*Rgimline((struct Simpmod *) (xyzxyz))) + diff --git a/ghc/compiler/yaccParser/import_dirlist.c b/ghc/compiler/yaccParser/import_dirlist.c new file mode 100644 index 0000000..dc0eaec --- /dev/null +++ b/ghc/compiler/yaccParser/import_dirlist.c @@ -0,0 +1,224 @@ +/********************************************************************** +* * +* * +* Import Directory List Handling * +* * +* * +**********************************************************************/ + +#include + +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +#ifdef HAVE_UNISTD_H +#include +#endif + +#ifdef HAVE_SYS_TYPES_H +#include +#else +#ifdef HAVE_TYPES_H +#include +#endif +#endif + +#ifdef HAVE_SYS_STAT_H +#include +#endif + +#ifdef HAVE_SYS_FILE_H +#include +#endif + +#ifndef HAVE_ACCESS +#define R_OK "r" +#define F_OK "r" +short +access(const char *fileName, const char *mode) +{ + FILE *fp = fopen(fileName, mode); + if (fp != NULL) { + (VOID) fclose(fp); + return 0; + } + return 1; +} +#endif /* HAVE_ACCESS */ + + +list imports_dirlist, sys_imports_dirlist; /* The imports lists */ +extern char HiSuffix[]; +extern char PreludeHiSuffix[]; +extern BOOLEAN ExplicitHiSuffixGiven; + +#define MAX_MATCH 16 + +/* + This finds a module along the imports directory list. +*/ + +VOID +find_module_on_imports_dirlist(module_name, is_sys_import, returned_filename) + char *module_name; + BOOLEAN is_sys_import; + char *returned_filename; +{ + char try[FILENAME_SIZE]; + + list imports_dirs; + +#ifdef HAVE_STAT + struct stat sbuf[MAX_MATCH]; +#endif + + int no_of_matches = 0; + BOOLEAN tried_source_dir = FALSE; + + char *try_end; + char *suffix_to_use = (is_sys_import) ? PreludeHiSuffix : HiSuffix; + int modname_len = strlen(module_name); + + /* + Check every directory in (sys_)imports_dirlist for the imports file. + The first directory in the list is the source directory. + */ + for (imports_dirs = (is_sys_import) ? sys_imports_dirlist : imports_dirlist; + tlist(imports_dirs) == lcons; + imports_dirs = ltl(imports_dirs)) + { + char *dir = (char *) lhd(imports_dirs); + strcpy(try, dir); + + try_end = try + strlen(try); + +#ifdef macintosh /* ToDo: use DIR_SEP_CHAR */ + if (*(try_end - 1) != ':') + strcpy (try_end++, ":"); +#else + if (*(try_end - 1) != '/') + strcpy (try_end++, "/"); +#endif /* ! macintosh */ + + strcpy(try_end, module_name); + + strcpy(try_end+modname_len, suffix_to_use); + + /* See whether the file exists and is readable. */ + if (access (try,R_OK) == 0) + { + if ( no_of_matches == 0 ) + strcpy(returned_filename, try); + + /* Return as soon as a match is found in the source directory. */ + if (!tried_source_dir) + return; + +#ifdef HAVE_STAT + if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 ) + { + int i; + for (i = 0; i < no_of_matches; i++) + { + if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev && + sbuf[no_of_matches].st_ino == sbuf[i].st_ino) + goto next; /* Skip dups */ + } + } +#endif /* HAVE_STAT */ + no_of_matches++; + } + else if (access (try,F_OK) == 0) + fprintf(stderr,"Warning: %s exists, but is not readable\n",try); + + next: + tried_source_dir = TRUE; + } + + if ( no_of_matches == 0 && ! is_sys_import ) { /* Nothing so far */ + + /* If we are explicitly meddling about with .hi suffixes, + then some system-supplied modules may need to be looked + for with PreludeHiSuffix; unsavoury but true... + */ + suffix_to_use = PreludeHiSuffix; + + for (imports_dirs = sys_imports_dirlist; + tlist(imports_dirs) == lcons; + imports_dirs = ltl(imports_dirs)) + { + char *dir = (char *) lhd(imports_dirs); + strcpy(try, dir); + + try_end = try + strlen(try); + +#ifdef macintosh /* ToDo: use DIR_SEP_STRING */ + if (*(try_end - 1) != ':') + strcpy (try_end++, ":"); +#else + if (*(try_end - 1) != '/') + strcpy (try_end++, "/"); +#endif /* ! macintosh */ + + strcpy(try_end, module_name); + + strcpy(try_end+modname_len, suffix_to_use); + + /* See whether the file exists and is readable. */ + if (access (try,R_OK) == 0) + { + if ( no_of_matches == 0 ) + strcpy(returned_filename, try); + +#ifdef HAVE_STAT + if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 ) + { + int i; + for (i = 0; i < no_of_matches; i++) + { + if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev && + sbuf[no_of_matches].st_ino == sbuf[i].st_ino) + goto next_again; /* Skip dups */ + } + } +#endif /* HAVE_STAT */ + no_of_matches++; + } + else if (access (try,F_OK) == 0) + fprintf(stderr,"Warning: %s exists, but is not readable\n",try); + next_again: + /*NOTHING*/; + } + } + + /* Error checking */ + + switch ( no_of_matches ) { + default: + fprintf(stderr,"Warning: found %d %s files for module \"%s\"\n", + no_of_matches, suffix_to_use, module_name); + break; + case 0: + { + char disaster_msg[MODNAME_SIZE+1000]; + sprintf(disaster_msg,"can't find interface (%s) file for module \"%s\"%s", + suffix_to_use, module_name, + (strncmp(module_name, "PreludeGlaIO", 12) == 0) + ? "\n(The PreludeGlaIO interface no longer exists);" + :( + (strncmp(module_name, "PreludePrimIO", 13) == 0) + ? "\n(The PreludePrimIO interface no longer exists -- just use PreludeGlaST);" + :( + (strncmp(module_name, "Prelude", 7) == 0) + ? "\n(Perhaps you forgot a `-fglasgow-exts' flag?);" + : "" + ))); + hsperror(disaster_msg); + break; + } + case 1: + /* Everything is fine */ + break; + } +} diff --git a/ghc/compiler/yaccParser/infix.c b/ghc/compiler/yaccParser/infix.c new file mode 100644 index 0000000..d53131b --- /dev/null +++ b/ghc/compiler/yaccParser/infix.c @@ -0,0 +1,260 @@ +/* + * Infix operator stuff -- modified from LML + */ + +#include + +#include "hspincl.h" +#ifdef DPH +#include "hsparser-DPH.tab.h" +#else +#include "hsparser.tab.h" +#endif +#include "constants.h" +#include "utils.h" + +static short iscope = 1; + +static struct infix { + char *iname; + short ilen; + short ifixity; + short iprecedence; +} infixtab[INFIX_SCOPES][MAX_INFIX] = + { + /* + Name Len Fixity Precedence + */ + "$", 1, INFIXR, 0, + ":=", 2, INFIX, 1, + "||", 2, INFIXR, 2, + "&&", 2, INFIXR, 3, + "==", 2, INFIX, 4, + "/=", 2, INFIX, 4, + "<", 1, INFIX, 4, + "<=", 2, INFIX, 4, + ">", 1, INFIX, 4, + ">=", 2, INFIX, 4, + "elem", 4, INFIX, 4, + "notElem", 7, INFIX, 4, + "\\\\", 2, INFIX, 5, + ":", 1, INFIXR, 5, + "++", 2, INFIXR, 5, + "+", 1, INFIXL, 6, + "-", 1, INFIXL, 6, + ":+", 2, INFIX, 6, + "*", 1, INFIXL, 7, + "/", 1, INFIXL, 7, + "mod", 3, INFIXL, 7, + "div", 3, INFIXL, 7, + "rem", 3, INFIXL, 7, + "quot", 4, INFIXL, 7, + ":%", 2, INFIXL, 7, /* possibly wrong; should be omitted? */ + "%", 1, INFIXL, 7, + "**", 2, INFIXR, 8, + "^", 1, INFIXR, 8, + "^^", 2, INFIXR, 8, + "!", 1, INFIXL, 9, + "!!", 2, INFIXL, 9, + "//", 2, INFIXL, 9, + ".", 1, INFIXR, 9 +}; + + +#define NFIX 31 /* The number of predefined operators */ +#define ninfix (ninfixtab[iscope]) +static int ninfixtab[INFIX_SCOPES] = {NFIX,0}; /* # of predefined operators */ +static char infixstr[MAX_ISTR]; +static char *infixp = infixstr; + +/* An "iscope" is an "infix scope": the scope of infix declarations + (either the main module or an interface) */ + +void +enteriscope() +{ + if(++iscope > INFIX_SCOPES) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"Too many infix scopes (> %d)\n",INFIX_SCOPES); + } + ninfix = 0; +} + +void +exitiscope() +{ + --iscope; +} + +void +exposeis() +{ + int i; + --iscope; + + for (i=0; i < ninfixtab[iscope+1]; ++i) + { + struct infix *ip = infixtab[iscope+1] + i; + makeinfix(install_literal(ip->iname),ip->ifixity,ip->iprecedence); + } +} + + +static int +ionelookup(name,iscope) + id name; + int iscope; +{ + int i; + char *iname = id_to_string(name); + + for(i = 0; i < ninfixtab[iscope]; i++) + { + if(strcmp(iname,infixtab[iscope][i].iname)==0) + return(i); + } + + return(-1); +} + + +struct infix * +infixlookup(name) + id name; +{ + int i; + for (i=iscope; i >= 0; --i) + { + int n = ionelookup(name,i); + if (n >= 0) + return (infixtab[i]+n); + } + return (NULL); +} + +int +nfixes() +{ + return ninfix; +} + +char * +fixop(n) + int n; +{ + return infixtab[iscope][n].iname; +} + +char * +fixtype(n) + int n; +{ + switch(infixtab[iscope][n].ifixity) { + case INFIXL: + return "infixl"; + + case INFIXR: + return "infixr"; + + case INFIX: + return "infix"; + + default : return 0; + /* Why might it return 0 ?? (WDP 94/11) */ + } +} + + +int +fixity(n) + int n; +{ +#ifdef HSP_DEBUG + fprintf(stderr,"fixity of %s (at %d) is %d\n",infixtab[iscope][n].iname,n,infixtab[iscope][n].ifixity); +#endif + return(n < 0? INFIXL: infixtab[iscope][n].ifixity); +} + + +long int +precedence(n) + int n; +{ +#ifdef HSP_DEBUG + fprintf(stderr,"precedence of %s (at %d) is %d\n",infixtab[iscope][n].iname,n,infixtab[iscope][n].iprecedence); +#endif + return(n < 0? 9: infixtab[iscope][n].iprecedence); +} + + +int +pfixity(ip) + struct infix *ip; +{ +#ifdef HSP_DEBUG + fprintf(stderr,"fixity of %s is %d\n",ip->iname,ip->ifixity); +#endif + return(ip == NULL? INFIXL: ip->ifixity); +} + +int +pprecedence(ip) + struct infix *ip; +{ +#ifdef HSP_DEBUG + fprintf(stderr,"precedence of %s (at %d) is %d\n",ip->iname,ip->iprecedence); +#endif + return(ip == NULL? 9: ip->iprecedence); +} + + +void +makeinfix(ssi, fixity, precedence) + id ssi; + int fixity, precedence; +{ + register int i, l; + char s[1000]; + char *ss = id_to_string(ssi); + + for(i=0; i < ninfix; ++i) + { + if(strcmp(ss,infixtab[iscope][i].iname)==0) + { + /* Allow duplicate definitions if they are identical */ + if(infixtab[iscope][i].ifixity!=fixity || + infixtab[iscope][i].iprecedence!=precedence ) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"(%s) already declared to be %s %d\n", + ss, + fixtype(i), + infixtab[iscope][i].iprecedence); + hsperror(errbuf); + } + return; + } + } + + strcpy(s, ss); + l = strlen(s); + s[l] = 0; + + if (ninfix >= MAX_INFIX || infixp+l+1 >= &infixstr[MAX_ISTR]) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"Too many Infix identifiers (> %d)",MAX_INFIX); + hsperror(errbuf); + } + +#ifdef HSP_DEBUG + fprintf(stderr,"adding %s (was %s), fixity=%d, prec=%d\n",s,ss,fixity,precedence); +#endif + infixtab[iscope][ninfix].iname = infixp; + strcpy(infixp, s); + infixp += l+1; + infixtab[iscope][ninfix].ifixity = fixity; + infixtab[iscope][ninfix].iprecedence = precedence; + infixtab[iscope][ninfix].ilen = l-1; + ninfix++; +} diff --git a/ghc/compiler/yaccParser/list.c b/ghc/compiler/yaccParser/list.c new file mode 100644 index 0000000..73ce725 --- /dev/null +++ b/ghc/compiler/yaccParser/list.c @@ -0,0 +1,55 @@ + + +#include "hspincl.h" +#include "yaccParser/list.h" + +Tlist tlist(t) + list t; +{ + return(t -> tag); +} + + +/************** lcons ******************/ + +list mklcons(PPlhd, PPltl) + VOID_STAR PPlhd; + list PPltl; +{ + register struct Slcons *pp = + (struct Slcons *) malloc(sizeof(struct Slcons)); + pp -> tag = lcons; + pp -> Xlhd = PPlhd; + pp -> Xltl = PPltl; + return((list)pp); +} + +VOID_STAR *Rlhd(t) + struct Slcons *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lcons) + fprintf(stderr,"lhd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xlhd); +} + +list *Rltl(t) + struct Slcons *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lcons) + fprintf(stderr,"ltl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xltl); +} + +/************** lnil ******************/ + +list mklnil() +{ + register struct Slnil *pp = + (struct Slnil *) malloc(sizeof(struct Slnil)); + pp -> tag = lnil; + return((list)pp); +} diff --git a/ghc/compiler/yaccParser/list.h b/ghc/compiler/yaccParser/list.h new file mode 100644 index 0000000..2eefe33 --- /dev/null +++ b/ghc/compiler/yaccParser/list.h @@ -0,0 +1,74 @@ +#ifndef list_defined +#define list_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + lcons, + lnil +} Tlist; + +typedef struct { Tlist tag; } *list; + +#ifdef __GNUC__ +extern __inline__ Tlist tlist(list t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tlist tlist PROTO((list)); +#endif /* ! __GNUC__ */ + +struct Slcons { + Tlist tag; + VOID_STAR Xlhd; + list Xltl; +}; + +struct Slnil { + Tlist tag; +}; + +extern list mklcons PROTO((VOID_STAR, list)); +#ifdef __GNUC__ + +extern __inline__ VOID_STAR *Rlhd(struct Slcons *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lcons) + fprintf(stderr,"lhd: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xlhd); +} +#else /* ! __GNUC__ */ +extern VOID_STAR *Rlhd PROTO((struct Slcons *)); +#endif /* ! __GNUC__ */ + +#define lhd(xyzxyz) (*Rlhd((struct Slcons *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rltl(struct Slcons *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lcons) + fprintf(stderr,"ltl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xltl); +} +#else /* ! __GNUC__ */ +extern list *Rltl PROTO((struct Slcons *)); +#endif /* ! __GNUC__ */ + +#define ltl(xyzxyz) (*Rltl((struct Slcons *) (xyzxyz))) + +extern list mklnil PROTO(()); + +#endif diff --git a/ghc/compiler/yaccParser/list.ugn b/ghc/compiler/yaccParser/list.ugn new file mode 100644 index 0000000..3606f20 --- /dev/null +++ b/ghc/compiler/yaccParser/list.ugn @@ -0,0 +1,13 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_list where +import UgenUtil +import Util +%}} +type list; + lcons : < lhd : VOID_STAR; + ltl : list; >; + lnil : <>; +end; diff --git a/ghc/compiler/yaccParser/listcomp.c b/ghc/compiler/yaccParser/listcomp.c new file mode 100644 index 0000000..6258869 --- /dev/null +++ b/ghc/compiler/yaccParser/listcomp.c @@ -0,0 +1,67 @@ +/* + Implementation of optimally compiled list comprehensions using Wadler's algorithm from + Peyton-Jones "Implementation of Functional Programming Languages", 1987 + + TQ transforms a list of qualifiers (either boolean expressions or generators) into a + single expression which implements the list comprehension. + + TE << [E || Q] >> = TQ << [E || Q] ++ [] >> + + TQ << [E || p <- L1, Q] ++ L2 >> = + + h ( TE << L1 >> ) where + h = us -> case us in + [] -> TE << L2 >> + (u : us') -> + (TE << p >> -> ( TQ << [E || Q] ++ (h us') >> )) u + */ + +tree TQ(quals,l2) +list quals, l2; +{ + tree qualh; + list rest; + + if(tlist(quals) == lnil) + return(mkcons(zfexpr,l2)); + + qualh = (tree) lhd(quals); + rest = ltl(quals); + + if(ttree(qualh) != qual) + return(mkif(qualh,TQ(rest,l2),l2)); + + { + tree h = mkident(uniqueident("Zh%d")), + u = mkident(uniqueident("Iu%d")), + us = mkident(uniqueident("Ius%d")), + pat = gqpat(qualh); + + pbinding tq = mkppat(gqpat(qualh),TQ(rest,mkap(h,us))); + + + return( + mkletv( + mkrbind( + mkpbind( + lsing( + mkppat(h, + mklam(us, + mkcasee(us, + ldub( + mkppat(niltree,l2), + mkppat( + mkcons(u,us), + mkcasee(u,lsing(tq)) +/* + replaces the following code which elides patterns in list comprehensions a la M*****a + + mkcasee(u, + ttree(pat) == ident && !isconstr(gident(pat))? + lsing(tq): + ldub(tq,mkppat(mkident("_"),mkap(h,us)))) +*/ + )))))))), + mkap(h,gqexp(qualh)))); + } +} diff --git a/ghc/compiler/yaccParser/literal.c b/ghc/compiler/yaccParser/literal.c new file mode 100644 index 0000000..509db3a --- /dev/null +++ b/ghc/compiler/yaccParser/literal.c @@ -0,0 +1,321 @@ + + +#include "hspincl.h" +#include "yaccParser/literal.h" + +Tliteral tliteral(t) + literal t; +{ + return(t -> tag); +} + + +/************** integer ******************/ + +literal mkinteger(PPginteger) + stringId PPginteger; +{ + register struct Sinteger *pp = + (struct Sinteger *) malloc(sizeof(struct Sinteger)); + pp -> tag = integer; + pp -> Xginteger = PPginteger; + return((literal)pp); +} + +stringId *Rginteger(t) + struct Sinteger *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != integer) + fprintf(stderr,"ginteger: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginteger); +} + +/************** intprim ******************/ + +literal mkintprim(PPgintprim) + stringId PPgintprim; +{ + register struct Sintprim *pp = + (struct Sintprim *) malloc(sizeof(struct Sintprim)); + pp -> tag = intprim; + pp -> Xgintprim = PPgintprim; + return((literal)pp); +} + +stringId *Rgintprim(t) + struct Sintprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != intprim) + fprintf(stderr,"gintprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgintprim); +} + +/************** floatr ******************/ + +literal mkfloatr(PPgfloatr) + stringId PPgfloatr; +{ + register struct Sfloatr *pp = + (struct Sfloatr *) malloc(sizeof(struct Sfloatr)); + pp -> tag = floatr; + pp -> Xgfloatr = PPgfloatr; + return((literal)pp); +} + +stringId *Rgfloatr(t) + struct Sfloatr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != floatr) + fprintf(stderr,"gfloatr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfloatr); +} + +/************** doubleprim ******************/ + +literal mkdoubleprim(PPgdoubleprim) + stringId PPgdoubleprim; +{ + register struct Sdoubleprim *pp = + (struct Sdoubleprim *) malloc(sizeof(struct Sdoubleprim)); + pp -> tag = doubleprim; + pp -> Xgdoubleprim = PPgdoubleprim; + return((literal)pp); +} + +stringId *Rgdoubleprim(t) + struct Sdoubleprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != doubleprim) + fprintf(stderr,"gdoubleprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdoubleprim); +} + +/************** floatprim ******************/ + +literal mkfloatprim(PPgfloatprim) + stringId PPgfloatprim; +{ + register struct Sfloatprim *pp = + (struct Sfloatprim *) malloc(sizeof(struct Sfloatprim)); + pp -> tag = floatprim; + pp -> Xgfloatprim = PPgfloatprim; + return((literal)pp); +} + +stringId *Rgfloatprim(t) + struct Sfloatprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != floatprim) + fprintf(stderr,"gfloatprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfloatprim); +} + +/************** charr ******************/ + +literal mkcharr(PPgchar) + hstring PPgchar; +{ + register struct Scharr *pp = + (struct Scharr *) malloc(sizeof(struct Scharr)); + pp -> tag = charr; + pp -> Xgchar = PPgchar; + return((literal)pp); +} + +hstring *Rgchar(t) + struct Scharr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != charr) + fprintf(stderr,"gchar: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgchar); +} + +/************** charprim ******************/ + +literal mkcharprim(PPgcharprim) + hstring PPgcharprim; +{ + register struct Scharprim *pp = + (struct Scharprim *) malloc(sizeof(struct Scharprim)); + pp -> tag = charprim; + pp -> Xgcharprim = PPgcharprim; + return((literal)pp); +} + +hstring *Rgcharprim(t) + struct Scharprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != charprim) + fprintf(stderr,"gcharprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcharprim); +} + +/************** string ******************/ + +literal mkstring(PPgstring) + hstring PPgstring; +{ + register struct Sstring *pp = + (struct Sstring *) malloc(sizeof(struct Sstring)); + pp -> tag = string; + pp -> Xgstring = PPgstring; + return((literal)pp); +} + +hstring *Rgstring(t) + struct Sstring *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != string) + fprintf(stderr,"gstring: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgstring); +} + +/************** stringprim ******************/ + +literal mkstringprim(PPgstringprim) + hstring PPgstringprim; +{ + register struct Sstringprim *pp = + (struct Sstringprim *) malloc(sizeof(struct Sstringprim)); + pp -> tag = stringprim; + pp -> Xgstringprim = PPgstringprim; + return((literal)pp); +} + +hstring *Rgstringprim(t) + struct Sstringprim *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != stringprim) + fprintf(stderr,"gstringprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgstringprim); +} + +/************** clitlit ******************/ + +literal mkclitlit(PPgclitlit, PPgclitlit_kind) + stringId PPgclitlit; + stringId PPgclitlit_kind; +{ + register struct Sclitlit *pp = + (struct Sclitlit *) malloc(sizeof(struct Sclitlit)); + pp -> tag = clitlit; + pp -> Xgclitlit = PPgclitlit; + pp -> Xgclitlit_kind = PPgclitlit_kind; + return((literal)pp); +} + +stringId *Rgclitlit(t) + struct Sclitlit *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != clitlit) + fprintf(stderr,"gclitlit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgclitlit); +} + +stringId *Rgclitlit_kind(t) + struct Sclitlit *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != clitlit) + fprintf(stderr,"gclitlit_kind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgclitlit_kind); +} + +/************** norepi ******************/ + +literal mknorepi(PPgnorepi) + stringId PPgnorepi; +{ + register struct Snorepi *pp = + (struct Snorepi *) malloc(sizeof(struct Snorepi)); + pp -> tag = norepi; + pp -> Xgnorepi = PPgnorepi; + return((literal)pp); +} + +stringId *Rgnorepi(t) + struct Snorepi *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != norepi) + fprintf(stderr,"gnorepi: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnorepi); +} + +/************** norepr ******************/ + +literal mknorepr(PPgnorepr_n, PPgnorepr_d) + stringId PPgnorepr_n; + stringId PPgnorepr_d; +{ + register struct Snorepr *pp = + (struct Snorepr *) malloc(sizeof(struct Snorepr)); + pp -> tag = norepr; + pp -> Xgnorepr_n = PPgnorepr_n; + pp -> Xgnorepr_d = PPgnorepr_d; + return((literal)pp); +} + +stringId *Rgnorepr_n(t) + struct Snorepr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != norepr) + fprintf(stderr,"gnorepr_n: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnorepr_n); +} + +stringId *Rgnorepr_d(t) + struct Snorepr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != norepr) + fprintf(stderr,"gnorepr_d: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnorepr_d); +} + +/************** noreps ******************/ + +literal mknoreps(PPgnoreps) + hstring PPgnoreps; +{ + register struct Snoreps *pp = + (struct Snoreps *) malloc(sizeof(struct Snoreps)); + pp -> tag = noreps; + pp -> Xgnoreps = PPgnoreps; + return((literal)pp); +} + +hstring *Rgnoreps(t) + struct Snoreps *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != noreps) + fprintf(stderr,"gnoreps: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnoreps); +} diff --git a/ghc/compiler/yaccParser/literal.h b/ghc/compiler/yaccParser/literal.h new file mode 100644 index 0000000..b46d7f5 --- /dev/null +++ b/ghc/compiler/yaccParser/literal.h @@ -0,0 +1,359 @@ +#ifndef literal_defined +#define literal_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + integer, + intprim, + floatr, + doubleprim, + floatprim, + charr, + charprim, + string, + stringprim, + clitlit, + norepi, + norepr, + noreps +} Tliteral; + +typedef struct { Tliteral tag; } *literal; + +#ifdef __GNUC__ +extern __inline__ Tliteral tliteral(literal t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tliteral tliteral PROTO((literal)); +#endif /* ! __GNUC__ */ + +struct Sinteger { + Tliteral tag; + stringId Xginteger; +}; + +struct Sintprim { + Tliteral tag; + stringId Xgintprim; +}; + +struct Sfloatr { + Tliteral tag; + stringId Xgfloatr; +}; + +struct Sdoubleprim { + Tliteral tag; + stringId Xgdoubleprim; +}; + +struct Sfloatprim { + Tliteral tag; + stringId Xgfloatprim; +}; + +struct Scharr { + Tliteral tag; + hstring Xgchar; +}; + +struct Scharprim { + Tliteral tag; + hstring Xgcharprim; +}; + +struct Sstring { + Tliteral tag; + hstring Xgstring; +}; + +struct Sstringprim { + Tliteral tag; + hstring Xgstringprim; +}; + +struct Sclitlit { + Tliteral tag; + stringId Xgclitlit; + stringId Xgclitlit_kind; +}; + +struct Snorepi { + Tliteral tag; + stringId Xgnorepi; +}; + +struct Snorepr { + Tliteral tag; + stringId Xgnorepr_n; + stringId Xgnorepr_d; +}; + +struct Snoreps { + Tliteral tag; + hstring Xgnoreps; +}; + +extern literal mkinteger PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rginteger(struct Sinteger *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != integer) + fprintf(stderr,"ginteger: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xginteger); +} +#else /* ! __GNUC__ */ +extern stringId *Rginteger PROTO((struct Sinteger *)); +#endif /* ! __GNUC__ */ + +#define ginteger(xyzxyz) (*Rginteger((struct Sinteger *) (xyzxyz))) + +extern literal mkintprim PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgintprim(struct Sintprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != intprim) + fprintf(stderr,"gintprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgintprim); +} +#else /* ! __GNUC__ */ +extern stringId *Rgintprim PROTO((struct Sintprim *)); +#endif /* ! __GNUC__ */ + +#define gintprim(xyzxyz) (*Rgintprim((struct Sintprim *) (xyzxyz))) + +extern literal mkfloatr PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgfloatr(struct Sfloatr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != floatr) + fprintf(stderr,"gfloatr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfloatr); +} +#else /* ! __GNUC__ */ +extern stringId *Rgfloatr PROTO((struct Sfloatr *)); +#endif /* ! __GNUC__ */ + +#define gfloatr(xyzxyz) (*Rgfloatr((struct Sfloatr *) (xyzxyz))) + +extern literal mkdoubleprim PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgdoubleprim(struct Sdoubleprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != doubleprim) + fprintf(stderr,"gdoubleprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdoubleprim); +} +#else /* ! __GNUC__ */ +extern stringId *Rgdoubleprim PROTO((struct Sdoubleprim *)); +#endif /* ! __GNUC__ */ + +#define gdoubleprim(xyzxyz) (*Rgdoubleprim((struct Sdoubleprim *) (xyzxyz))) + +extern literal mkfloatprim PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgfloatprim(struct Sfloatprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != floatprim) + fprintf(stderr,"gfloatprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfloatprim); +} +#else /* ! __GNUC__ */ +extern stringId *Rgfloatprim PROTO((struct Sfloatprim *)); +#endif /* ! __GNUC__ */ + +#define gfloatprim(xyzxyz) (*Rgfloatprim((struct Sfloatprim *) (xyzxyz))) + +extern literal mkcharr PROTO((hstring)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgchar(struct Scharr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != charr) + fprintf(stderr,"gchar: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgchar); +} +#else /* ! __GNUC__ */ +extern hstring *Rgchar PROTO((struct Scharr *)); +#endif /* ! __GNUC__ */ + +#define gchar(xyzxyz) (*Rgchar((struct Scharr *) (xyzxyz))) + +extern literal mkcharprim PROTO((hstring)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgcharprim(struct Scharprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != charprim) + fprintf(stderr,"gcharprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcharprim); +} +#else /* ! __GNUC__ */ +extern hstring *Rgcharprim PROTO((struct Scharprim *)); +#endif /* ! __GNUC__ */ + +#define gcharprim(xyzxyz) (*Rgcharprim((struct Scharprim *) (xyzxyz))) + +extern literal mkstring PROTO((hstring)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgstring(struct Sstring *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != string) + fprintf(stderr,"gstring: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgstring); +} +#else /* ! __GNUC__ */ +extern hstring *Rgstring PROTO((struct Sstring *)); +#endif /* ! __GNUC__ */ + +#define gstring(xyzxyz) (*Rgstring((struct Sstring *) (xyzxyz))) + +extern literal mkstringprim PROTO((hstring)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgstringprim(struct Sstringprim *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != stringprim) + fprintf(stderr,"gstringprim: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgstringprim); +} +#else /* ! __GNUC__ */ +extern hstring *Rgstringprim PROTO((struct Sstringprim *)); +#endif /* ! __GNUC__ */ + +#define gstringprim(xyzxyz) (*Rgstringprim((struct Sstringprim *) (xyzxyz))) + +extern literal mkclitlit PROTO((stringId, stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgclitlit(struct Sclitlit *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != clitlit) + fprintf(stderr,"gclitlit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgclitlit); +} +#else /* ! __GNUC__ */ +extern stringId *Rgclitlit PROTO((struct Sclitlit *)); +#endif /* ! __GNUC__ */ + +#define gclitlit(xyzxyz) (*Rgclitlit((struct Sclitlit *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgclitlit_kind(struct Sclitlit *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != clitlit) + fprintf(stderr,"gclitlit_kind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgclitlit_kind); +} +#else /* ! __GNUC__ */ +extern stringId *Rgclitlit_kind PROTO((struct Sclitlit *)); +#endif /* ! __GNUC__ */ + +#define gclitlit_kind(xyzxyz) (*Rgclitlit_kind((struct Sclitlit *) (xyzxyz))) + +extern literal mknorepi PROTO((stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgnorepi(struct Snorepi *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != norepi) + fprintf(stderr,"gnorepi: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnorepi); +} +#else /* ! __GNUC__ */ +extern stringId *Rgnorepi PROTO((struct Snorepi *)); +#endif /* ! __GNUC__ */ + +#define gnorepi(xyzxyz) (*Rgnorepi((struct Snorepi *) (xyzxyz))) + +extern literal mknorepr PROTO((stringId, stringId)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgnorepr_n(struct Snorepr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != norepr) + fprintf(stderr,"gnorepr_n: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnorepr_n); +} +#else /* ! __GNUC__ */ +extern stringId *Rgnorepr_n PROTO((struct Snorepr *)); +#endif /* ! __GNUC__ */ + +#define gnorepr_n(xyzxyz) (*Rgnorepr_n((struct Snorepr *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgnorepr_d(struct Snorepr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != norepr) + fprintf(stderr,"gnorepr_d: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnorepr_d); +} +#else /* ! __GNUC__ */ +extern stringId *Rgnorepr_d PROTO((struct Snorepr *)); +#endif /* ! __GNUC__ */ + +#define gnorepr_d(xyzxyz) (*Rgnorepr_d((struct Snorepr *) (xyzxyz))) + +extern literal mknoreps PROTO((hstring)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgnoreps(struct Snoreps *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != noreps) + fprintf(stderr,"gnoreps: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnoreps); +} +#else /* ! __GNUC__ */ +extern hstring *Rgnoreps PROTO((struct Snoreps *)); +#endif /* ! __GNUC__ */ + +#define gnoreps(xyzxyz) (*Rgnoreps((struct Snoreps *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/literal.ugn b/ghc/compiler/yaccParser/literal.ugn new file mode 100644 index 0000000..f35f54f --- /dev/null +++ b/ghc/compiler/yaccParser/literal.ugn @@ -0,0 +1,25 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_literal where +import UgenUtil +import Util +%}} +type literal; + integer : < ginteger : stringId; >; + intprim : < gintprim : stringId; >; + floatr : < gfloatr : stringId; >; + doubleprim : < gdoubleprim : stringId; >; + floatprim : < gfloatprim : stringId; >; + charr : < gchar : hstring; >; + charprim : < gcharprim : hstring; >; + string : < gstring : hstring; >; + stringprim : < gstringprim : hstring; >; + clitlit : < gclitlit : stringId; + gclitlit_kind : stringId; >; + norepi : < gnorepi : stringId; >; + norepr : < gnorepr_n : stringId; + gnorepr_d : stringId; >; + noreps : < gnoreps : hstring; >; +end; diff --git a/ghc/compiler/yaccParser/main.c b/ghc/compiler/yaccParser/main.c new file mode 100644 index 0000000..0c6e197 --- /dev/null +++ b/ghc/compiler/yaccParser/main.c @@ -0,0 +1,57 @@ +/* This is the "top-level" file for the *standalone* hsp parser. + See also hsclink.c. (WDP 94/10) +*/ + +#include + +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/*OLD:static char *progname;*/ /* The name of the program. */ + + +/********************************************************************** +* * +* * +* The main program * +* * +* * +**********************************************************************/ + +int +main(argc, argv) + int argc; + char **argv; +{ + Lnil = mklnil(); /* The null list -- used in lsing, etc. */ + all = mklnil(); /* This should be the list of all derivable types */ + + process_args(argc,argv); + + hash_init(); + +#ifdef HSP_DEBUG + fprintf(stderr,"input_file_dir=%s\n",input_file_dir); +#endif + + yyinit(); + + if(yyparse() == 0 && !etags) + { + /* No syntax errors. */ + pprogram(root); + printf("\n"); + exit(0); + } + else if(etags) + { + exit(0); + } + else + { + /* There was a syntax error. */ + printf("\n"); + exit(1); + } +} diff --git a/ghc/compiler/yaccParser/pbinding.c b/ghc/compiler/yaccParser/pbinding.c new file mode 100644 index 0000000..4ea35b6 --- /dev/null +++ b/ghc/compiler/yaccParser/pbinding.c @@ -0,0 +1,81 @@ + + +#include "hspincl.h" +#include "yaccParser/pbinding.h" + +Tpbinding tpbinding(t) + pbinding t; +{ + return(t -> tag); +} + + +/************** pgrhs ******************/ + +pbinding mkpgrhs(PPggpat, PPggdexprs, PPggbind, PPggfuncname, PPggline) + tree PPggpat; + list PPggdexprs; + binding PPggbind; + stringId PPggfuncname; + long PPggline; +{ + register struct Spgrhs *pp = + (struct Spgrhs *) malloc(sizeof(struct Spgrhs)); + pp -> tag = pgrhs; + pp -> Xggpat = PPggpat; + pp -> Xggdexprs = PPggdexprs; + pp -> Xggbind = PPggbind; + pp -> Xggfuncname = PPggfuncname; + pp -> Xggline = PPggline; + return((pbinding)pp); +} + +tree *Rggpat(t) + struct Spgrhs *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggpat: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggpat); +} + +list *Rggdexprs(t) + struct Spgrhs *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggdexprs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggdexprs); +} + +binding *Rggbind(t) + struct Spgrhs *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggbind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggbind); +} + +stringId *Rggfuncname(t) + struct Spgrhs *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggfuncname: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggfuncname); +} + +long *Rggline(t) + struct Spgrhs *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggline); +} diff --git a/ghc/compiler/yaccParser/pbinding.h b/ghc/compiler/yaccParser/pbinding.h new file mode 100644 index 0000000..55f14ae --- /dev/null +++ b/ghc/compiler/yaccParser/pbinding.h @@ -0,0 +1,115 @@ +#ifndef pbinding_defined +#define pbinding_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + pgrhs +} Tpbinding; + +typedef struct { Tpbinding tag; } *pbinding; + +#ifdef __GNUC__ +extern __inline__ Tpbinding tpbinding(pbinding t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tpbinding tpbinding PROTO((pbinding)); +#endif /* ! __GNUC__ */ + +struct Spgrhs { + Tpbinding tag; + tree Xggpat; + list Xggdexprs; + binding Xggbind; + stringId Xggfuncname; + long Xggline; +}; + +extern pbinding mkpgrhs PROTO((tree, list, binding, stringId, long)); +#ifdef __GNUC__ + +extern __inline__ tree *Rggpat(struct Spgrhs *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggpat: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggpat); +} +#else /* ! __GNUC__ */ +extern tree *Rggpat PROTO((struct Spgrhs *)); +#endif /* ! __GNUC__ */ + +#define ggpat(xyzxyz) (*Rggpat((struct Spgrhs *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rggdexprs(struct Spgrhs *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggdexprs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggdexprs); +} +#else /* ! __GNUC__ */ +extern list *Rggdexprs PROTO((struct Spgrhs *)); +#endif /* ! __GNUC__ */ + +#define ggdexprs(xyzxyz) (*Rggdexprs((struct Spgrhs *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rggbind(struct Spgrhs *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggbind: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggbind); +} +#else /* ! __GNUC__ */ +extern binding *Rggbind PROTO((struct Spgrhs *)); +#endif /* ! __GNUC__ */ + +#define ggbind(xyzxyz) (*Rggbind((struct Spgrhs *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rggfuncname(struct Spgrhs *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggfuncname: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggfuncname); +} +#else /* ! __GNUC__ */ +extern stringId *Rggfuncname PROTO((struct Spgrhs *)); +#endif /* ! __GNUC__ */ + +#define ggfuncname(xyzxyz) (*Rggfuncname((struct Spgrhs *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rggline(struct Spgrhs *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != pgrhs) + fprintf(stderr,"ggline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggline); +} +#else /* ! __GNUC__ */ +extern long *Rggline PROTO((struct Spgrhs *)); +#endif /* ! __GNUC__ */ + +#define ggline(xyzxyz) (*Rggline((struct Spgrhs *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/pbinding.ugn b/ghc/compiler/yaccParser/pbinding.ugn new file mode 100644 index 0000000..b7386f4 --- /dev/null +++ b/ghc/compiler/yaccParser/pbinding.ugn @@ -0,0 +1,23 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_pbinding where +import UgenUtil +import Util + +import U_binding +import U_coresyn ( U_coresyn ) -- interface only +import U_hpragma ( U_hpragma ) -- interface only +import U_list +import U_literal ( U_literal ) -- ditto +import U_treeHACK +import U_ttype ( U_ttype ) -- ditto +%}} +type pbinding; + pgrhs : < ggpat : tree; + ggdexprs : list; + ggbind : binding; + ggfuncname : stringId; + ggline : long; >; +end; diff --git a/ghc/compiler/yaccParser/printtree.c b/ghc/compiler/yaccParser/printtree.c new file mode 100644 index 0000000..719f87c --- /dev/null +++ b/ghc/compiler/yaccParser/printtree.c @@ -0,0 +1,998 @@ +/********************************************************************** +* * +* * +* Syntax Tree Printing Routines * +* * +* * +**********************************************************************/ + + +#define COMPACT TRUE /* No spaces in output -- #undef this for debugging */ + + +#include + +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/* fwd decls, necessary and otherwise */ +static void ptree PROTO( (tree) ); +static void plist PROTO( (void (*)(), list) ); +static void pid PROTO( (id) ); +static void pstr PROTO( (char *) ); +static void pbool PROTO( (BOOLEAN) ); +static void prbind PROTO( (binding) ); +static void pttype PROTO( (ttype) ); +static void patype PROTO( (atype) ); +static void pentid PROTO( (entidt) ); +static void prename PROTO( (list) ); +static void pfixes PROTO( (void) ); +static void ppbinding PROTO((pbinding)); +static void pgrhses PROTO( (list) ); +static void ppragma PROTO( (hpragma) ); +static void pcoresyn PROTO((coresyn)); + +extern char *fixop PROTO((int)); +extern char *fixtype PROTO((int)); + +extern char *input_filename; +extern BOOLEAN hashIds; + +/* How to print tags */ + +#if COMPACT +#define PUTTAG(c) putchar(c); +#define PUTTAGSTR(s) printf("%s",(s)); +#else +#define PUTTAG(c) putchar(c); \ + putchar(' '); +#define PUTTAGSTR(s) printf("%s",(s)); \ + putchar(' '); +#endif + + +/* Performs a post order walk of the tree + to print it. +*/ + +void +pprogram(t) +tree t; +{ + print_hash_table(); + ptree(t); +} + +/* print_string: we must escape \t and \\, as described in + char/string lexer comments. (WDP 94/11) +*/ +static void +print_string(str) + hstring str; +{ + char *gs; + char c; + int i, str_length; + + putchar('#'); + str_length = str->len; + gs = str->bytes; + + for (i = 0; i < str_length; i++) { + c = gs[i]; + if ( c == '\t' ) { + putchar('\\'); + putchar('t'); + } else if ( c == '\\' ) { + putchar('\\'); + putchar('\\'); + } else { + putchar(gs[i]); + } + } + putchar('\t'); +} + +static int +get_character(str) + hstring str; +{ + int c = (int)((str->bytes)[0]); + + if (str->len != 1) { /* ToDo: assert */ + fprintf(stderr, "get_character: length != 1? (%d: %s)\n", str->len, str->bytes); + } + + if (c < 0) { + c += 256; /* "This is not a hack" -- KH */ + } + + return(c); +} + +static void +pliteral(t) + literal t; +{ + switch(tliteral(t)) { + case integer: + PUTTAG('4'); + pstr(ginteger(t)); + break; + case intprim: + PUTTAG('H'); + pstr(gintprim(t)); + break; + case floatr: + PUTTAG('F'); + pstr(gfloatr(t)); + break; + case doubleprim: + PUTTAG('J'); + pstr(gdoubleprim(t)); + break; + case floatprim: + PUTTAG('K'); + pstr(gfloatprim(t)); + break; + case charr: + PUTTAG('C'); + /* Changed %d to %u, since negative chars + make little sense -- KH @ 16/4/91 + */ + printf("#%u\t", get_character(gchar(t))); + break; + case charprim: + PUTTAG('P'); + printf("#%u\t", get_character(gcharprim(t))); + break; + case string: + PUTTAG('S'); + print_string(gstring(t)); + break; + case stringprim: + PUTTAG('V'); + print_string(gstringprim(t)); + break; + case clitlit: + PUTTAG('Y'); + pstr(gclitlit(t)); + pstr(gclitlit_kind(t)); + break; + + case norepi: + PUTTAG('I'); + pstr(gnorepi(t)); + break; + case norepr: + PUTTAG('R'); + pstr(gnorepr_n(t)); + pstr(gnorepr_d(t)); + break; + case noreps: + PUTTAG('s'); + print_string(gnoreps(t)); + break; + default: + error("Bad pliteral"); + } +} + +static void +ptree(t) + tree t; +{ +again: + switch(ttree(t)) { + case par: t = gpare(t); goto again; + case hmodule: + PUTTAG('M'); + printf("#%u\t",ghmodline(t)); + pid(ghname(t)); + pstr(input_filename); + prbind(ghmodlist(t)); + pfixes(); + plist(prbind, ghimplist(t)); + plist(pentid, ghexplist(t)); + break; + case ident: + PUTTAG('i'); + pid(gident(t)); + break; + case lit: + PUTTAG('C'); + pliteral(glit(t)); + break; + + case ap: + PUTTAG('a'); + ptree(gfun(t)); + ptree(garg(t)); + break; + case lsection: + PUTTAG('('); + ptree(glsexp(t)); + pid(glsop(t)); + break; + case rsection: + PUTTAG(')'); + pid(grsop(t)); + ptree(grsexp(t)); + break; + case tinfixop: + PUTTAG('@'); + ptree(ginarg1((struct Sap *)t)); + pid(gident(ginfun((struct Sap *)t))); + ptree(ginarg2((struct Sap *)t)); + break; + + case lambda: + PUTTAG('l'); + printf("#%u\t",glamline(t)); + plist(ptree,glampats(t)); + ptree(glamexpr(t)); + break; + + case let: + PUTTAG('E'); + prbind(gletvdeflist(t)); + ptree(gletvexpr(t)); + break; + case casee: + PUTTAG('c'); + ptree(gcaseexpr(t)); + plist(ppbinding, gcasebody(t)); + break; + case ife: + PUTTAG('b'); + ptree(gifpred(t)); + ptree(gifthen(t)); + ptree(gifelse(t)); + break; + case tuple: + PUTTAG(','); + plist(ptree,gtuplelist(t)); + break; + case eenum: + PUTTAG('.'); + ptree(gefrom(t)); + plist(ptree,gestep(t)); + plist(ptree,geto(t)); + break; + case llist: + PUTTAG(':'); + plist(ptree,gllist(t)); + break; + case negate: + PUTTAG('-'); + ptree(gnexp(t)); + break; + case comprh: + PUTTAG('Z'); + ptree(gcexp(t)); + plist(ptree,gcquals(t)); + break; + case qual: + PUTTAG('G'); + ptree(gqpat(t)); + ptree(gqexp(t)); + break; + case guard: + PUTTAG('g'); + ptree(ggexp(t)); + break; + case def: + PUTTAG('='); + ptree(ggdef(t)); /* was: prbind (WDP 94/10) */ + break; + case as: + PUTTAG('s'); + pid(gasid(t)); + ptree(gase(t)); + break; + case lazyp: + PUTTAG('~'); + ptree(glazyp(t)); + break; + case plusp: + PUTTAG('+'); + ptree(gplusp(t)); + pliteral(gplusi(t)); + break; + case wildp: + PUTTAG('_'); + break; + case restr: + PUTTAG('R'); + ptree(grestre(t)); + pttype(grestrt(t)); + break; + case ccall: + PUTTAG('j'); + pstr(gccid(t)); + pstr(gccinfo(t)); + plist(ptree,gccargs(t)); + break; + case scc: + PUTTAG('k'); + print_string(gsccid(t)); + ptree(gsccexp(t)); + break; +#ifdef DPH + case parzf: + PUTTAG('5'); + ptree(gpzfexp(t)); + plist(ptree,gpzfqual(t)); + break; + case pod: + PUTTAG('6'); + plist(ptree,gpod(t)); + break; + case proc: + PUTTAG('O'); + plist(ptree,gprocid(t)); + ptree(gprocdata(t)); + break; + case pardgen: + PUTTAG('0'); + ptree(gdproc(t)); + ptree(gdexp(t)); + break; + case parigen: + PUTTAG('w'); + ptree(giproc(t)); + ptree(giexp(t)); + break; + case parfilt: + PUTTAG('I'); + ptree(gpfilt(t)); + break; +#endif /* DPH */ + + default: + error("Bad ptree"); + } +} + +static void +plist(fun, l) + void (*fun)(); + list l; +{ + if (tlist(l) == lcons) { + PUTTAG('L'); + (*fun)(lhd(l)); + plist(fun, ltl(l)); + } else { + PUTTAG('N'); + } +} + +static void +pid(i) + id i; +{ + if(hashIds) + printf("!%u\t", hash_index(i)); + else + printf("#%s\t", id_to_string(i)); +} + +static void +pstr(i) + char *i; +{ + printf("#%s\t", i); +} + +static void +prbind(b) + binding b; +{ + switch(tbinding(b)) { + case tbind: + PUTTAG('t'); + printf("#%u\t",gtline(b)); + plist(pttype, gtbindc(b)); + plist(pid, gtbindd(b)); + pttype(gtbindid(b)); + plist(patype, gtbindl(b)); + ppragma(gtpragma(b)); + break; + case nbind : + PUTTAG('n'); + printf("#%u\t",gnline(b)); + pttype(gnbindid(b)); + pttype(gnbindas(b)); + ppragma(gnpragma(b)); + break; + case pbind : + PUTTAG('p'); + printf("#%u\t",gpline(b)); + plist(ppbinding, gpbindl(b)); + break; + case fbind : + PUTTAG('f'); + printf("#%u\t",gfline(b)); + plist(ppbinding, gfbindl(b)); + break; + case abind : + PUTTAG('A'); + prbind(gabindfst(b)); + prbind(gabindsnd(b)); + break; + case cbind : + PUTTAG('$'); + printf("#%u\t",gcline(b)); + plist(pttype,gcbindc(b)); + pttype(gcbindid(b)); + prbind(gcbindw(b)); + ppragma(gcpragma(b)); + break; + case ibind : + PUTTAG('%'); + printf("#%u\t",giline(b)); + plist(pttype,gibindc(b)); + pid(gibindid(b)); + pttype(gibindi(b)); + prbind(gibindw(b)); + ppragma(gipragma(b)); + break; + case dbind : + PUTTAG('D'); + printf("#%u\t",gdline(b)); + plist(pttype,gdbindts(b)); + break; + + /* signature(-like) things, including user pragmas */ + case sbind : + PUTTAGSTR("St"); + printf("#%u\t",gsline(b)); + plist(pid,gsbindids(b)); + pttype(gsbindid(b)); + ppragma(gspragma(b)); + break; + + case vspec_uprag: + PUTTAGSTR("Ss"); + printf("#%u\t",gvspec_line(b)); + pid(gvspec_id(b)); + plist(pttype,gvspec_tys(b)); + break; + case ispec_uprag: + PUTTAGSTR("SS"); + printf("#%u\t",gispec_line(b)); + pid(gispec_clas(b)); + pttype(gispec_ty(b)); + break; + case inline_uprag: + PUTTAGSTR("Si"); + printf("#%u\t",ginline_line(b)); + pid(ginline_id(b)); + plist(pid,ginline_howto(b)); + break; + case deforest_uprag: + PUTTAGSTR("Sd"); + printf("#%u\t",gdeforest_line(b)); + pid(gdeforest_id(b)); + break; + case magicuf_uprag: + PUTTAGSTR("Su"); + printf("#%u\t",gmagicuf_line(b)); + pid(gmagicuf_id(b)); + pid(gmagicuf_str(b)); + break; + case abstract_uprag: + PUTTAGSTR("Sa"); + printf("#%u\t",gabstract_line(b)); + pid(gabstract_id(b)); + break; + case dspec_uprag: + PUTTAGSTR("Sd"); + printf("#%u\t",gdspec_line(b)); + pid(gdspec_id(b)); + plist(pttype,gdspec_tys(b)); + break; + + /* end of signature(-like) things */ + + case mbind: + PUTTAG('7'); + printf("#%u\t",gmline(b)); + pid(gmbindmodn(b)); + plist(pentid,gmbindimp(b)); + plist(prename,gmbindren(b)); + break; + case import: + PUTTAG('e'); + printf("#%u\t",giebindline(b)); + pstr(giebindfile(b)); + pid(giebindmod(b)); + plist(pentid,giebindexp(b)); + plist(prename,giebindren(b)); + prbind(giebinddef(b)); + break; + case hiding: + PUTTAG('h'); + printf("#%u\t",gihbindline(b)); + pstr(gihbindfile(b)); + pid(gihbindmod(b)); + plist(pentid,gihbindexp(b)); + plist(prename,gihbindren(b)); + prbind(gihbinddef(b)); + break; + case nullbind : + PUTTAG('B'); + break; + default : error("Bad prbind"); + break; + } +} + +static void +pttype(t) + ttype t; +{ + switch (tttype(t)) { + case tname : PUTTAG('T'); + pid(gtypeid(t)); + plist(pttype, gtypel(t)); + break; + case namedtvar : PUTTAG('y'); + pid(gnamedtvar(t)); + break; + case tllist : PUTTAG(':'); + pttype(gtlist(t)); + break; + case ttuple : PUTTAG(','); + plist(pttype,gttuple(t)); + break; + case tfun : PUTTAG('>'); + pttype(gtfun(t)); + pttype(gtarg(t)); + break; + case context : PUTTAG('3'); + plist(pttype,gtcontextl(t)); + pttype(gtcontextt(t)); + break; + + case unidict : PUTTAGSTR("2A"); + pid(gunidict_clas(t)); + pttype(gunidict_ty(t)); + break; + case unityvartemplate : PUTTAGSTR("2B"); + pid(gunityvartemplate(t)); + break; + case uniforall : PUTTAGSTR("2C"); + plist(pid,guniforall_tv(t)); + pttype(guniforall_ty(t)); + break; + + case ty_maybe_nothing : PUTTAGSTR("2D"); + break; + case ty_maybe_just: PUTTAGSTR("2E"); + pttype(gty_maybe(t)); + break; + +#ifdef DPH + case tproc : + PUTTAG('u'); + plist(pttype,gtpid(t)); + pttype(gtdata(t)); + break; + case tpod : + PUTTAG('v'); + pttype(gtpod(t)); + break; +#endif + default : error("bad pttype"); + } +} + +static void +patype(a) + atype a; +{ + switch (tatype(a)) { + case atc : + PUTTAG('1'); + printf("#%u\t",gatcline(a)); + pid(gatcid(a)); + plist(pttype, gatctypel(a)); + break; + default : fprintf(stderr, "Bad tag in abstree %d\n", tatype(a)); + exit(1); + } +} + + +static void +pentid(i) + entidt i; +{ + switch (tentidt(i)) { + case entid : PUTTAG('x'); + pid(gentid(i)); + break; + case enttype : PUTTAG('X'); + pid(gitentid(i)); + break; + case enttypeall : PUTTAG('z'); + pid(gatentid(i)); + break; + case entmod : PUTTAG('m'); + pid(gmentid(i)); + break; + case enttypecons: PUTTAG('8'); + pid(gctentid(i)); + plist(pid,gctentcons(i)); + break; + case entclass : PUTTAG('9'); + pid(gcentid(i)); + plist(pid,gcentops(i)); + break; + default : + error("Bad pentid"); + } +} + + +static void +prename(l) + list l; +{ + pid(lhd(l)); + pid(lhd(ltl(l))); +} + + +static void +pfixes() +{ + int m = nfixes(), i; + char *s; + + for(i = 0; i < m; i++) { + s = fixtype(i); + if (s) { + PUTTAG('L'); + pstr(fixop(i)); + pstr(fixtype(i)); + printf("#%u\t",precedence(i)); + } + } + PUTTAG('N'); +} + + +static void +ppbinding(p) + pbinding p; +{ + switch(tpbinding(p)) { + case pgrhs : PUTTAG('W'); + printf("#%u\t",ggline(p)); + pid(ggfuncname(p)); + ptree(ggpat(p)); + plist(pgrhses,ggdexprs(p)); + prbind(ggbind(p)); + break; + default : + error("Bad pbinding"); + } +} + + +static void +pgrhses(l) + list l; +{ + ptree(lhd(l)); /* Guard */ + ptree(lhd(ltl(l))); /* Expression */ +} + +static void +ppragma(p) + hpragma p; +{ + switch(thpragma(p)) { + case no_pragma: PUTTAGSTR("PN"); + break; + case idata_pragma: PUTTAGSTR("Pd"); + plist(patype, gprag_data_constrs(p)); + plist(ppragma, gprag_data_specs(p)); + break; + case itype_pragma: PUTTAGSTR("Pt"); + break; + case iclas_pragma: PUTTAGSTR("Pc"); + plist(ppragma, gprag_clas(p)); + break; + case iclasop_pragma: PUTTAGSTR("Po"); + ppragma(gprag_dsel(p)); + ppragma(gprag_defm(p)); + break; + + case iinst_simpl_pragma: PUTTAGSTR("Pis"); + pid(gprag_imod_simpl(p)); + ppragma(gprag_dfun_simpl(p)); + break; + case iinst_const_pragma: PUTTAGSTR("Pic"); + pid(gprag_imod_const(p)); + ppragma(gprag_dfun_const(p)); + plist(ppragma, gprag_constms(p)); + break; + case iinst_spec_pragma: PUTTAGSTR("PiS"); + pid(gprag_imod_spec(p)); + ppragma(gprag_dfun_spec(p)); + plist(ppragma, gprag_inst_specs(p)); + break; + + case igen_pragma: PUTTAGSTR("Pg"); + ppragma(gprag_arity(p)); + ppragma(gprag_update(p)); + ppragma(gprag_deforest(p)); + ppragma(gprag_strictness(p)); + ppragma(gprag_unfolding(p)); + plist(ppragma, gprag_specs(p)); + break; + case iarity_pragma: PUTTAGSTR("PA"); + pid(gprag_arity_val(p)); + break; + case iupdate_pragma: PUTTAGSTR("Pu"); + pid(gprag_update_val(p)); + break; + case ideforest_pragma: PUTTAGSTR("PD"); + break; + case istrictness_pragma: PUTTAGSTR("PS"); + print_string(gprag_strict_spec(p)); + ppragma(gprag_strict_wrkr(p)); + break; + case imagic_unfolding_pragma: PUTTAGSTR("PM"); + pid(gprag_magic_str(p)); + break; + + case iunfolding_pragma: PUTTAGSTR("PU"); + ppragma(gprag_unfold_guide(p)); + pcoresyn(gprag_unfold_core(p)); + break; + + case iunfold_always: PUTTAGSTR("Px"); + break; + case iunfold_if_args: PUTTAGSTR("Py"); + pid(gprag_unfold_if_t_args(p)); + pid(gprag_unfold_if_v_args(p)); + pid(gprag_unfold_if_con_args(p)); + pid(gprag_unfold_if_size(p)); + break; + + case iname_pragma_pr: PUTTAGSTR("P1"); + pid(gprag_name_pr1(p)); + ppragma(gprag_name_pr2(p)); + break; + case itype_pragma_pr: PUTTAGSTR("P2"); + plist(pttype, gprag_type_pr1(p)); + pid(gprag_type_pr2(p)); + ppragma(gprag_type_pr3(p)); + break; + case iinst_pragma_3s: PUTTAGSTR("P3"); + plist(pttype, gprag_inst_pt1(p)); + pid(gprag_inst_pt2(p)); + ppragma(gprag_inst_pt3(p)); + plist(ppragma,gprag_inst_pt4(p)); + break; + + case idata_pragma_4s: PUTTAGSTR("P4"); + plist(pttype, gprag_data_spec(p)); + break; + + default: error("Bad Pragma"); + } +} + +static void +pbool(b) + BOOLEAN b; +{ + if (b) { + putchar('T'); + } else { + putchar('F'); + } +} + +static void +pcoresyn(p) + coresyn p; +{ + switch(tcoresyn(p)) { + case cobinder: PUTTAGSTR("Fa"); + pid(gcobinder_v(p)); + pttype(gcobinder_ty(p)); + break; + + case colit: PUTTAGSTR("Fb"); + pliteral(gcolit(p)); + break; + case colocal: PUTTAGSTR("Fc"); + pcoresyn(gcolocal_v(p)); + break; + + case cononrec: PUTTAGSTR("Fd"); + pcoresyn(gcononrec_b(p)); + pcoresyn(gcononrec_rhs(p)); + break; + case corec: PUTTAGSTR("Fe"); + plist(pcoresyn,gcorec(p)); + break; + case corec_pair: PUTTAGSTR("Ff"); + pcoresyn(gcorec_b(p)); + pcoresyn(gcorec_rhs(p)); + break; + + case covar: PUTTAGSTR("Fg"); + pcoresyn(gcovar(p)); + break; + case coliteral: PUTTAGSTR("Fh"); + pliteral(gcoliteral(p)); + break; + case cocon: PUTTAGSTR("Fi"); + pcoresyn(gcocon_con(p)); + plist(pttype, gcocon_tys(p)); + plist(pcoresyn, gcocon_args(p)); + break; + case coprim: PUTTAGSTR("Fj"); + pcoresyn(gcoprim_op(p)); + plist(pttype, gcoprim_tys(p)); + plist(pcoresyn, gcoprim_args(p)); + break; + case colam: PUTTAGSTR("Fk"); + plist(pcoresyn, gcolam_vars(p)); + pcoresyn(gcolam_body(p)); + break; + case cotylam: PUTTAGSTR("Fl"); + plist(pid, gcotylam_tvs(p)); + pcoresyn(gcotylam_body(p)); + break; + case coapp: PUTTAGSTR("Fm"); + pcoresyn(gcoapp_fun(p)); + plist(pcoresyn, gcoapp_args(p)); + break; + case cotyapp: PUTTAGSTR("Fn"); + pcoresyn(gcotyapp_e(p)); + pttype(gcotyapp_t(p)); + break; + case cocase: PUTTAGSTR("Fo"); + pcoresyn(gcocase_s(p)); + pcoresyn(gcocase_alts(p)); + break; + case colet: PUTTAGSTR("Fp"); + pcoresyn(gcolet_bind(p)); + pcoresyn(gcolet_body(p)); + break; + case coscc: PUTTAGSTR("Fz"); /* out of order! */ + pcoresyn(gcoscc_scc(p)); + pcoresyn(gcoscc_body(p)); + break; + + case coalg_alts: PUTTAGSTR("Fq"); + plist(pcoresyn, gcoalg_alts(p)); + pcoresyn(gcoalg_deflt(p)); + break; + case coalg_alt: PUTTAGSTR("Fr"); + pcoresyn(gcoalg_con(p)); + plist(pcoresyn, gcoalg_bs(p)); + pcoresyn(gcoalg_rhs(p)); + break; + case coprim_alts: PUTTAGSTR("Fs"); + plist(pcoresyn, gcoprim_alts(p)); + pcoresyn(gcoprim_deflt(p)); + break; + case coprim_alt: PUTTAGSTR("Ft"); + pliteral(gcoprim_lit(p)); + pcoresyn(gcoprim_rhs(p)); + break; + case conodeflt: PUTTAGSTR("Fu"); + break; + case cobinddeflt: PUTTAGSTR("Fv"); + pcoresyn(gcobinddeflt_v(p)); + pcoresyn(gcobinddeflt_rhs(p)); + break; + + case co_primop: PUTTAGSTR("Fw"); + pid(gco_primop(p)); + break; + case co_ccall: PUTTAGSTR("Fx"); + pbool(gco_ccall_may_gc(p)); + pid(gco_ccall(p)); + plist(pttype, gco_ccall_arg_tys(p)); + pttype(gco_ccall_res_ty(p)); + break; + case co_casm: PUTTAGSTR("Fy"); + pbool(gco_casm_may_gc(p)); + pliteral(gco_casm(p)); + plist(pttype, gco_casm_arg_tys(p)); + pttype(gco_casm_res_ty(p)); + break; + + /* Cost-centre stuff */ + case co_preludedictscc: PUTTAGSTR("F?a"); + pcoresyn(gco_preludedictscc_dupd(p)); + break; + case co_alldictscc: PUTTAGSTR("F?b"); + print_string(gco_alldictscc_m(p)); + print_string(gco_alldictscc_g(p)); + pcoresyn(gco_alldictscc_dupd(p)); + break; + case co_usercc: PUTTAGSTR("F?c"); + print_string(gco_usercc_n(p)); + print_string(gco_usercc_m(p)); + print_string(gco_usercc_g(p)); + pcoresyn(gco_usercc_dupd(p)); + pcoresyn(gco_usercc_cafd(p)); + break; + case co_autocc: PUTTAGSTR("F?d"); + pcoresyn(gco_autocc_i(p)); + print_string(gco_autocc_m(p)); + print_string(gco_autocc_g(p)); + pcoresyn(gco_autocc_dupd(p)); + pcoresyn(gco_autocc_cafd(p)); + break; + case co_dictcc: PUTTAGSTR("F?e"); + pcoresyn(gco_dictcc_i(p)); + print_string(gco_dictcc_m(p)); + print_string(gco_dictcc_g(p)); + pcoresyn(gco_dictcc_dupd(p)); + pcoresyn(gco_dictcc_cafd(p)); + break; + + case co_scc_noncaf: PUTTAGSTR("F?f"); + break; + case co_scc_caf: PUTTAGSTR("F?g"); + break; + case co_scc_nondupd: PUTTAGSTR("F?h"); + break; + case co_scc_dupd: PUTTAGSTR("F?i"); + break; + + /* Id stuff */ + case co_id: PUTTAGSTR("F1"); + pid(gco_id(p)); + break; + case co_orig_id: PUTTAGSTR("F9"); + pid(gco_orig_id_m(p)); + pid(gco_orig_id_n(p)); + break; + case co_sdselid: PUTTAGSTR("F2"); + pid(gco_sdselid_c(p)); + pid(gco_sdselid_sc(p)); + break; + case co_classopid: PUTTAGSTR("F3"); + pid(gco_classopid_c(p)); + pid(gco_classopid_o(p)); + break; + case co_defmid: PUTTAGSTR("F4"); + pid(gco_defmid_c(p)); + pid(gco_defmid_op(p)); + break; + case co_dfunid: PUTTAGSTR("F5"); + pid(gco_dfunid_c(p)); + pttype(gco_dfunid_ty(p)); + break; + case co_constmid: PUTTAGSTR("F6"); + pid(gco_constmid_c(p)); + pid(gco_constmid_op(p)); + pttype(gco_constmid_ty(p)); + break; + case co_specid: PUTTAGSTR("F7"); + pcoresyn(gco_specid_un(p)); + plist(pttype,gco_specid_tys(p)); + break; + case co_wrkrid: PUTTAGSTR("F8"); + pcoresyn(gco_wrkrid_un(p)); + break; + /* more to come?? */ + + default : error("Bad Core syntax"); + } +} diff --git a/ghc/compiler/yaccParser/syntax.c b/ghc/compiler/yaccParser/syntax.c new file mode 100644 index 0000000..6719ccb --- /dev/null +++ b/ghc/compiler/yaccParser/syntax.c @@ -0,0 +1,728 @@ +/********************************************************************** +* * +* * +* Syntax-related Utility Functions * +* * +* * +**********************************************************************/ + +#include +#include + +#include "hspincl.h" +#include "constants.h" +#include "utils.h" +#ifdef DPH +#include "tree-DPH.h" +#else +#include "tree.h" +#endif + +/* + This file, syntax.c, is used both for the regular parser + and for parseint; however, we use the tab.h file from + the regular parser. This could get us in trouble... +*/ +#ifdef DPH +#include "hsparser-DPH.tab.h" +#else +#include "hsparser.tab.h" +#endif /* Data Parallel Haskell */ + +/* Imported values */ +extern short icontexts; +extern list Lnil; +extern unsigned endlineno, startlineno; +extern BOOLEAN hashIds, etags; + +/* Forward Declarations */ + +char *ineg PROTO((char *)); +tree unparen PROTO((tree)); + +tree fns[MAX_CONTEXTS] = { NULL }; +short samefn[MAX_CONTEXTS] = { 0 }; +tree prevpatt[MAX_CONTEXTS] = { NULL }; + +BOOLEAN inpat = FALSE; + + +/* + check infix value in range 0..9 +*/ + + +int +checkfixity(vals) + char *vals; +{ + int value; + sscanf(vals,"%d",&value); + + if (value < 0 || value > 9) + { + int oldvalue = value; + value = value < 0 ? 0 : 9; + fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n", + oldvalue,value); + } + return(value); +} + + +/* + Check Previous Pattern usage +*/ + +void +checkprevpatt() +{ + if (PREVPATT == NULL) + hsperror("\"'\" used before a function definition"); +} + +void +checksamefn(fn) + char *fn; +{ + SAMEFN = (hashIds && fn == (char *)FN) || (FN != NULL && strcmp(fn,gident(FN)) == 0); + if(!SAMEFN && etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,fn); +#endif +} + + +/* + Check that a list of types is a list of contexts +*/ + +void +checkcontext(context) + list context; +{ + ttype ty; list tl; + int valid; + + while (tlist(context) == lcons) + { + ty = (ttype) lhd(context); + valid = tttype(ty) == tname; + if (valid) + { + tl = gtypel(ty); + valid = tlist(tl) != lnil && tlist(ltl(tl)) == lnil && tttype((ttype) lhd(tl)) == namedtvar; + } + + if (!valid) + hsperror("Not a valid context"); + + context = ltl(context); + } +} + +void +checkinpat() +{ + if(!inpat) + hsperror("syntax error"); +} + +void +checkpatt(e) + tree e; +{ + switch(ttree(e)) + { + case ident: + case wildp: + break; + + case lit: + switch (tliteral(glit(e))) { + case integer: + case intprim: + case floatr: + case doubleprim: + case floatprim: + case string: + case charr: + case charprim: + case stringprim: + break; + default: + hsperror("not a valid literal pattern"); + } + break; + + case negate: + if (ttree(gnexp(e)) != lit) { + hsperror("syntax error: \"-\" applied to a non-literal"); + } else { + literal l = glit(gnexp(e)); + + if (tliteral(l) != integer && tliteral(l) != floatr) { + hsperror("syntax error: \"-\" applied to a non-number"); + } + } + break; + + case ap: + { + tree f = gfun(e); + tree a = garg(e); + + checkconap(f, a); + } + break; + + case as: + checkpatt(gase(e)); + break; + + case lazyp: + checkpatt(glazyp(e)); + break; + + case plusp: + checkpatt(gplusp(e)); + break; + + case tinfixop: + { + tree f = ginfun((struct Sap *)e), + a1 = ginarg1((struct Sap *)e), + a2 = ginarg2((struct Sap *)e); + + struct Splusp *e_plus; + + checkpatt(a1); + + if (ttree(f) == ident && strcmp(id_to_string(gident(f)),"+")==0) + { + if(ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer) + hsperror("syntax error: non-integer in (n+k) pattern"); + + if(ttree(a1) == wildp || (ttree(a1) == ident && !isconstr(gident(a1)))) + { + e->tag = plusp; + e_plus = (struct Splusp *) e; + *Rgplusp(e_plus) = a1; + *Rgplusi(e_plus) = glit(a2); + } + else + hsperror("syntax error: non-variable in (n+k) pattern"); + } + else + { + if(ttree(f) == ident && !isconstr(gident(f))) + hsperror("syntax error: variable application in pattern"); + checkpatt(a2); + } + } + break; + + case tuple: + { + list tup = gtuplelist(e); + while (tlist(tup) == lcons) + { + checkpatt(lhd(tup)); + tup = ltl(tup); + } + } + break; + + case par: + checkpatt(gpare(e)); + break; + + case llist: + { + list l = gllist(e); + while (tlist(l) == lcons) + { + checkpatt(lhd(l)); + l = ltl(l); + } + } + break; + +#ifdef DPH + case proc: + { + list pids = gprocid(e); + while (tlist(pids) == lcons) + { + checkpatt(lhd(pids)); + pids = ltl(pids); + } + checkpatt(gprocdata(e)); + } + break; +#endif /* DPH */ + + default: + hsperror("not a pattern"); + } +} + + +BOOLEAN /* return TRUE if LHS is a pattern; FALSE if a function */ +is_patt_or_fun(e, outer_level) + tree e; + BOOLEAN outer_level; + /* only needed because x+y is a *function* at + the "outer level", but an n+k *pattern* at + any "inner" level. Sigh. */ +{ + switch(ttree(e)) + { + case lit: + switch (tliteral(glit(e))) { + case integer: + case intprim: + case floatr: + case doubleprim: + case floatprim: + case string: + case charr: + case charprim: + case stringprim: + return TRUE; + default: + hsperror("Literal is not a valid LHS"); + } + + case wildp: + return TRUE; + + case as: + case lazyp: + case plusp: + case llist: + case tuple: + case negate: +#ifdef DPH + case proc: +#endif + checkpatt(e); + return TRUE; + + case ident: + return(TRUE); + /* This change might break ap infixop below. BEWARE. + return (isconstr(gident(e))); + */ + + case ap: + { + tree a = garg(e); + /* do not "unparen", otherwise the error + fromInteger ((x,y) {-no comma-} z) + will be missed. + */ + tree fn = function(e); + +/*fprintf(stderr,"ap:f=%d %s (%d),a=%d %s\n",ttree(gfun(e)),(ttree(gfun(e)) == ident) ? (gident(gfun(e))) : "",ttree(fn),ttree(garg(e)),(ttree(garg(e)) == ident) ? (gident(garg(e))) : "");*/ + checkpatt(a); + + if(ttree(fn) == ident) + return(isconstr(gident(fn))); + + else if(ttree(fn) == tinfixop) + return(is_patt_or_fun(fn, TRUE/*still at "outer level"*/)); + + else + hsperror("Not a legal pattern binding in LHS"); + } + + case tinfixop: + { + tree f = ginfun((struct Sap *)e), + a1 = unparen(ginarg1((struct Sap *)e)), + a2 = unparen(ginarg2((struct Sap *)e)); + + struct Splusp *e_plus; + + /* Even function definitions must have pattern arguments */ + checkpatt(a1); + checkpatt(a2); + + if (ttree(f) == ident) + { + if(strcmp(id_to_string(gident(f)),"+")==0 && ttree(a1) == ident) + { + /* n+k is a function at the top level */ + if(outer_level || ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer) + return FALSE; + + e->tag = plusp; + e_plus = (struct Splusp *) e; + *Rgplusp(e_plus) = a1; + *Rgplusi(e_plus) = glit(a2); + return TRUE; + } + else + return(isconstr(gident(f))); + } + + else + hsperror("Strange infix op"); + } + + case par: + return(is_patt_or_fun(gpare(e), FALSE /*no longer at "outer level"*/)); + + /* Anything else must be an illegal LHS */ + default: + hsperror("Not a valid LHS"); + } + + abort(); /* should never get here */ + return(FALSE); +} + +/* interface for the outside world */ +BOOLEAN +lhs_is_patt(e) + tree e; +{ + return(is_patt_or_fun(e, TRUE /*outer-level*/)); +} + +/* + Return the function at the root of a series of applications. +*/ + +tree +function(e) + tree e; +{ + switch (ttree(e)) + { + case ap: + checkpatt(garg(e)); + return(function(gfun(e))); + + case par: + return(function(gpare(e))); + + default: + return(e); + } +} + + +tree +unparen(e) + tree e; +{ + while (ttree(e) == par) + e = gpare(e); + + return(e); +} + +void +checkconap(f, a) + tree f, a; +{ + switch(ttree(f)) + { + case ident: + if (isconstr(gident(f))) + { + checkpatt(a); + return; + } + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"syntax error: not a constructor application -- %s",gident(f)); + hsperror(errbuf); + } + + case ap: + checkconap(gfun(f), garg(f)); + checkpatt(a); + return; + + case par: + checkconap(gpare(f), a); + break; + + case tuple: + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"syntax error: tuple pattern `applied' to arguments (missing comma?)"); + hsperror(errbuf); + } + break; + + default: + hsperror("syntax error: not a constructor application"); + } +} + + +/* + Extend a function by adding a new definition to its list of bindings. +*/ + +void +extendfn(bind,rule) +binding bind; +binding rule; +{ +/* fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/ + if(tbinding(bind) == abind) + bind = gabindsnd(bind); + + if(tbinding(bind) == pbind) + gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule)); + else if(tbinding(bind) == fbind) + gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule)); + else + fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind)); +} + +/* + + Precedence Parser for Haskell. By default operators are left-associative, + so it is only necessary to rearrange the parse tree where the new operator + has a greater precedence than the existing one, or where two operators have + the same precedence and are both right-associative. Error conditions are + handled. + + Note: Prefix negation has the same precedence as infix minus. + The algorithm must thus take account of explicit negates. +*/ + +void +precparse(t) + tree t; +{ +#if 0 +#ifdef HSP_DEBUG + fprintf(stderr,"precparse %x\n",ttree(t)); +#endif +#endif + if(ttree(t) == tinfixop) + { + tree left = ginarg1((struct Sap *)t); + +#if 0 +#ifdef HSP_DEBUG + fprintf(stderr,"precparse:t=");ptree(t);printf("\nleft=");ptree(left);printf("\n"); +#endif +#endif + + if(ttree(left) == negate) + { + id tid = gident(ginfun((struct Sap *)t)); + struct infix *ttabpos = infixlookup(tid); + struct infix *ntabpos = infixlookup(install_literal("-")); /* This should be static, but C won't allow that. */ + + if(pprecedence(ntabpos) < pprecedence(ttabpos)) + { + tree right = ginarg2((struct Sap *)t); + t->tag = negate; + gnexp(t) = mkinfixop(tid,gnexp(left),right); + } + } + + else if(ttree(left) == tinfixop) + { + id lid = gident(ginfun((struct Sap *)left)), + tid = gident(ginfun((struct Sap *)t)); + + struct infix *lefttabpos = infixlookup(lid), + *ttabpos = infixlookup(tid); + +#if 0 +#ifdef HSP_DEBUG + fprintf(stderr,"precparse: lid=%s; tid=%s,ltab=%d,ttab=%d\n", + id_to_string(lid),id_to_string(tid),pprecedence(lefttabpos),pprecedence(ttabpos)); +#endif +#endif + + if (pprecedence(lefttabpos) < pprecedence(ttabpos)) + rearrangeprec(left,t); + + else if (pprecedence(lefttabpos) == pprecedence(ttabpos)) + { + if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR) + rearrangeprec(left,t); + + else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL) + /* SKIP */; + + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"Cannot mix %s and %s in the same infix expression", + id_to_string(lid), id_to_string(tid)); + hsperror(errbuf); + } + } + } + } +} + + +/* + Rearrange a tree to effectively insert an operator in the correct place. + The recursive call to precparse ensures this filters down as necessary. +*/ + +void +rearrangeprec(t1,t2) + tree t1, t2; +{ + tree arg3 = ginarg2((struct Sap *)t2); + id id1 = gident(ginfun((struct Sap *)t1)), + id2 = gident(ginfun((struct Sap *)t2)); + gident(ginfun((struct Sap *)t1)) = id2; + gident(ginfun((struct Sap *)t2)) = id1; + + ginarg2((struct Sap *)t2) = t1; + ginarg1((struct Sap *)t2) = ginarg1((struct Sap *)t1); + ginarg1((struct Sap *)t1) = ginarg2((struct Sap *)t1); + ginarg2((struct Sap *)t1) = arg3; + precparse(t1); +} + +pbinding +createpat(guards,where) + list guards; + binding where; +{ + char *func; + + if(FN != NULL) + func = gident(FN); + else + func = install_literal(""); + + /* I don't think I need to allocate func here -- KH */ + return(mkpgrhs(PREVPATT,guards,where,func,endlineno)); +} + + +list +mktruecase(expr) + tree expr; +{ +/* partain: want a more magical symbol ??? + return(ldub(mkbool(1),expr)); +*/ + return(ldub(mkident(install_literal("__o")),expr)); /* __otherwise */ +} + + +char * +ineg(i) + char *i; +{ + char *p = xmalloc(strlen(i)+2); + + *p = '-'; + strcpy(p+1,i); + return(p); +} + +void +checkmodname(import,interface) + id import, interface; +{ + if(strcmp(import,interface) != 0) + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"interface name (%s) does not agree with import name (%s)",interface,import); + hsperror(errbuf); + } +} + +/* + Check the ordering of declarations in a cbody. + All signatures must appear before any declarations. +*/ + +void +checkorder(decls) + binding decls; +{ + /* The ordering must be correct for a singleton */ + if(tbinding(decls)!=abind) + return; + + checkorder2(decls,TRUE); +} + +BOOLEAN +checkorder2(decls,sigs) + binding decls; + BOOLEAN sigs; +{ + while(tbinding(decls)==abind) + { + /* Perform a left-traversal if necessary */ + binding left = gabindfst(decls); + if(tbinding(left)==abind) + sigs = checkorder2(left,sigs); + else + sigs = checksig(sigs,left); + decls = gabindsnd(decls); + } + + return(checksig(sigs,decls)); +} + + +BOOLEAN +checksig(sig,decl) + BOOLEAN sig; + binding decl; +{ + BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind; + if(!sig && issig) + hsperror("Signature appears after definition in class body"); + + return(issig); +} + + +/* + Check the precedence of a pattern or expression to ensure that + sections and function definitions have the correct parse. +*/ + +void +checkprec(exp,fn,right) + tree exp; + id fn; + BOOLEAN right; +{ + if(ttree(exp) == tinfixop) + { + struct infix *ftabpos = infixlookup(fn); + struct infix *etabpos = infixlookup(gident(ginfun((struct Sap *)exp))); + + if (pprecedence(etabpos) > pprecedence(ftabpos) || + (pprecedence(etabpos) == pprecedence(ftabpos) && + ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) || + ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right))))) + /* SKIP */; + + else + { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section", + id_to_string(fn), id_to_string(gident(ginfun((struct Sap *)exp)))); + hsperror(errbuf); + } + } +} + diff --git a/ghc/compiler/yaccParser/tests/Jmakefile b/ghc/compiler/yaccParser/tests/Jmakefile new file mode 100644 index 0000000..e69de29 diff --git a/ghc/compiler/yaccParser/tree-DPH.ugn b/ghc/compiler/yaccParser/tree-DPH.ugn new file mode 100644 index 0000000..1b68dcd --- /dev/null +++ b/ghc/compiler/yaccParser/tree-DPH.ugn @@ -0,0 +1,80 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_tree where +import UgenUtil +import Util +%}} +type tree; + hmodule : < ghname : id; + ghimplist : list; + ghexplist : list; + ghmodlist : binding; + ghmodline : unsigned; >; + ident : < gident : id; >; + integer : < ginteger : id; >; + intprim : < gintprim : id; >; + floatr : < gfloatr : id; >; + doubleprim : < gdoubleprim : id; >; + floatprim : < gfloatprim : id; >; + charr : < gchar : id; >; + charprim : < gcharprim : id; >; + clitlit : < gclitlit : id; >; + voidprim : < >; + string : < gstring : id; >; + tuple : < gtuplelist : list; >; + ap : < gfun : tree; + garg : tree; >; + lambda : < glampats : list; + glamexpr : tree; + glamline : unsigned; >; + let : < gletvdeflist : binding; + gletvexpr : tree; >; + casee : < gcaseexpr : tree; + gcasebody : list; >; + ife : < gifpred : tree; + gifthen : tree; + gifelse : tree; >; + par : < gpare : tree; >; + as : < gasid : id; + gase : tree; >; + lazyp : < glazyp : tree; >; + plusp : < gplusp : tree; + gplusi : tree; >; + wildp : < >; + restr : < grestre : tree; + grestrt : ttype; >; + comprh : < gcexp : tree; + gcquals : list; >; + qual : < gqpat : tree; + gqexp : tree; >; + guard : < ggexp : tree; >; + def : < ggdef : binding; >; + tinfixop: < gdummy : tree; >; + lsection: < glsexp : tree; + glsop : id; >; + rsection: < grsop : id; + grsexp : tree; >; + eenum : < gefrom : tree; + gestep : list; + geto : list; >; + llist : < gllist : list; >; + ccall : < gccid : id; + gccinfo : id; + gccargs : list; >; + scc : < gsccid : id; + gsccexp : tree; >; + negate : < gnexp : tree; >; + parzf : < gpzfexp : tree; + gpzfqual : list; >; + pardgen : < gdproc : tree; + gdexp : tree; >; + parigen : < giproc : tree; + giexp : tree; >; + parfilt : < gpfilt : tree; >; + pod : < gpod : list; >; + proc : < gprocid : list; + gprocdata : tree; >; + +end; diff --git a/ghc/compiler/yaccParser/tree.c b/ghc/compiler/yaccParser/tree.c new file mode 100644 index 0000000..1fa6533 --- /dev/null +++ b/ghc/compiler/yaccParser/tree.c @@ -0,0 +1,869 @@ + + +#include "hspincl.h" +#include "yaccParser/tree.h" + +Ttree ttree(t) + tree t; +{ + return(t -> tag); +} + + +/************** hmodule ******************/ + +tree mkhmodule(PPghname, PPghimplist, PPghexplist, PPghmodlist, PPghmodline) + stringId PPghname; + list PPghimplist; + list PPghexplist; + binding PPghmodlist; + long PPghmodline; +{ + register struct Shmodule *pp = + (struct Shmodule *) malloc(sizeof(struct Shmodule)); + pp -> tag = hmodule; + pp -> Xghname = PPghname; + pp -> Xghimplist = PPghimplist; + pp -> Xghexplist = PPghexplist; + pp -> Xghmodlist = PPghmodlist; + pp -> Xghmodline = PPghmodline; + return((tree)pp); +} + +stringId *Rghname(t) + struct Shmodule *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghname: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghname); +} + +list *Rghimplist(t) + struct Shmodule *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghimplist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghimplist); +} + +list *Rghexplist(t) + struct Shmodule *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghexplist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghexplist); +} + +binding *Rghmodlist(t) + struct Shmodule *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghmodlist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghmodlist); +} + +long *Rghmodline(t) + struct Shmodule *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghmodline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghmodline); +} + +/************** ident ******************/ + +tree mkident(PPgident) + unkId PPgident; +{ + register struct Sident *pp = + (struct Sident *) malloc(sizeof(struct Sident)); + pp -> tag = ident; + pp -> Xgident = PPgident; + return((tree)pp); +} + +unkId *Rgident(t) + struct Sident *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ident) + fprintf(stderr,"gident: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgident); +} + +/************** lit ******************/ + +tree mklit(PPglit) + literal PPglit; +{ + register struct Slit *pp = + (struct Slit *) malloc(sizeof(struct Slit)); + pp -> tag = lit; + pp -> Xglit = PPglit; + return((tree)pp); +} + +literal *Rglit(t) + struct Slit *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lit) + fprintf(stderr,"glit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglit); +} + +/************** tuple ******************/ + +tree mktuple(PPgtuplelist) + list PPgtuplelist; +{ + register struct Stuple *pp = + (struct Stuple *) malloc(sizeof(struct Stuple)); + pp -> tag = tuple; + pp -> Xgtuplelist = PPgtuplelist; + return((tree)pp); +} + +list *Rgtuplelist(t) + struct Stuple *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tuple) + fprintf(stderr,"gtuplelist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtuplelist); +} + +/************** ap ******************/ + +tree mkap(PPgfun, PPgarg) + tree PPgfun; + tree PPgarg; +{ + register struct Sap *pp = + (struct Sap *) malloc(sizeof(struct Sap)); + pp -> tag = ap; + pp -> Xgfun = PPgfun; + pp -> Xgarg = PPgarg; + return((tree)pp); +} + +tree *Rgfun(t) + struct Sap *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ap) + fprintf(stderr,"gfun: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfun); +} + +tree *Rgarg(t) + struct Sap *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ap) + fprintf(stderr,"garg: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgarg); +} + +/************** lambda ******************/ + +tree mklambda(PPglampats, PPglamexpr, PPglamline) + list PPglampats; + tree PPglamexpr; + long PPglamline; +{ + register struct Slambda *pp = + (struct Slambda *) malloc(sizeof(struct Slambda)); + pp -> tag = lambda; + pp -> Xglampats = PPglampats; + pp -> Xglamexpr = PPglamexpr; + pp -> Xglamline = PPglamline; + return((tree)pp); +} + +list *Rglampats(t) + struct Slambda *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lambda) + fprintf(stderr,"glampats: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglampats); +} + +tree *Rglamexpr(t) + struct Slambda *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lambda) + fprintf(stderr,"glamexpr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglamexpr); +} + +long *Rglamline(t) + struct Slambda *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lambda) + fprintf(stderr,"glamline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglamline); +} + +/************** let ******************/ + +tree mklet(PPgletvdeflist, PPgletvexpr) + binding PPgletvdeflist; + tree PPgletvexpr; +{ + register struct Slet *pp = + (struct Slet *) malloc(sizeof(struct Slet)); + pp -> tag = let; + pp -> Xgletvdeflist = PPgletvdeflist; + pp -> Xgletvexpr = PPgletvexpr; + return((tree)pp); +} + +binding *Rgletvdeflist(t) + struct Slet *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != let) + fprintf(stderr,"gletvdeflist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgletvdeflist); +} + +tree *Rgletvexpr(t) + struct Slet *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != let) + fprintf(stderr,"gletvexpr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgletvexpr); +} + +/************** casee ******************/ + +tree mkcasee(PPgcaseexpr, PPgcasebody) + tree PPgcaseexpr; + list PPgcasebody; +{ + register struct Scasee *pp = + (struct Scasee *) malloc(sizeof(struct Scasee)); + pp -> tag = casee; + pp -> Xgcaseexpr = PPgcaseexpr; + pp -> Xgcasebody = PPgcasebody; + return((tree)pp); +} + +tree *Rgcaseexpr(t) + struct Scasee *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != casee) + fprintf(stderr,"gcaseexpr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcaseexpr); +} + +list *Rgcasebody(t) + struct Scasee *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != casee) + fprintf(stderr,"gcasebody: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcasebody); +} + +/************** ife ******************/ + +tree mkife(PPgifpred, PPgifthen, PPgifelse) + tree PPgifpred; + tree PPgifthen; + tree PPgifelse; +{ + register struct Sife *pp = + (struct Sife *) malloc(sizeof(struct Sife)); + pp -> tag = ife; + pp -> Xgifpred = PPgifpred; + pp -> Xgifthen = PPgifthen; + pp -> Xgifelse = PPgifelse; + return((tree)pp); +} + +tree *Rgifpred(t) + struct Sife *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ife) + fprintf(stderr,"gifpred: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgifpred); +} + +tree *Rgifthen(t) + struct Sife *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ife) + fprintf(stderr,"gifthen: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgifthen); +} + +tree *Rgifelse(t) + struct Sife *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ife) + fprintf(stderr,"gifelse: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgifelse); +} + +/************** par ******************/ + +tree mkpar(PPgpare) + tree PPgpare; +{ + register struct Spar *pp = + (struct Spar *) malloc(sizeof(struct Spar)); + pp -> tag = par; + pp -> Xgpare = PPgpare; + return((tree)pp); +} + +tree *Rgpare(t) + struct Spar *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != par) + fprintf(stderr,"gpare: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgpare); +} + +/************** as ******************/ + +tree mkas(PPgasid, PPgase) + unkId PPgasid; + tree PPgase; +{ + register struct Sas *pp = + (struct Sas *) malloc(sizeof(struct Sas)); + pp -> tag = as; + pp -> Xgasid = PPgasid; + pp -> Xgase = PPgase; + return((tree)pp); +} + +unkId *Rgasid(t) + struct Sas *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != as) + fprintf(stderr,"gasid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgasid); +} + +tree *Rgase(t) + struct Sas *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != as) + fprintf(stderr,"gase: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgase); +} + +/************** lazyp ******************/ + +tree mklazyp(PPglazyp) + tree PPglazyp; +{ + register struct Slazyp *pp = + (struct Slazyp *) malloc(sizeof(struct Slazyp)); + pp -> tag = lazyp; + pp -> Xglazyp = PPglazyp; + return((tree)pp); +} + +tree *Rglazyp(t) + struct Slazyp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lazyp) + fprintf(stderr,"glazyp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglazyp); +} + +/************** plusp ******************/ + +tree mkplusp(PPgplusp, PPgplusi) + tree PPgplusp; + literal PPgplusi; +{ + register struct Splusp *pp = + (struct Splusp *) malloc(sizeof(struct Splusp)); + pp -> tag = plusp; + pp -> Xgplusp = PPgplusp; + pp -> Xgplusi = PPgplusi; + return((tree)pp); +} + +tree *Rgplusp(t) + struct Splusp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != plusp) + fprintf(stderr,"gplusp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgplusp); +} + +literal *Rgplusi(t) + struct Splusp *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != plusp) + fprintf(stderr,"gplusi: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgplusi); +} + +/************** wildp ******************/ + +tree mkwildp() +{ + register struct Swildp *pp = + (struct Swildp *) malloc(sizeof(struct Swildp)); + pp -> tag = wildp; + return((tree)pp); +} + +/************** restr ******************/ + +tree mkrestr(PPgrestre, PPgrestrt) + tree PPgrestre; + ttype PPgrestrt; +{ + register struct Srestr *pp = + (struct Srestr *) malloc(sizeof(struct Srestr)); + pp -> tag = restr; + pp -> Xgrestre = PPgrestre; + pp -> Xgrestrt = PPgrestrt; + return((tree)pp); +} + +tree *Rgrestre(t) + struct Srestr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != restr) + fprintf(stderr,"grestre: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrestre); +} + +ttype *Rgrestrt(t) + struct Srestr *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != restr) + fprintf(stderr,"grestrt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrestrt); +} + +/************** comprh ******************/ + +tree mkcomprh(PPgcexp, PPgcquals) + tree PPgcexp; + list PPgcquals; +{ + register struct Scomprh *pp = + (struct Scomprh *) malloc(sizeof(struct Scomprh)); + pp -> tag = comprh; + pp -> Xgcexp = PPgcexp; + pp -> Xgcquals = PPgcquals; + return((tree)pp); +} + +tree *Rgcexp(t) + struct Scomprh *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != comprh) + fprintf(stderr,"gcexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcexp); +} + +list *Rgcquals(t) + struct Scomprh *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != comprh) + fprintf(stderr,"gcquals: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcquals); +} + +/************** qual ******************/ + +tree mkqual(PPgqpat, PPgqexp) + tree PPgqpat; + tree PPgqexp; +{ + register struct Squal *pp = + (struct Squal *) malloc(sizeof(struct Squal)); + pp -> tag = qual; + pp -> Xgqpat = PPgqpat; + pp -> Xgqexp = PPgqexp; + return((tree)pp); +} + +tree *Rgqpat(t) + struct Squal *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != qual) + fprintf(stderr,"gqpat: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgqpat); +} + +tree *Rgqexp(t) + struct Squal *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != qual) + fprintf(stderr,"gqexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgqexp); +} + +/************** guard ******************/ + +tree mkguard(PPggexp) + tree PPggexp; +{ + register struct Sguard *pp = + (struct Sguard *) malloc(sizeof(struct Sguard)); + pp -> tag = guard; + pp -> Xggexp = PPggexp; + return((tree)pp); +} + +tree *Rggexp(t) + struct Sguard *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != guard) + fprintf(stderr,"ggexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggexp); +} + +/************** def ******************/ + +tree mkdef(PPggdef) + tree PPggdef; +{ + register struct Sdef *pp = + (struct Sdef *) malloc(sizeof(struct Sdef)); + pp -> tag = def; + pp -> Xggdef = PPggdef; + return((tree)pp); +} + +tree *Rggdef(t) + struct Sdef *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != def) + fprintf(stderr,"ggdef: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggdef); +} + +/************** tinfixop ******************/ + +tree mktinfixop(PPgdummy) + infixTree PPgdummy; +{ + register struct Stinfixop *pp = + (struct Stinfixop *) malloc(sizeof(struct Stinfixop)); + pp -> tag = tinfixop; + pp -> Xgdummy = PPgdummy; + return((tree)pp); +} + +infixTree *Rgdummy(t) + struct Stinfixop *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tinfixop) + fprintf(stderr,"gdummy: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdummy); +} + +/************** lsection ******************/ + +tree mklsection(PPglsexp, PPglsop) + tree PPglsexp; + unkId PPglsop; +{ + register struct Slsection *pp = + (struct Slsection *) malloc(sizeof(struct Slsection)); + pp -> tag = lsection; + pp -> Xglsexp = PPglsexp; + pp -> Xglsop = PPglsop; + return((tree)pp); +} + +tree *Rglsexp(t) + struct Slsection *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lsection) + fprintf(stderr,"glsexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglsexp); +} + +unkId *Rglsop(t) + struct Slsection *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != lsection) + fprintf(stderr,"glsop: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglsop); +} + +/************** rsection ******************/ + +tree mkrsection(PPgrsop, PPgrsexp) + unkId PPgrsop; + tree PPgrsexp; +{ + register struct Srsection *pp = + (struct Srsection *) malloc(sizeof(struct Srsection)); + pp -> tag = rsection; + pp -> Xgrsop = PPgrsop; + pp -> Xgrsexp = PPgrsexp; + return((tree)pp); +} + +unkId *Rgrsop(t) + struct Srsection *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != rsection) + fprintf(stderr,"grsop: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrsop); +} + +tree *Rgrsexp(t) + struct Srsection *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != rsection) + fprintf(stderr,"grsexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrsexp); +} + +/************** eenum ******************/ + +tree mkeenum(PPgefrom, PPgestep, PPgeto) + tree PPgefrom; + list PPgestep; + list PPgeto; +{ + register struct Seenum *pp = + (struct Seenum *) malloc(sizeof(struct Seenum)); + pp -> tag = eenum; + pp -> Xgefrom = PPgefrom; + pp -> Xgestep = PPgestep; + pp -> Xgeto = PPgeto; + return((tree)pp); +} + +tree *Rgefrom(t) + struct Seenum *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != eenum) + fprintf(stderr,"gefrom: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgefrom); +} + +list *Rgestep(t) + struct Seenum *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != eenum) + fprintf(stderr,"gestep: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgestep); +} + +list *Rgeto(t) + struct Seenum *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != eenum) + fprintf(stderr,"geto: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgeto); +} + +/************** llist ******************/ + +tree mkllist(PPgllist) + list PPgllist; +{ + register struct Sllist *pp = + (struct Sllist *) malloc(sizeof(struct Sllist)); + pp -> tag = llist; + pp -> Xgllist = PPgllist; + return((tree)pp); +} + +list *Rgllist(t) + struct Sllist *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != llist) + fprintf(stderr,"gllist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgllist); +} + +/************** ccall ******************/ + +tree mkccall(PPgccid, PPgccinfo, PPgccargs) + stringId PPgccid; + stringId PPgccinfo; + list PPgccargs; +{ + register struct Sccall *pp = + (struct Sccall *) malloc(sizeof(struct Sccall)); + pp -> tag = ccall; + pp -> Xgccid = PPgccid; + pp -> Xgccinfo = PPgccinfo; + pp -> Xgccargs = PPgccargs; + return((tree)pp); +} + +stringId *Rgccid(t) + struct Sccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ccall) + fprintf(stderr,"gccid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgccid); +} + +stringId *Rgccinfo(t) + struct Sccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ccall) + fprintf(stderr,"gccinfo: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgccinfo); +} + +list *Rgccargs(t) + struct Sccall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ccall) + fprintf(stderr,"gccargs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgccargs); +} + +/************** scc ******************/ + +tree mkscc(PPgsccid, PPgsccexp) + hstring PPgsccid; + tree PPgsccexp; +{ + register struct Sscc *pp = + (struct Sscc *) malloc(sizeof(struct Sscc)); + pp -> tag = scc; + pp -> Xgsccid = PPgsccid; + pp -> Xgsccexp = PPgsccexp; + return((tree)pp); +} + +hstring *Rgsccid(t) + struct Sscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != scc) + fprintf(stderr,"gsccid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsccid); +} + +tree *Rgsccexp(t) + struct Sscc *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != scc) + fprintf(stderr,"gsccexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsccexp); +} + +/************** negate ******************/ + +tree mknegate(PPgnexp) + tree PPgnexp; +{ + register struct Snegate *pp = + (struct Snegate *) malloc(sizeof(struct Snegate)); + pp -> tag = negate; + pp -> Xgnexp = PPgnexp; + return((tree)pp); +} + +tree *Rgnexp(t) + struct Snegate *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != negate) + fprintf(stderr,"gnexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnexp); +} diff --git a/ghc/compiler/yaccParser/tree.h b/ghc/compiler/yaccParser/tree.h new file mode 100644 index 0000000..d0c93c8 --- /dev/null +++ b/ghc/compiler/yaccParser/tree.h @@ -0,0 +1,1001 @@ +#ifndef tree_defined +#define tree_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + hmodule, + ident, + lit, + tuple, + ap, + lambda, + let, + casee, + ife, + par, + as, + lazyp, + plusp, + wildp, + restr, + comprh, + qual, + guard, + def, + tinfixop, + lsection, + rsection, + eenum, + llist, + ccall, + scc, + negate +} Ttree; + +typedef struct { Ttree tag; } *tree; + +#ifdef __GNUC__ +extern __inline__ Ttree ttree(tree t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Ttree ttree PROTO((tree)); +#endif /* ! __GNUC__ */ + +struct Shmodule { + Ttree tag; + stringId Xghname; + list Xghimplist; + list Xghexplist; + binding Xghmodlist; + long Xghmodline; +}; + +struct Sident { + Ttree tag; + unkId Xgident; +}; + +struct Slit { + Ttree tag; + literal Xglit; +}; + +struct Stuple { + Ttree tag; + list Xgtuplelist; +}; + +struct Sap { + Ttree tag; + tree Xgfun; + tree Xgarg; +}; + +struct Slambda { + Ttree tag; + list Xglampats; + tree Xglamexpr; + long Xglamline; +}; + +struct Slet { + Ttree tag; + binding Xgletvdeflist; + tree Xgletvexpr; +}; + +struct Scasee { + Ttree tag; + tree Xgcaseexpr; + list Xgcasebody; +}; + +struct Sife { + Ttree tag; + tree Xgifpred; + tree Xgifthen; + tree Xgifelse; +}; + +struct Spar { + Ttree tag; + tree Xgpare; +}; + +struct Sas { + Ttree tag; + unkId Xgasid; + tree Xgase; +}; + +struct Slazyp { + Ttree tag; + tree Xglazyp; +}; + +struct Splusp { + Ttree tag; + tree Xgplusp; + literal Xgplusi; +}; + +struct Swildp { + Ttree tag; +}; + +struct Srestr { + Ttree tag; + tree Xgrestre; + ttype Xgrestrt; +}; + +struct Scomprh { + Ttree tag; + tree Xgcexp; + list Xgcquals; +}; + +struct Squal { + Ttree tag; + tree Xgqpat; + tree Xgqexp; +}; + +struct Sguard { + Ttree tag; + tree Xggexp; +}; + +struct Sdef { + Ttree tag; + tree Xggdef; +}; + +struct Stinfixop { + Ttree tag; + infixTree Xgdummy; +}; + +struct Slsection { + Ttree tag; + tree Xglsexp; + unkId Xglsop; +}; + +struct Srsection { + Ttree tag; + unkId Xgrsop; + tree Xgrsexp; +}; + +struct Seenum { + Ttree tag; + tree Xgefrom; + list Xgestep; + list Xgeto; +}; + +struct Sllist { + Ttree tag; + list Xgllist; +}; + +struct Sccall { + Ttree tag; + stringId Xgccid; + stringId Xgccinfo; + list Xgccargs; +}; + +struct Sscc { + Ttree tag; + hstring Xgsccid; + tree Xgsccexp; +}; + +struct Snegate { + Ttree tag; + tree Xgnexp; +}; + +extern tree mkhmodule PROTO((stringId, list, list, binding, long)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rghname(struct Shmodule *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghname: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghname); +} +#else /* ! __GNUC__ */ +extern stringId *Rghname PROTO((struct Shmodule *)); +#endif /* ! __GNUC__ */ + +#define ghname(xyzxyz) (*Rghname((struct Shmodule *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rghimplist(struct Shmodule *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghimplist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghimplist); +} +#else /* ! __GNUC__ */ +extern list *Rghimplist PROTO((struct Shmodule *)); +#endif /* ! __GNUC__ */ + +#define ghimplist(xyzxyz) (*Rghimplist((struct Shmodule *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rghexplist(struct Shmodule *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghexplist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghexplist); +} +#else /* ! __GNUC__ */ +extern list *Rghexplist PROTO((struct Shmodule *)); +#endif /* ! __GNUC__ */ + +#define ghexplist(xyzxyz) (*Rghexplist((struct Shmodule *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ binding *Rghmodlist(struct Shmodule *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghmodlist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghmodlist); +} +#else /* ! __GNUC__ */ +extern binding *Rghmodlist PROTO((struct Shmodule *)); +#endif /* ! __GNUC__ */ + +#define ghmodlist(xyzxyz) (*Rghmodlist((struct Shmodule *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rghmodline(struct Shmodule *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != hmodule) + fprintf(stderr,"ghmodline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xghmodline); +} +#else /* ! __GNUC__ */ +extern long *Rghmodline PROTO((struct Shmodule *)); +#endif /* ! __GNUC__ */ + +#define ghmodline(xyzxyz) (*Rghmodline((struct Shmodule *) (xyzxyz))) + +extern tree mkident PROTO((unkId)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgident(struct Sident *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ident) + fprintf(stderr,"gident: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgident); +} +#else /* ! __GNUC__ */ +extern unkId *Rgident PROTO((struct Sident *)); +#endif /* ! __GNUC__ */ + +#define gident(xyzxyz) (*Rgident((struct Sident *) (xyzxyz))) + +extern tree mklit PROTO((literal)); +#ifdef __GNUC__ + +extern __inline__ literal *Rglit(struct Slit *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lit) + fprintf(stderr,"glit: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglit); +} +#else /* ! __GNUC__ */ +extern literal *Rglit PROTO((struct Slit *)); +#endif /* ! __GNUC__ */ + +#define glit(xyzxyz) (*Rglit((struct Slit *) (xyzxyz))) + +extern tree mktuple PROTO((list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgtuplelist(struct Stuple *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tuple) + fprintf(stderr,"gtuplelist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtuplelist); +} +#else /* ! __GNUC__ */ +extern list *Rgtuplelist PROTO((struct Stuple *)); +#endif /* ! __GNUC__ */ + +#define gtuplelist(xyzxyz) (*Rgtuplelist((struct Stuple *) (xyzxyz))) + +extern tree mkap PROTO((tree, tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgfun(struct Sap *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ap) + fprintf(stderr,"gfun: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgfun); +} +#else /* ! __GNUC__ */ +extern tree *Rgfun PROTO((struct Sap *)); +#endif /* ! __GNUC__ */ + +#define gfun(xyzxyz) (*Rgfun((struct Sap *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgarg(struct Sap *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ap) + fprintf(stderr,"garg: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgarg); +} +#else /* ! __GNUC__ */ +extern tree *Rgarg PROTO((struct Sap *)); +#endif /* ! __GNUC__ */ + +#define garg(xyzxyz) (*Rgarg((struct Sap *) (xyzxyz))) + +extern tree mklambda PROTO((list, tree, long)); +#ifdef __GNUC__ + +extern __inline__ list *Rglampats(struct Slambda *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lambda) + fprintf(stderr,"glampats: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglampats); +} +#else /* ! __GNUC__ */ +extern list *Rglampats PROTO((struct Slambda *)); +#endif /* ! __GNUC__ */ + +#define glampats(xyzxyz) (*Rglampats((struct Slambda *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rglamexpr(struct Slambda *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lambda) + fprintf(stderr,"glamexpr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglamexpr); +} +#else /* ! __GNUC__ */ +extern tree *Rglamexpr PROTO((struct Slambda *)); +#endif /* ! __GNUC__ */ + +#define glamexpr(xyzxyz) (*Rglamexpr((struct Slambda *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ long *Rglamline(struct Slambda *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lambda) + fprintf(stderr,"glamline: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglamline); +} +#else /* ! __GNUC__ */ +extern long *Rglamline PROTO((struct Slambda *)); +#endif /* ! __GNUC__ */ + +#define glamline(xyzxyz) (*Rglamline((struct Slambda *) (xyzxyz))) + +extern tree mklet PROTO((binding, tree)); +#ifdef __GNUC__ + +extern __inline__ binding *Rgletvdeflist(struct Slet *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != let) + fprintf(stderr,"gletvdeflist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgletvdeflist); +} +#else /* ! __GNUC__ */ +extern binding *Rgletvdeflist PROTO((struct Slet *)); +#endif /* ! __GNUC__ */ + +#define gletvdeflist(xyzxyz) (*Rgletvdeflist((struct Slet *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgletvexpr(struct Slet *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != let) + fprintf(stderr,"gletvexpr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgletvexpr); +} +#else /* ! __GNUC__ */ +extern tree *Rgletvexpr PROTO((struct Slet *)); +#endif /* ! __GNUC__ */ + +#define gletvexpr(xyzxyz) (*Rgletvexpr((struct Slet *) (xyzxyz))) + +extern tree mkcasee PROTO((tree, list)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgcaseexpr(struct Scasee *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != casee) + fprintf(stderr,"gcaseexpr: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcaseexpr); +} +#else /* ! __GNUC__ */ +extern tree *Rgcaseexpr PROTO((struct Scasee *)); +#endif /* ! __GNUC__ */ + +#define gcaseexpr(xyzxyz) (*Rgcaseexpr((struct Scasee *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcasebody(struct Scasee *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != casee) + fprintf(stderr,"gcasebody: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcasebody); +} +#else /* ! __GNUC__ */ +extern list *Rgcasebody PROTO((struct Scasee *)); +#endif /* ! __GNUC__ */ + +#define gcasebody(xyzxyz) (*Rgcasebody((struct Scasee *) (xyzxyz))) + +extern tree mkife PROTO((tree, tree, tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgifpred(struct Sife *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ife) + fprintf(stderr,"gifpred: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgifpred); +} +#else /* ! __GNUC__ */ +extern tree *Rgifpred PROTO((struct Sife *)); +#endif /* ! __GNUC__ */ + +#define gifpred(xyzxyz) (*Rgifpred((struct Sife *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgifthen(struct Sife *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ife) + fprintf(stderr,"gifthen: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgifthen); +} +#else /* ! __GNUC__ */ +extern tree *Rgifthen PROTO((struct Sife *)); +#endif /* ! __GNUC__ */ + +#define gifthen(xyzxyz) (*Rgifthen((struct Sife *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgifelse(struct Sife *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ife) + fprintf(stderr,"gifelse: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgifelse); +} +#else /* ! __GNUC__ */ +extern tree *Rgifelse PROTO((struct Sife *)); +#endif /* ! __GNUC__ */ + +#define gifelse(xyzxyz) (*Rgifelse((struct Sife *) (xyzxyz))) + +extern tree mkpar PROTO((tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgpare(struct Spar *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != par) + fprintf(stderr,"gpare: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgpare); +} +#else /* ! __GNUC__ */ +extern tree *Rgpare PROTO((struct Spar *)); +#endif /* ! __GNUC__ */ + +#define gpare(xyzxyz) (*Rgpare((struct Spar *) (xyzxyz))) + +extern tree mkas PROTO((unkId, tree)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgasid(struct Sas *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != as) + fprintf(stderr,"gasid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgasid); +} +#else /* ! __GNUC__ */ +extern unkId *Rgasid PROTO((struct Sas *)); +#endif /* ! __GNUC__ */ + +#define gasid(xyzxyz) (*Rgasid((struct Sas *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgase(struct Sas *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != as) + fprintf(stderr,"gase: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgase); +} +#else /* ! __GNUC__ */ +extern tree *Rgase PROTO((struct Sas *)); +#endif /* ! __GNUC__ */ + +#define gase(xyzxyz) (*Rgase((struct Sas *) (xyzxyz))) + +extern tree mklazyp PROTO((tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rglazyp(struct Slazyp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lazyp) + fprintf(stderr,"glazyp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglazyp); +} +#else /* ! __GNUC__ */ +extern tree *Rglazyp PROTO((struct Slazyp *)); +#endif /* ! __GNUC__ */ + +#define glazyp(xyzxyz) (*Rglazyp((struct Slazyp *) (xyzxyz))) + +extern tree mkplusp PROTO((tree, literal)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgplusp(struct Splusp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != plusp) + fprintf(stderr,"gplusp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgplusp); +} +#else /* ! __GNUC__ */ +extern tree *Rgplusp PROTO((struct Splusp *)); +#endif /* ! __GNUC__ */ + +#define gplusp(xyzxyz) (*Rgplusp((struct Splusp *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ literal *Rgplusi(struct Splusp *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != plusp) + fprintf(stderr,"gplusi: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgplusi); +} +#else /* ! __GNUC__ */ +extern literal *Rgplusi PROTO((struct Splusp *)); +#endif /* ! __GNUC__ */ + +#define gplusi(xyzxyz) (*Rgplusi((struct Splusp *) (xyzxyz))) + +extern tree mkwildp PROTO(()); + +extern tree mkrestr PROTO((tree, ttype)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgrestre(struct Srestr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != restr) + fprintf(stderr,"grestre: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrestre); +} +#else /* ! __GNUC__ */ +extern tree *Rgrestre PROTO((struct Srestr *)); +#endif /* ! __GNUC__ */ + +#define grestre(xyzxyz) (*Rgrestre((struct Srestr *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgrestrt(struct Srestr *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != restr) + fprintf(stderr,"grestrt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrestrt); +} +#else /* ! __GNUC__ */ +extern ttype *Rgrestrt PROTO((struct Srestr *)); +#endif /* ! __GNUC__ */ + +#define grestrt(xyzxyz) (*Rgrestrt((struct Srestr *) (xyzxyz))) + +extern tree mkcomprh PROTO((tree, list)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgcexp(struct Scomprh *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != comprh) + fprintf(stderr,"gcexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcexp); +} +#else /* ! __GNUC__ */ +extern tree *Rgcexp PROTO((struct Scomprh *)); +#endif /* ! __GNUC__ */ + +#define gcexp(xyzxyz) (*Rgcexp((struct Scomprh *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgcquals(struct Scomprh *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != comprh) + fprintf(stderr,"gcquals: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgcquals); +} +#else /* ! __GNUC__ */ +extern list *Rgcquals PROTO((struct Scomprh *)); +#endif /* ! __GNUC__ */ + +#define gcquals(xyzxyz) (*Rgcquals((struct Scomprh *) (xyzxyz))) + +extern tree mkqual PROTO((tree, tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgqpat(struct Squal *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != qual) + fprintf(stderr,"gqpat: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgqpat); +} +#else /* ! __GNUC__ */ +extern tree *Rgqpat PROTO((struct Squal *)); +#endif /* ! __GNUC__ */ + +#define gqpat(xyzxyz) (*Rgqpat((struct Squal *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgqexp(struct Squal *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != qual) + fprintf(stderr,"gqexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgqexp); +} +#else /* ! __GNUC__ */ +extern tree *Rgqexp PROTO((struct Squal *)); +#endif /* ! __GNUC__ */ + +#define gqexp(xyzxyz) (*Rgqexp((struct Squal *) (xyzxyz))) + +extern tree mkguard PROTO((tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rggexp(struct Sguard *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != guard) + fprintf(stderr,"ggexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggexp); +} +#else /* ! __GNUC__ */ +extern tree *Rggexp PROTO((struct Sguard *)); +#endif /* ! __GNUC__ */ + +#define ggexp(xyzxyz) (*Rggexp((struct Sguard *) (xyzxyz))) + +extern tree mkdef PROTO((tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rggdef(struct Sdef *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != def) + fprintf(stderr,"ggdef: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xggdef); +} +#else /* ! __GNUC__ */ +extern tree *Rggdef PROTO((struct Sdef *)); +#endif /* ! __GNUC__ */ + +#define ggdef(xyzxyz) (*Rggdef((struct Sdef *) (xyzxyz))) + +extern tree mktinfixop PROTO((infixTree)); +#ifdef __GNUC__ + +extern __inline__ infixTree *Rgdummy(struct Stinfixop *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tinfixop) + fprintf(stderr,"gdummy: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgdummy); +} +#else /* ! __GNUC__ */ +extern infixTree *Rgdummy PROTO((struct Stinfixop *)); +#endif /* ! __GNUC__ */ + +#define gdummy(xyzxyz) (*Rgdummy((struct Stinfixop *) (xyzxyz))) + +extern tree mklsection PROTO((tree, unkId)); +#ifdef __GNUC__ + +extern __inline__ tree *Rglsexp(struct Slsection *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lsection) + fprintf(stderr,"glsexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglsexp); +} +#else /* ! __GNUC__ */ +extern tree *Rglsexp PROTO((struct Slsection *)); +#endif /* ! __GNUC__ */ + +#define glsexp(xyzxyz) (*Rglsexp((struct Slsection *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ unkId *Rglsop(struct Slsection *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != lsection) + fprintf(stderr,"glsop: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xglsop); +} +#else /* ! __GNUC__ */ +extern unkId *Rglsop PROTO((struct Slsection *)); +#endif /* ! __GNUC__ */ + +#define glsop(xyzxyz) (*Rglsop((struct Slsection *) (xyzxyz))) + +extern tree mkrsection PROTO((unkId, tree)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgrsop(struct Srsection *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != rsection) + fprintf(stderr,"grsop: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrsop); +} +#else /* ! __GNUC__ */ +extern unkId *Rgrsop PROTO((struct Srsection *)); +#endif /* ! __GNUC__ */ + +#define grsop(xyzxyz) (*Rgrsop((struct Srsection *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgrsexp(struct Srsection *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != rsection) + fprintf(stderr,"grsexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgrsexp); +} +#else /* ! __GNUC__ */ +extern tree *Rgrsexp PROTO((struct Srsection *)); +#endif /* ! __GNUC__ */ + +#define grsexp(xyzxyz) (*Rgrsexp((struct Srsection *) (xyzxyz))) + +extern tree mkeenum PROTO((tree, list, list)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgefrom(struct Seenum *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != eenum) + fprintf(stderr,"gefrom: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgefrom); +} +#else /* ! __GNUC__ */ +extern tree *Rgefrom PROTO((struct Seenum *)); +#endif /* ! __GNUC__ */ + +#define gefrom(xyzxyz) (*Rgefrom((struct Seenum *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgestep(struct Seenum *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != eenum) + fprintf(stderr,"gestep: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgestep); +} +#else /* ! __GNUC__ */ +extern list *Rgestep PROTO((struct Seenum *)); +#endif /* ! __GNUC__ */ + +#define gestep(xyzxyz) (*Rgestep((struct Seenum *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgeto(struct Seenum *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != eenum) + fprintf(stderr,"geto: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgeto); +} +#else /* ! __GNUC__ */ +extern list *Rgeto PROTO((struct Seenum *)); +#endif /* ! __GNUC__ */ + +#define geto(xyzxyz) (*Rgeto((struct Seenum *) (xyzxyz))) + +extern tree mkllist PROTO((list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgllist(struct Sllist *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != llist) + fprintf(stderr,"gllist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgllist); +} +#else /* ! __GNUC__ */ +extern list *Rgllist PROTO((struct Sllist *)); +#endif /* ! __GNUC__ */ + +#define gllist(xyzxyz) (*Rgllist((struct Sllist *) (xyzxyz))) + +extern tree mkccall PROTO((stringId, stringId, list)); +#ifdef __GNUC__ + +extern __inline__ stringId *Rgccid(struct Sccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ccall) + fprintf(stderr,"gccid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgccid); +} +#else /* ! __GNUC__ */ +extern stringId *Rgccid PROTO((struct Sccall *)); +#endif /* ! __GNUC__ */ + +#define gccid(xyzxyz) (*Rgccid((struct Sccall *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ stringId *Rgccinfo(struct Sccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ccall) + fprintf(stderr,"gccinfo: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgccinfo); +} +#else /* ! __GNUC__ */ +extern stringId *Rgccinfo PROTO((struct Sccall *)); +#endif /* ! __GNUC__ */ + +#define gccinfo(xyzxyz) (*Rgccinfo((struct Sccall *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgccargs(struct Sccall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ccall) + fprintf(stderr,"gccargs: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgccargs); +} +#else /* ! __GNUC__ */ +extern list *Rgccargs PROTO((struct Sccall *)); +#endif /* ! __GNUC__ */ + +#define gccargs(xyzxyz) (*Rgccargs((struct Sccall *) (xyzxyz))) + +extern tree mkscc PROTO((hstring, tree)); +#ifdef __GNUC__ + +extern __inline__ hstring *Rgsccid(struct Sscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != scc) + fprintf(stderr,"gsccid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsccid); +} +#else /* ! __GNUC__ */ +extern hstring *Rgsccid PROTO((struct Sscc *)); +#endif /* ! __GNUC__ */ + +#define gsccid(xyzxyz) (*Rgsccid((struct Sscc *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ tree *Rgsccexp(struct Sscc *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != scc) + fprintf(stderr,"gsccexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgsccexp); +} +#else /* ! __GNUC__ */ +extern tree *Rgsccexp PROTO((struct Sscc *)); +#endif /* ! __GNUC__ */ + +#define gsccexp(xyzxyz) (*Rgsccexp((struct Sscc *) (xyzxyz))) + +extern tree mknegate PROTO((tree)); +#ifdef __GNUC__ + +extern __inline__ tree *Rgnexp(struct Snegate *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != negate) + fprintf(stderr,"gnexp: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnexp); +} +#else /* ! __GNUC__ */ +extern tree *Rgnexp PROTO((struct Snegate *)); +#endif /* ! __GNUC__ */ + +#define gnexp(xyzxyz) (*Rgnexp((struct Snegate *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/tree.ugn b/ghc/compiler/yaccParser/tree.ugn new file mode 100644 index 0000000..dd8715d --- /dev/null +++ b/ghc/compiler/yaccParser/tree.ugn @@ -0,0 +1,80 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_tree where +import UgenUtil +import Util + +import U_binding +import U_coresyn ( U_coresyn ) -- interface only +import U_hpragma ( U_hpragma ) -- interface only +import U_list +import U_literal +import U_ttype + +type U_infixTree = (ProtoName, U_tree, U_tree) + +rdU_infixTree :: _Addr -> UgnM U_infixTree +rdU_infixTree pt + = ioToUgnM (_casm_ ``%r = gident(*Rginfun_hs((struct Sap *)%0));'' pt) `thenUgn` \ op_t -> + ioToUgnM (_casm_ ``%r = (*Rginarg1_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t -> + ioToUgnM (_casm_ ``%r = (*Rginarg2_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t -> + + rdU_unkId op_t `thenUgn` \ op -> + rdU_tree arg1_t `thenUgn` \ arg1 -> + rdU_tree arg2_t `thenUgn` \ arg2 -> + returnUgn (op, arg1, arg2) +%}} +type tree; + hmodule : < ghname : stringId; + ghimplist : list; + ghexplist : list; + ghmodlist : binding; + ghmodline : long; >; + ident : < gident : unkId; >; + lit : < glit : literal; >; + tuple : < gtuplelist : list; >; + ap : < gfun : tree; + garg : tree; >; + lambda : < glampats : list; + glamexpr : tree; + glamline : long; >; + let : < gletvdeflist : binding; + gletvexpr : tree; >; + casee : < gcaseexpr : tree; + gcasebody : list; >; + ife : < gifpred : tree; + gifthen : tree; + gifelse : tree; >; + par : < gpare : tree; >; + as : < gasid : unkId; + gase : tree; >; + lazyp : < glazyp : tree; >; + plusp : < gplusp : tree; + gplusi : literal; >; + wildp : < >; + restr : < grestre : tree; + grestrt : ttype; >; + comprh : < gcexp : tree; + gcquals : list; >; + qual : < gqpat : tree; + gqexp : tree; >; + guard : < ggexp : tree; >; + def : < ggdef : tree; >; + tinfixop: < gdummy : infixTree; >; + lsection: < glsexp : tree; + glsop : unkId; >; + rsection: < grsop : unkId; + grsexp : tree; >; + eenum : < gefrom : tree; + gestep : list; + geto : list; >; + llist : < gllist : list; >; + ccall : < gccid : stringId; + gccinfo : stringId; + gccargs : list; >; + scc : < gsccid : hstring; + gsccexp : tree; >; + negate : < gnexp : tree; >; +end; diff --git a/ghc/compiler/yaccParser/ttype-DPH.ugn b/ghc/compiler/yaccParser/ttype-DPH.ugn new file mode 100644 index 0000000..dd0209b --- /dev/null +++ b/ghc/compiler/yaccParser/ttype-DPH.ugn @@ -0,0 +1,23 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_ttype where +import UgenUtil +import Util +%}} +type ttype; + tname : < gtypeid : id; + gtypel : list; >; + namedtvar : < gnamedtvar : id; >; + tllist : < gtlist : ttype; >; + ttuple : < gttuple : list; >; + tfun : < gtfun : ttype; + gtarg : ttype; >; + context : < gtcontextl : list; + gtcontextt : ttype; >; + tproc : < gtpid : list; + gtdata : ttype; >; + tpod : < gtpod : ttype; >; +end; + diff --git a/ghc/compiler/yaccParser/ttype.c b/ghc/compiler/yaccParser/ttype.c new file mode 100644 index 0000000..caf561b --- /dev/null +++ b/ghc/compiler/yaccParser/ttype.c @@ -0,0 +1,301 @@ + + +#include "hspincl.h" +#include "yaccParser/ttype.h" + +Tttype tttype(t) + ttype t; +{ + return(t -> tag); +} + + +/************** tname ******************/ + +ttype mktname(PPgtypeid, PPgtypel) + unkId PPgtypeid; + list PPgtypel; +{ + register struct Stname *pp = + (struct Stname *) malloc(sizeof(struct Stname)); + pp -> tag = tname; + pp -> Xgtypeid = PPgtypeid; + pp -> Xgtypel = PPgtypel; + return((ttype)pp); +} + +unkId *Rgtypeid(t) + struct Stname *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tname) + fprintf(stderr,"gtypeid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtypeid); +} + +list *Rgtypel(t) + struct Stname *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tname) + fprintf(stderr,"gtypel: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtypel); +} + +/************** namedtvar ******************/ + +ttype mknamedtvar(PPgnamedtvar) + unkId PPgnamedtvar; +{ + register struct Snamedtvar *pp = + (struct Snamedtvar *) malloc(sizeof(struct Snamedtvar)); + pp -> tag = namedtvar; + pp -> Xgnamedtvar = PPgnamedtvar; + return((ttype)pp); +} + +unkId *Rgnamedtvar(t) + struct Snamedtvar *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != namedtvar) + fprintf(stderr,"gnamedtvar: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnamedtvar); +} + +/************** tllist ******************/ + +ttype mktllist(PPgtlist) + ttype PPgtlist; +{ + register struct Stllist *pp = + (struct Stllist *) malloc(sizeof(struct Stllist)); + pp -> tag = tllist; + pp -> Xgtlist = PPgtlist; + return((ttype)pp); +} + +ttype *Rgtlist(t) + struct Stllist *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tllist) + fprintf(stderr,"gtlist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtlist); +} + +/************** ttuple ******************/ + +ttype mkttuple(PPgttuple) + list PPgttuple; +{ + register struct Sttuple *pp = + (struct Sttuple *) malloc(sizeof(struct Sttuple)); + pp -> tag = ttuple; + pp -> Xgttuple = PPgttuple; + return((ttype)pp); +} + +list *Rgttuple(t) + struct Sttuple *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ttuple) + fprintf(stderr,"gttuple: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgttuple); +} + +/************** tfun ******************/ + +ttype mktfun(PPgtfun, PPgtarg) + ttype PPgtfun; + ttype PPgtarg; +{ + register struct Stfun *pp = + (struct Stfun *) malloc(sizeof(struct Stfun)); + pp -> tag = tfun; + pp -> Xgtfun = PPgtfun; + pp -> Xgtarg = PPgtarg; + return((ttype)pp); +} + +ttype *Rgtfun(t) + struct Stfun *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tfun) + fprintf(stderr,"gtfun: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtfun); +} + +ttype *Rgtarg(t) + struct Stfun *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != tfun) + fprintf(stderr,"gtarg: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtarg); +} + +/************** context ******************/ + +ttype mkcontext(PPgtcontextl, PPgtcontextt) + list PPgtcontextl; + ttype PPgtcontextt; +{ + register struct Scontext *pp = + (struct Scontext *) malloc(sizeof(struct Scontext)); + pp -> tag = context; + pp -> Xgtcontextl = PPgtcontextl; + pp -> Xgtcontextt = PPgtcontextt; + return((ttype)pp); +} + +list *Rgtcontextl(t) + struct Scontext *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != context) + fprintf(stderr,"gtcontextl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtcontextl); +} + +ttype *Rgtcontextt(t) + struct Scontext *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != context) + fprintf(stderr,"gtcontextt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtcontextt); +} + +/************** unidict ******************/ + +ttype mkunidict(PPgunidict_clas, PPgunidict_ty) + unkId PPgunidict_clas; + ttype PPgunidict_ty; +{ + register struct Sunidict *pp = + (struct Sunidict *) malloc(sizeof(struct Sunidict)); + pp -> tag = unidict; + pp -> Xgunidict_clas = PPgunidict_clas; + pp -> Xgunidict_ty = PPgunidict_ty; + return((ttype)pp); +} + +unkId *Rgunidict_clas(t) + struct Sunidict *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != unidict) + fprintf(stderr,"gunidict_clas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgunidict_clas); +} + +ttype *Rgunidict_ty(t) + struct Sunidict *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != unidict) + fprintf(stderr,"gunidict_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgunidict_ty); +} + +/************** unityvartemplate ******************/ + +ttype mkunityvartemplate(PPgunityvartemplate) + unkId PPgunityvartemplate; +{ + register struct Sunityvartemplate *pp = + (struct Sunityvartemplate *) malloc(sizeof(struct Sunityvartemplate)); + pp -> tag = unityvartemplate; + pp -> Xgunityvartemplate = PPgunityvartemplate; + return((ttype)pp); +} + +unkId *Rgunityvartemplate(t) + struct Sunityvartemplate *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != unityvartemplate) + fprintf(stderr,"gunityvartemplate: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgunityvartemplate); +} + +/************** uniforall ******************/ + +ttype mkuniforall(PPguniforall_tv, PPguniforall_ty) + list PPguniforall_tv; + ttype PPguniforall_ty; +{ + register struct Suniforall *pp = + (struct Suniforall *) malloc(sizeof(struct Suniforall)); + pp -> tag = uniforall; + pp -> Xguniforall_tv = PPguniforall_tv; + pp -> Xguniforall_ty = PPguniforall_ty; + return((ttype)pp); +} + +list *Rguniforall_tv(t) + struct Suniforall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != uniforall) + fprintf(stderr,"guniforall_tv: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xguniforall_tv); +} + +ttype *Rguniforall_ty(t) + struct Suniforall *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != uniforall) + fprintf(stderr,"guniforall_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xguniforall_ty); +} + +/************** ty_maybe_nothing ******************/ + +ttype mkty_maybe_nothing() +{ + register struct Sty_maybe_nothing *pp = + (struct Sty_maybe_nothing *) malloc(sizeof(struct Sty_maybe_nothing)); + pp -> tag = ty_maybe_nothing; + return((ttype)pp); +} + +/************** ty_maybe_just ******************/ + +ttype mkty_maybe_just(PPgty_maybe) + ttype PPgty_maybe; +{ + register struct Sty_maybe_just *pp = + (struct Sty_maybe_just *) malloc(sizeof(struct Sty_maybe_just)); + pp -> tag = ty_maybe_just; + pp -> Xgty_maybe = PPgty_maybe; + return((ttype)pp); +} + +ttype *Rgty_maybe(t) + struct Sty_maybe_just *t; +{ +#ifdef UGEN_DEBUG + if(t -> tag != ty_maybe_just) + fprintf(stderr,"gty_maybe: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgty_maybe); +} diff --git a/ghc/compiler/yaccParser/ttype.h b/ghc/compiler/yaccParser/ttype.h new file mode 100644 index 0000000..ced12b6 --- /dev/null +++ b/ghc/compiler/yaccParser/ttype.h @@ -0,0 +1,345 @@ +#ifndef ttype_defined +#define ttype_defined + +#include + +#ifndef PROTO +#ifdef __STDC__ +#define PROTO(x) x +#else +#define PROTO(x) /**/ +#endif +#endif + +typedef enum { + tname, + namedtvar, + tllist, + ttuple, + tfun, + context, + unidict, + unityvartemplate, + uniforall, + ty_maybe_nothing, + ty_maybe_just +} Tttype; + +typedef struct { Tttype tag; } *ttype; + +#ifdef __GNUC__ +extern __inline__ Tttype tttype(ttype t) +{ + return(t -> tag); +} +#else /* ! __GNUC__ */ +extern Tttype tttype PROTO((ttype)); +#endif /* ! __GNUC__ */ + +struct Stname { + Tttype tag; + unkId Xgtypeid; + list Xgtypel; +}; + +struct Snamedtvar { + Tttype tag; + unkId Xgnamedtvar; +}; + +struct Stllist { + Tttype tag; + ttype Xgtlist; +}; + +struct Sttuple { + Tttype tag; + list Xgttuple; +}; + +struct Stfun { + Tttype tag; + ttype Xgtfun; + ttype Xgtarg; +}; + +struct Scontext { + Tttype tag; + list Xgtcontextl; + ttype Xgtcontextt; +}; + +struct Sunidict { + Tttype tag; + unkId Xgunidict_clas; + ttype Xgunidict_ty; +}; + +struct Sunityvartemplate { + Tttype tag; + unkId Xgunityvartemplate; +}; + +struct Suniforall { + Tttype tag; + list Xguniforall_tv; + ttype Xguniforall_ty; +}; + +struct Sty_maybe_nothing { + Tttype tag; +}; + +struct Sty_maybe_just { + Tttype tag; + ttype Xgty_maybe; +}; + +extern ttype mktname PROTO((unkId, list)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgtypeid(struct Stname *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tname) + fprintf(stderr,"gtypeid: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtypeid); +} +#else /* ! __GNUC__ */ +extern unkId *Rgtypeid PROTO((struct Stname *)); +#endif /* ! __GNUC__ */ + +#define gtypeid(xyzxyz) (*Rgtypeid((struct Stname *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ list *Rgtypel(struct Stname *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tname) + fprintf(stderr,"gtypel: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtypel); +} +#else /* ! __GNUC__ */ +extern list *Rgtypel PROTO((struct Stname *)); +#endif /* ! __GNUC__ */ + +#define gtypel(xyzxyz) (*Rgtypel((struct Stname *) (xyzxyz))) + +extern ttype mknamedtvar PROTO((unkId)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgnamedtvar(struct Snamedtvar *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != namedtvar) + fprintf(stderr,"gnamedtvar: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgnamedtvar); +} +#else /* ! __GNUC__ */ +extern unkId *Rgnamedtvar PROTO((struct Snamedtvar *)); +#endif /* ! __GNUC__ */ + +#define gnamedtvar(xyzxyz) (*Rgnamedtvar((struct Snamedtvar *) (xyzxyz))) + +extern ttype mktllist PROTO((ttype)); +#ifdef __GNUC__ + +extern __inline__ ttype *Rgtlist(struct Stllist *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tllist) + fprintf(stderr,"gtlist: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtlist); +} +#else /* ! __GNUC__ */ +extern ttype *Rgtlist PROTO((struct Stllist *)); +#endif /* ! __GNUC__ */ + +#define gtlist(xyzxyz) (*Rgtlist((struct Stllist *) (xyzxyz))) + +extern ttype mkttuple PROTO((list)); +#ifdef __GNUC__ + +extern __inline__ list *Rgttuple(struct Sttuple *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ttuple) + fprintf(stderr,"gttuple: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgttuple); +} +#else /* ! __GNUC__ */ +extern list *Rgttuple PROTO((struct Sttuple *)); +#endif /* ! __GNUC__ */ + +#define gttuple(xyzxyz) (*Rgttuple((struct Sttuple *) (xyzxyz))) + +extern ttype mktfun PROTO((ttype, ttype)); +#ifdef __GNUC__ + +extern __inline__ ttype *Rgtfun(struct Stfun *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tfun) + fprintf(stderr,"gtfun: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtfun); +} +#else /* ! __GNUC__ */ +extern ttype *Rgtfun PROTO((struct Stfun *)); +#endif /* ! __GNUC__ */ + +#define gtfun(xyzxyz) (*Rgtfun((struct Stfun *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgtarg(struct Stfun *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != tfun) + fprintf(stderr,"gtarg: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtarg); +} +#else /* ! __GNUC__ */ +extern ttype *Rgtarg PROTO((struct Stfun *)); +#endif /* ! __GNUC__ */ + +#define gtarg(xyzxyz) (*Rgtarg((struct Stfun *) (xyzxyz))) + +extern ttype mkcontext PROTO((list, ttype)); +#ifdef __GNUC__ + +extern __inline__ list *Rgtcontextl(struct Scontext *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != context) + fprintf(stderr,"gtcontextl: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtcontextl); +} +#else /* ! __GNUC__ */ +extern list *Rgtcontextl PROTO((struct Scontext *)); +#endif /* ! __GNUC__ */ + +#define gtcontextl(xyzxyz) (*Rgtcontextl((struct Scontext *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgtcontextt(struct Scontext *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != context) + fprintf(stderr,"gtcontextt: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgtcontextt); +} +#else /* ! __GNUC__ */ +extern ttype *Rgtcontextt PROTO((struct Scontext *)); +#endif /* ! __GNUC__ */ + +#define gtcontextt(xyzxyz) (*Rgtcontextt((struct Scontext *) (xyzxyz))) + +extern ttype mkunidict PROTO((unkId, ttype)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgunidict_clas(struct Sunidict *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != unidict) + fprintf(stderr,"gunidict_clas: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgunidict_clas); +} +#else /* ! __GNUC__ */ +extern unkId *Rgunidict_clas PROTO((struct Sunidict *)); +#endif /* ! __GNUC__ */ + +#define gunidict_clas(xyzxyz) (*Rgunidict_clas((struct Sunidict *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rgunidict_ty(struct Sunidict *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != unidict) + fprintf(stderr,"gunidict_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgunidict_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rgunidict_ty PROTO((struct Sunidict *)); +#endif /* ! __GNUC__ */ + +#define gunidict_ty(xyzxyz) (*Rgunidict_ty((struct Sunidict *) (xyzxyz))) + +extern ttype mkunityvartemplate PROTO((unkId)); +#ifdef __GNUC__ + +extern __inline__ unkId *Rgunityvartemplate(struct Sunityvartemplate *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != unityvartemplate) + fprintf(stderr,"gunityvartemplate: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgunityvartemplate); +} +#else /* ! __GNUC__ */ +extern unkId *Rgunityvartemplate PROTO((struct Sunityvartemplate *)); +#endif /* ! __GNUC__ */ + +#define gunityvartemplate(xyzxyz) (*Rgunityvartemplate((struct Sunityvartemplate *) (xyzxyz))) + +extern ttype mkuniforall PROTO((list, ttype)); +#ifdef __GNUC__ + +extern __inline__ list *Rguniforall_tv(struct Suniforall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != uniforall) + fprintf(stderr,"guniforall_tv: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xguniforall_tv); +} +#else /* ! __GNUC__ */ +extern list *Rguniforall_tv PROTO((struct Suniforall *)); +#endif /* ! __GNUC__ */ + +#define guniforall_tv(xyzxyz) (*Rguniforall_tv((struct Suniforall *) (xyzxyz))) +#ifdef __GNUC__ + +extern __inline__ ttype *Rguniforall_ty(struct Suniforall *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != uniforall) + fprintf(stderr,"guniforall_ty: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xguniforall_ty); +} +#else /* ! __GNUC__ */ +extern ttype *Rguniforall_ty PROTO((struct Suniforall *)); +#endif /* ! __GNUC__ */ + +#define guniforall_ty(xyzxyz) (*Rguniforall_ty((struct Suniforall *) (xyzxyz))) + +extern ttype mkty_maybe_nothing PROTO(()); + +extern ttype mkty_maybe_just PROTO((ttype)); +#ifdef __GNUC__ + +extern __inline__ ttype *Rgty_maybe(struct Sty_maybe_just *t) +{ +#ifdef UGEN_DEBUG + if(t -> tag != ty_maybe_just) + fprintf(stderr,"gty_maybe: illegal selection; was %d\n", t -> tag); +#endif /* UGEN_DEBUG */ + return(& t -> Xgty_maybe); +} +#else /* ! __GNUC__ */ +extern ttype *Rgty_maybe PROTO((struct Sty_maybe_just *)); +#endif /* ! __GNUC__ */ + +#define gty_maybe(xyzxyz) (*Rgty_maybe((struct Sty_maybe_just *) (xyzxyz))) + +#endif diff --git a/ghc/compiler/yaccParser/ttype.ugn b/ghc/compiler/yaccParser/ttype.ugn new file mode 100644 index 0000000..63ed306 --- /dev/null +++ b/ghc/compiler/yaccParser/ttype.ugn @@ -0,0 +1,31 @@ +%{ +#include "hspincl.h" +%} +%{{ +module U_ttype where +import UgenUtil +import Util + +import U_list +%}} +type ttype; + tname : < gtypeid : unkId; + gtypel : list; >; + namedtvar : < gnamedtvar : unkId; >; + tllist : < gtlist : ttype; >; + ttuple : < gttuple : list; >; + tfun : < gtfun : ttype; + gtarg : ttype; >; + context : < gtcontextl : list; + gtcontextt : ttype; >; + + unidict : < gunidict_clas : unkId; + gunidict_ty : ttype; >; + unityvartemplate: ; + uniforall : < guniforall_tv : list; + guniforall_ty : ttype; >; + + ty_maybe_nothing : < >; + ty_maybe_just : < gty_maybe : ttype; >; +end; + diff --git a/ghc/compiler/yaccParser/type2context.c b/ghc/compiler/yaccParser/type2context.c new file mode 100644 index 0000000..185dc64 --- /dev/null +++ b/ghc/compiler/yaccParser/type2context.c @@ -0,0 +1,160 @@ +/********************************************************************** +* * +* * +* Convert Types to Contexts * +* * +* * +**********************************************************************/ + + +#include +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/* Imported Values */ +extern list Lnil; + +VOID is_context_format PROTO((ttype)); /* forward */ + +/* + partain: see also the comment by "decl" in hsparser.y. + + Here, we've been given a type that must be of the form + "C a" or "(C1 a, C2 a, ...)" [otherwise an error] + + Convert it to a list. +*/ + + +list +type2context(t) + ttype t; +{ + char *tycon_name; + list args, rest_args; + ttype first_arg; + + switch (tttype(t)) { + case ttuple: + /* returning the list is OK, but ensure items are right format */ + args = gttuple(t); + + if (tlist(args) == lnil) + hsperror ("type2context: () found instead of a context"); + + while (tlist(args) != lnil) + { + is_context_format(lhd(args)); + args = ltl(args); + } + + return(gttuple(t)); /* args */ + + + case tname : + tycon_name = gtypeid(t); + + /* just a class name ":: C =>" */ + if (tlist(gtypel(t)) == lnil) + return (mklcons(t, Lnil)); + + /* should be just: ":: C a =>" */ + else + { + first_arg = (ttype) lhd(gtypel(t)); + rest_args = ltl(gtypel(t)); /* should be nil */ + + if (tlist(rest_args) != lnil) + hsperror ("type2context: too many variables after class name"); + + switch (tttype(first_arg)) + { + case namedtvar: /* ToDo: right? */ + return (mklcons(t, Lnil)); + break; + + default: + hsperror ("type2context: something wrong with variable after class name"); + } + } + break; + + case namedtvar: + hsperror ("type2context: unexpected namedtvar found in a context"); + + case tllist: + hsperror ("type2context: list constructor found in a context"); + + case tfun: + hsperror ("type2context: arrow (->) constructor found in a context"); + + case context: + hsperror ("type2context: unexpected context-thing found in a context"); + + default : + hsperror ("type2context: totally unexpected input"); + } + abort(); /* should never get here! */ +} + + +/* is_context_format is the same as "type2context" except that it just performs checking */ +/* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */ + +VOID +is_context_format(t) + ttype t; +{ + char *tycon_name; + list rest_args; + ttype first_arg; + + switch (tttype(t)) + { + case tname : + tycon_name = gtypeid(t); + + /* just a class name ":: C =>" */ + if (tlist(gtypel(t)) == lnil) + hsperror("is_context_format: variable missing after class name"); + + /* should be just: ":: C a =>" */ + else + { + first_arg = (ttype) lhd(gtypel(t)); + rest_args = ltl(gtypel(t)); /* should be nil */ + if (tlist(rest_args) != lnil) + hsperror ("is_context_format: too many variables after class name"); + + switch (tttype(first_arg)) + { + case namedtvar: /* ToDo: right? */ + /* everything is cool; will fall off the end */ + break; + default: + hsperror ("is_context_format: something wrong with variable after class name"); + } + } + break; + + case ttuple: + hsperror ("is_context_format: tuple found in a context"); + + case namedtvar: + hsperror ("is_context_format: unexpected namedtvar found in a context"); + + case tllist: + hsperror ("is_context_format: list constructor found in a context"); + + case tfun: + hsperror ("is_context_format: arrow (->) constructor found in a context"); + + case context: + hsperror ("is_context_format: unexpected context-thing found in a context"); + + default: + hsperror ("is_context_format: totally unexpected input"); + } +} + diff --git a/ghc/compiler/yaccParser/util.c b/ghc/compiler/yaccParser/util.c new file mode 100644 index 0000000..5f72496 --- /dev/null +++ b/ghc/compiler/yaccParser/util.c @@ -0,0 +1,312 @@ +/********************************************************************** +* * +* * +* Declarations * +* * +* * +**********************************************************************/ + +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +#ifndef DPH +#define PARSER_VERSION "0.26" +#else +#define PARSER_VERSION "0.26 -- for Data Parallel Haskell" +#endif + +tree root; /* The root of the built syntax tree. */ +list Lnil; +list all; + +BOOLEAN nonstandardFlag = FALSE; /* Set if non-std Haskell extensions to be used. */ +BOOLEAN acceptPrim = FALSE; /* Set if Int#, etc., may be used */ +BOOLEAN haskell1_3Flag = FALSE; /* Set if we are doing (proto?) Haskell 1.3 */ +BOOLEAN etags = FALSE; /* Set if we're parsing only to produce tags. */ +BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */ + +BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */ +BOOLEAN warnSCC = FALSE; /* Set if we warn about ignored scc expressions. */ + +BOOLEAN implicitPrelude = TRUE; /* Set if we implicitly import the Prelude. */ +BOOLEAN ignorePragmas = FALSE; /* Set if we want to ignore pragmas */ + +/* From time to time, the format of interface files may change. + + So that we don't get gratuitous syntax errors or silently slurp in + junk info, two things: (a) the compiler injects a "this is a + version N interface": + + {-# GHC_PRAGMA INTERFACE VERSION #-} + + (b) this parser has a "minimum acceptable version", below which it + refuses to parse the pragmas (it just considers them as comments). + It also has a "maximum acceptable version", above which... + + The minimum is so a new parser won't try to grok overly-old + interfaces; the maximum (usually the current version number when + the parser was released) is so an old parser will not try to grok + since-upgraded interfaces. + + If an interface has no INTERFACE VERSION line, it is taken to be + version 0. +*/ +int minAcceptablePragmaVersion = 5; /* 0.26 or greater ONLY */ +int maxAcceptablePragmaVersion = 5; /* 0.26+ */ +int thisIfacePragmaVersion = 0; + +char *input_file_dir; /* The directory where the input file is. */ + +char HiSuffix[64] = ".hi"; /* can be changed with -h flag */ +char PreludeHiSuffix[64] = ".hi"; /* can be changed with -g flag */ + +BOOLEAN ExplicitHiSuffixGiven = 0; +static BOOLEAN verbose = FALSE; /* Set for verbose messages. */ + +/********************************************************************** +* * +* * +* Utility Functions * +* * +* * +**********************************************************************/ + +# include +# include "constants.h" +# include "hspincl.h" +# include "utils.h" + +void +process_args(argc,argv) + int argc; + char **argv; +{ + BOOLEAN keep_munging_option = FALSE; + +/*OLD: progname = argv[0]; */ + imports_dirlist = mklnil(); + sys_imports_dirlist = mklnil(); + + argc--, argv++; + + while (argc && argv[0][0] == '-') { + + keep_munging_option = TRUE; + + while (keep_munging_option && *++*argv != '\0') { + switch(**argv) { + + /* -I dir */ + case 'I': + imports_dirlist = lapp(imports_dirlist,*argv+1); + keep_munging_option = FALSE; + break; + + /* -J dir (for system imports) */ + case 'J': + sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1); + keep_munging_option = FALSE; + break; + + case 'g': + strcpy(PreludeHiSuffix, *argv+1); + keep_munging_option = FALSE; + break; + + case 'h': + strcpy(HiSuffix, *argv+1); + ExplicitHiSuffixGiven = 1; + keep_munging_option = FALSE; + break; + + case 'v': + who_am_i(); /* identify myself */ + verbose = TRUE; + break; + + case 'N': + nonstandardFlag = TRUE; + acceptPrim = TRUE; + break; + + case '3': + haskell1_3Flag = TRUE; + break; + + case 'S': + ignoreSCC = FALSE; + break; + + case 'W': + warnSCC = TRUE; + break; + + case 'p': + ignorePragmas = TRUE; + break; + + case 'P': + implicitPrelude = FALSE; + break; + + case 'D': +#ifdef HSP_DEBUG + { extern int yydebug; + yydebug = 1; + } +#endif + break; + + /* -Hn -- Use Hash Table, Size n (if given) */ + case 'H': + hashIds = TRUE; + if(*(*argv+1)!= '\0') + hash_table_size = atoi(*argv+1); + break; + case 'E': + etags = TRUE; + break; + } + } + argc--, argv++; + } + + if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) { + fprintf(stderr, "Cannot open %s.\n", argv[0]); + exit(1); + } + + if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) { + fprintf(stderr, "Cannot open %s.\n", argv[1]); + exit(1); + } + + + /* By default, imports come from the directory of the source file */ + if ( argc >= 1 ) + { + char *endchar; + + input_file_dir = xmalloc (strlen(argv[0]) + 1); + strcpy(input_file_dir, argv[0]); +#ifdef macintosh + endchar = rindex(input_file_dir, (int) ':'); +#else + endchar = rindex(input_file_dir, (int) '/'); +#endif /* ! macintosh */ + + if ( endchar == NULL ) + { + free(input_file_dir); + input_file_dir = "."; + } + else + *endchar = '\0'; + } + + /* No input file -- imports come from the current directory first */ + else + input_file_dir = "."; + + imports_dirlist = mklcons( input_file_dir, imports_dirlist ); + + if (verbose) + { + fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size); + if(acceptPrim) + fprintf(stderr,"Allowing special syntax for Unboxed Values\n"); + } +} + +void +error(s) + char *s; +{ +/*OLD: fprintf(stderr, "%s: Error %s\n", progname, s); */ + fprintf(stderr, "PARSER: Error %s\n", s); + exit(1); +} + +void +who_am_i() +{ + fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION); +} + +tree +mkbinop(s, l, r) + char *s; + tree l, r; +{ + return mkap(mkap(mkident(s), l), r); +} + +list +lconc(l1, l2) + list l1; + list l2; +{ + list t; + + if (tlist(l1) == lnil) + return(l2); + for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t)) + ; + ltl(t) = l2; + return(l1); +} + +list +lapp(l1, l2) + list l1; + VOID_STAR l2; +{ + list t; + + if (tlist(l1) == lnil) + return(mklcons(l2, mklnil())); + for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t)) + ; + ltl(t) = mklcons(l2, mklnil()); + return(l1); +} + + +/************** Haskell Infix ops, built on mkap ******************/ + +tree mkinfixop(s, l, r) + char *s; + tree l, r; +{ + tree ap = mkap(mkap(mkident(s), l), r); + ap -> tag = tinfixop; + return ap; +} + +tree * +Rginfun(t) + struct Sap *t; +{ + if(t -> tag != tinfixop) + fprintf(stderr, "ginfun: illegal selection; was %d\n", t -> tag); + return(Rgfun((struct Sap *) (t -> Xgfun))); +} + +tree * +Rginarg1(t) + struct Sap *t; +{ + if(t -> tag != tinfixop) + fprintf(stderr, "ginarg1: illegal selection; was %d\n", t -> tag); + return(Rgarg((struct Sap *) (t -> Xgfun))); +} + +tree * +Rginarg2(t) + struct Sap *t; +{ + if(t -> tag != tinfixop) + fprintf(stderr, "ginarg2: illegal selection; was %d\n", t -> tag); + return(& t -> Xgarg); +} diff --git a/ghc/compiler/yaccParser/utils.h b/ghc/compiler/yaccParser/utils.h new file mode 100644 index 0000000..e43303e --- /dev/null +++ b/ghc/compiler/yaccParser/utils.h @@ -0,0 +1,140 @@ +/* + Utility Definitions. +*/ + +#ifndef __UTILS_H +#define __UTILS_H + +/* stuff from util.c */ +extern tree root; +extern list Lnil; +extern list all; + +extern BOOLEAN nonstandardFlag; +extern BOOLEAN hashIds; +extern BOOLEAN acceptPrim; +extern BOOLEAN etags; + +extern BOOLEAN ignoreSCC; +extern BOOLEAN warnSCC; + +extern BOOLEAN implicitPrelude; +extern BOOLEAN ignorePragmas; + +extern int minAcceptablePragmaVersion; +extern int maxAcceptablePragmaVersion; +extern int thisIfacePragmaVersion; + +extern unsigned hash_table_size; +extern char *input_file_dir; + +extern list imports_dirlist; +extern list sys_imports_dirlist; + +extern char HiSuffix[]; +extern char PreludeHiSuffix[]; + +extern void process_args PROTO((int, char **)); + +/* end of util.c stuff */ + +extern list mklcons PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */ +extern list lapp PROTO((list l1, void *l2)); +extern list lconc PROTO((list l1, list l2)); +extern list mktruecase PROTO((tree t)); + +#define lsing(l) mklcons(l, Lnil) /* Singleton Lists */ +#define ldub(l1, l2) mklcons(l1, lsing(l2)) /* Two-element Lists */ + +#define FN fns[icontexts] +#define SAMEFN samefn[icontexts] +#define PREVPATT prevpatt[icontexts] + +extern tree *Rginfun PROTO((struct Sap *)); +extern tree *Rginarg1 PROTO((struct Sap *)); +extern tree *Rginarg2 PROTO((struct Sap *)); + +#define ginfun(xx) *Rginfun(xx) +#define ginarg1(xx) *Rginarg1(xx) +#define ginarg2(xx) *Rginarg2(xx) + +extern id installid PROTO((char *)); /* Create a new identifier */ +extern hstring installHstring PROTO((int, char *)); /* Create a new literal string */ + +extern id install_literal PROTO((char *)); +extern char *id_to_string PROTO((id)); + +extern struct infix *infixlookup(); + +/* partain additions */ + +extern char *xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */ +extern int printf PROTO((const char *, ...)); +extern int fprintf PROTO((FILE *, const char *, ...)); +/*varies (sun/alpha): extern int fputc PROTO((char, FILE *)); */ +extern int fputs PROTO((const char *, FILE *)); +extern int sscanf PROTO((const char *, const char *, ...)); +extern long strtol PROTO((const char *, char **, int)); +extern size_t fread PROTO((void *, size_t, size_t, FILE *)); +extern int fclose PROTO((FILE *)); +extern int isatty PROTO((int)); +/*extern ??? _filbuf */ +/*extern ??? _flsbuf */ + +extern void format_string PROTO((FILE *, unsigned char *, int)); +extern tree mkbinop PROTO((char *, tree, tree)); +extern tree mkinfixop PROTO((char *, tree, tree)); +extern list type2context PROTO((ttype)); +extern pbinding createpat PROTO((list, binding)); +extern void process_args PROTO((int, char **)); +extern void hash_init PROTO((void)); +extern void print_hash_table PROTO((void)); +extern long int hash_index PROTO((id)); +extern void yyinit PROTO((void)); +extern int yyparse PROTO((void)); +extern int yylex PROTO((void)); +extern void setyyin PROTO((char *)); +extern void yyerror PROTO((char *)); +extern void error PROTO((char *)); +extern void hsperror PROTO((char *)); +extern void enteriscope PROTO((void)); +extern void exposeis PROTO((void)); +extern void makeinfix PROTO((id, int, int)); +extern int nfixes PROTO((void)); +extern long int precedence PROTO((int)); +extern int pprecedence PROTO((struct infix *)); +extern void rearrangeprec PROTO((tree, tree)); +extern int pfixity PROTO((struct infix *)); +extern void hsincindent PROTO((void)); +extern void hssetindent PROTO((void)); +extern void hsentercontext PROTO((int)); +extern void hsendindent PROTO((void)); +extern void hsindentoff PROTO((void)); + +extern int checkfixity PROTO((char *)); +extern void checksamefn PROTO((char *)); +extern void checkcontext PROTO((list)); +extern void checkinpat PROTO((void)); +extern void checkpatt PROTO((tree)); +extern BOOLEAN lhs_is_patt PROTO((tree)); +extern tree function PROTO((tree)); +extern void checkconap PROTO((tree, tree)); +extern void extendfn PROTO((binding, binding)); +extern void precparse PROTO((tree)); +extern void checkorder PROTO((binding)); +extern BOOLEAN checkorder2 PROTO((binding, BOOLEAN)); +extern BOOLEAN checksig PROTO((BOOLEAN, binding)); +extern void checkprec PROTO((tree, id, BOOLEAN)); +extern BOOLEAN isconstr PROTO((char *)); +extern void setstartlineno PROTO((void)); +extern void pprogram PROTO((tree)); +extern void who_am_i PROTO((void)); +extern void new_filename PROTO((char *)); +extern int Return PROTO((int)); + +/* mattson additions */ +extern char *xstrdup PROTO((char *)); /* Duplicate a string */ +extern char *xstrndup PROTO((char *, unsigned));/* Duplicate a substring */ +extern char *xrealloc PROTO((char *, unsigned));/* Re-allocate a string */ + +#endif /* __UTILS_H */ diff --git a/ghc/docs/ANNOUNCE-0.06 b/ghc/docs/ANNOUNCE-0.06 new file mode 100644 index 0000000..8a1b633 --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.06 @@ -0,0 +1,116 @@ + The Glasgow Haskell Compiler + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Version 0.06 --- Hackers' release + +As many of you know, we have been working hard at Glasgow on a modular +Haskell compiler. We are proud to announce its first public release. + +We are calling it a "Hackers' release" because it is not yet suitable +for Haskell *programmers*. It is intended for *implementors* who are +interested in using our compiler as a substrate for their own work. +(A later version will indeed be a "Programmers' release".) We also +hope that some *porters*, people who would like to see Haskell running +on their system, will help us debug any Sun dependencies in our +generated C files. Finally, the *curious* may simply want to see the +World's Largest Haskell Program (40,000 lines?)! + +The compiler has the following characteristics: + + * It is written in Haskell. + + * It generates C as its target code. + + * It is specifically designed to be modular, so that others can + use it as a "motherboard" into which they can "plug in" their + latest whizzy strictness analyser, profiler, or whatever. + + * Internally, it uses the polymorphic second-order lambda calculus + as a way to preserve correct type information in the face of + substantial program transformations. + + * It implements unboxed values as described in [1]. In + particular, the implementation of arithmetic and the exploitation + of strictness analysis is handled just as described there. + + * Its back end is based on the Spineless Tagless G-machine, an + abstract machine for non-strict functional languages. There is a + detailed paper describing this work [2]. + + * It plants code to gather quite a lot of simple profiling + information. + + * Its runtime system is heavily configurable. For example, it + comes complete with three different garbage collectors: two-space, + one-space compacting, and Appel-style generational. Adding extra + fields to heap objects (for debugging or profiling for example) is + just a question of altering C macros; the Haskell source doesn't + need to be recompiled. (Caveat: you have to alter them *right*!) + +The compiler also suffers its fair share of deficiencies: + + * The compiler itself is large and slow. + + * The code it generates is very, very unoptimised. Any + comparisons you make of runtime speed with good existing compilers + will be deeply unflattering. (Our next priority is optimisation.) + + * Several language features aren't dealt with. This has not + prevented us from compiling and running several quite large + Haskell programs. + +Please follow the pointers in the top-level README file to find all of +the documentation in and about this release. Distribution info +follows below. + +We hope you enjoy this system, and we look forward to hearing about +your successes with it! Please report bugs to +glasgow-haskell-bugs@dcs.glasgow.ac.uk and direct general queries to +glasgow-haskell-request@. + +Simon Peyton Jones +(and his GRASPing colleagues) +...................................................................... + +References +~~~~~~~~~~ +[1] Simon L Peyton Jones and John Launchbury, "Unboxed values as first +class citizens", Functional Programming Languages and Computer +Architecture, Boston, ed Hughes, LNCS 523, Springer Verlag, Sept 1991. + +[2] Simon L Peyton Jones, "Implementing lazy functional languages on +stock hardware: the Spineless Tagless G-machine", Journal of +Functional Programming (to appear). Also obtainable by anonymous FTP +from ftp.dcs.glasgow.ac.uk:pub/glasgow-fp/stg.dvi. + +Distribution +~~~~~~~~~~~~ +This release is available, in whole or in part, from the usual Haskell +anonymous FTP sites, in the directory pub/haskell/glasgow: + + nebula.cs.yale.edu (128.36.13.1) + ftp.dcs.glasgow.ac.uk (130.209.240.50) + animal.cs.chalmers.se (129.16.225.66) + +(Beleaguered NIFTP users within the UK can get the same files by using +a /haskell/glasgow prefix, instead of pub/haskell/glasgow.) + +These are the available files (for the ON DEMAND ones, please ask): + +ghc-0.06-src.tar.Z the basic source distribution; assumes you + will compile it with Chalmers HBC, version + 0.997.3 or later. + +ghc-0.06-proto-hi-files.tar.Z + An "overlay" of .hi interface files, to be + used when compiling with the *prototype* + Glasgow Haskell compiler (version 0.411 or + later). + +ghc-0.06-hc-files.tar.Z An "overlay" of .hc generated-C files; used + either to save you the trouble of compiling + the prelude, or because your only interest is + porting the C to + +ghc-0.06-tests.tar.Z Some of our test files we have used in getting + this beast going. We hope to grow them into a + semi-respectable benchmark suite. diff --git a/ghc/docs/ANNOUNCE-0.10 b/ghc/docs/ANNOUNCE-0.10 new file mode 100644 index 0000000..04062f1 --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.10 @@ -0,0 +1,135 @@ + The Glasgow Haskell Compiler + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We are happy to announce the first full release of the Glasgow Haskell +Compiler (GHC, version 0.10). It is freely available by FTP; details +appear below. + +To run this release, you need a Sun4, probably with 16+MB memory, and +GNU C (gcc), version 2.1 or greater, and "perl". If building from +source, you will need Chalmers HBC, version 0.998.x. + +We hope you enjoy this system, and we look forward to hearing about +your successes with it! Please report bugs to +glasgow-haskell-bugs@dcs.glasgow.ac.uk and direct general queries to +glasgow-haskell-request@. + +Simon Peyton Jones +(and his GRASPing colleagues) + +Why a Haskell programmer might want to use GHC +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Almost all of Haskell is implemented. In particular, the full range + of data types is supported: arbitrary precision integers, rationals, + double-precision floats, and "real" arrays with O(1) access time. + (The release notes list all unimplemented language features.) + +* An extensible I/O system is provided, based on a "monad" [1]. (The + standard Haskell I/O system is built on this foundation.) + +* A number of significant language extensions are implemented: + - Fully fledged unboxed data types [2]. + - Ability to write arbitrary in-line C-language code, using + the I/O monad to retain referential transparency. + - Incrementally-updatable arrays, also embedded in a monad. + - Mutable reference types. + +* By default, the system uses a generational garbage collector which + lets you run programs whose live data is significantly larger than + the physical memory size before thrashing occurs. (Conventional + 2-space GC starts thrashing when the live data gets to about half + the physical memory size.) + +* A new profiling system is supplied, which enables you to find out which + bits of your program are eating both *time* and the *space* [3]. + +* Good error messages. Well, fairly good error messages. Line + numbers are pretty accurate, and during type checking you get + several (accurate) error reports rather than just one. + +* Performance: programs compiled with GHC "usually" beat + Chalmers-HBC-compiled ones. If you find programs where HBC wins, + send them to us :-). + +* We have a pretty good test suite, and this version passes + practically all of it. (Yes, it can compile itself, too.) We hope + you will find the system to be robust. + +Why a functional-language implementor might want to use GHC +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We have tried very hard to write the compiler in a modular and + well-documented way, so that other researchers can modify and extend + it. One of our goals is specifically to provide a framework to + support others' work. Several people are already using it in this + way. + +* Highly configurable runtime system. Heavy use of C macros means + that you can modify much of the storage representation without + telling the compiler. For example, the system comes with 4 + different garbage collectors! (all working) + +* Internals: extensive use of the second-order lambda calculus as an + intermediate code; the Spineless Tagless G-machine as evaluation + model [4]. + +* Various performance-measurement hooks. + +Main shortcomings +~~~~~~~~~~~~~~~~~ +* No interactive system. This is a batch compiler only. (Any + volunteers?) + +* Compiler is greedy on resources. Going via C doesn't help here. + +* This system should run on any Unix box. We haven't had time to do + any non-Sun4 ports. Help or prodding welcome. + +References +~~~~~~~~~~ +All these papers come with the distribution [in ghc/docs/papers]. + +[1] "Imperative functional programming", Peyton Jones & Wadler, POPL '93 + +[2] "Unboxed data types as first-class citizens", Peyton Jones & + Launchbury, FPCA '91 + +[3] "Profiling lazy functional languages", Sansom & Peyton Jones, + Glasgow workshop '92 + +[4] "Implementing lazy functional languages on stock hardware", Peyton + Jones, Journal of Functional Programming, Apr 1992 + +How to get it +~~~~~~~~~~~~~ +This release is available, in whole or in part, from the usual Haskell +anonymous FTP sites, in the directory pub/haskell/glasgow: + + nebula.cs.yale.edu (128.36.13.1) + ftp.dcs.glasgow.ac.uk (130.209.240.50) + animal.cs.chalmers.se (129.16.225.66) + +(Beleaguered NIFTP users within the UK can get the same files from +Glasgow by using a /haskell/glasgow prefix, instead of +pub/haskell/glasgow. Also, we are mirrored by src.doc.ic.ac.uk, in +languages/haskell/glasgow, and you can get files from there by every +means known to humanity.) + +These are the available files: + +ghc-0.10-src.tar.Z The basic source distribution; assumes you + will compile it with Chalmers HBC, version + 0.998.n, on a Sun4, for which you have GNU C + (gcc) version 2.1 or greater. About 3MB. + +ghc-0.10-bin-sun4.tar.Z A binary distribution -- avoid compiling + altogether! For SunOS 4.1.x; assumes you + have GNU C (gcc) version 2.x around... + +ghc-0.10-patch-* Patches to the original distribution. There + are none to start with, of course, but there + might be by the time you grab the files. + Please check for them. + +Once you have the distribution, please follow the pointers in the +ghc/README file to find all of the documentation in and about this +release. diff --git a/ghc/docs/ANNOUNCE-0.16 b/ghc/docs/ANNOUNCE-0.16 new file mode 100644 index 0000000..f642566 --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.16 @@ -0,0 +1,146 @@ + The Glasgow Haskell Compiler -- version 0.16 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The second public release of the Glasgow Haskell Compiler is now +available (GHC, version 0.16). Binaries (recommended) and source are +freely available by FTP; details appear below. + +GHC 0.16 is still alpha-quality software. This release in an interim +measure, not as solid as I would prefer. However, a lot has gone in +since December. The profiling system is Way Cool. The compiler now +has a strictness analyser and an update analyser. Compiled programs +tend to run faster. Compilation speed is worse. Bugs remain, but +they tend to be work-around-able. + +To run this release, you need a Sun4 or Sun3, probably with 16+MB +memory, and GNU C (gcc), version 2.1 or greater, and "perl". + +This system can be built from source using: itself (most likely to +succeed), the previous GHC release (0.10) [least likely], or the +Chalmers HBC compiler [in-between]. Please see the appropriate +documentation for details. + +Please report bugs to glasgow-haskell-bugs@dcs.glasgow.ac.uk and +direct general queries to glasgow-haskell-request@. + +Will Partain +(typist for the AQUA [formerly GRASP] project) + +.................................................................... + +Why a Haskell programmer might want to use GHC +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* GHC provides an extensible I/O system, based on a "monad" [1]. (The + standard Haskell I/O system is built on this foundation.) + +* A number of significant language extensions are implemented: + - Fully fledged unboxed data types [2]. + - Ability to write arbitrary in-line C-language code, using + the I/O monad to retain referential transparency. + - Incrementally-updatable arrays, also embedded in a monad. + - Mutable reference types. + +* A new profiling system is supplied, which enables you to find out + which bits of your program are eating both *time* and the *space* [3]. + +* By default, the system uses a generational garbage collector which + lets you run programs whose live data is significantly larger than + the physical memory size before thrashing occurs. (Conventional + 2-space GC starts thrashing when the live data gets to about half + the physical memory size.) + +* Good error messages. Well, fairly good error messages. Line + numbers are pretty accurate, and during type checking you get + several (accurate) error reports rather than just one. + +* Performance: programs compiled with GHC "often" beat + Chalmers-HBC-compiled ones. If you find programs where HBC wins, + please report it to us, as a bug :-). + +Why a functional-language implementor might want to use GHC +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We have tried very hard to write the compiler in a modular and + well-documented way, so that other researchers can modify and extend + it. One of our goals is specifically to provide a framework to + support others' work. Several people are already using it in this + way. + +* Highly configurable runtime system. Heavy use of C macros means + that you can modify much of the storage representation without + telling the compiler. For example, the system comes with 4 + different garbage collectors! (all working) + +* Internals: extensive use of the second-order lambda calculus as an + intermediate code; the Spineless Tagless G-machine as evaluation + model [4]. + +* Various performance-measurement hooks. + +Main shortcomings +~~~~~~~~~~~~~~~~~ +* No interactive system. This is a batch compiler only. (Any + volunteers?) + +* Compiler is greedy on resources. Going via C doesn't help here. + +* This system should run on any Unix box. We haven't had time to do + any non-Sun ports. Help or prodding welcome. + +References +~~~~~~~~~~ +All these papers come with the distribution [in ghc/docs/papers]. + +[1] "Imperative functional programming", Peyton Jones & Wadler, POPL '93 + +[2] "Unboxed data types as first-class citizens", Peyton Jones & + Launchbury, FPCA '91 + +[3] "Profiling lazy functional languages", Sansom & Peyton Jones, + Glasgow workshop '92 + +[4] "Implementing lazy functional languages on stock hardware", Peyton + Jones, Journal of Functional Programming, Apr 1992 + +How to get it +~~~~~~~~~~~~~ +This release is available, in whole or in part, from the usual Haskell +anonymous FTP sites, in the directory pub/haskell/glasgow: + + ftp.dcs.glasgow.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.225.66) + nebula.cs.yale.edu (128.36.13.1) + +We are mirrored by src.doc.ic.ac.uk, in +computing/programming/languages/haskell/glasgow, and you can get files +from there by every means known to humanity. + +These are the available files (.Z for compressed, .gz for gzipped) -- +some are `on demand', ask if you don't see them: + +ghc-0.16-bin-sun4.tar.{Z,gz} A binary distribution -- avoid compiling + altogether! For SunOS 4.1.x; assumes you have + GNU C (gcc) version 2.x around... + +ghc-0.16-src.tar.gz The basic source distribution; about 3MB. + +ghc-0.16-hi-files-{hbc,ghc-0.10}.tar.gz + Interface files for the compiler proper + (ghc/compiler/*/*.hi), to be used if booting + with either HBC or GHC version 0.10. (The + distributed .hi files assume GHC version + 0.16.) + +ghc-0.16-hc-files.tar.gz The intermediate C files for the compiler + proper, the prelude, and `Hello, world'. + Used when porting. + +ghc-0.16-patch-* Patches to the original distribution. There + are none to start with, of course, but there + might be by the time you grab the files. + Please check for them. + +There are no diffs from version 0.10, as they would be laughably huge. + +Once you have the distribution, please follow the pointers in the +ghc/README file to find all of the documentation in and about this +release. diff --git a/ghc/docs/ANNOUNCE-0.19 b/ghc/docs/ANNOUNCE-0.19 new file mode 100644 index 0000000..6f0523f --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.19 @@ -0,0 +1,130 @@ + The Glasgow Haskell Compiler -- version 0.19 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + "What a great system!" + +The third public release of the Glasgow Haskell Compiler is now +available (GHC, version 0.19). Binaries and sources are freely +available by FTP; details below. + +Highlights of what's new in 0.19 since 0.16 (July 1993): + * Somewhat faster compilation times. + * Still better error messages. + * Better Haskell 1.2 compliance, including more derived instances, + `default' declarations, renaming, etc. + * Native-code generator for SPARC. + * Unfoldings across module boundaries. + * Automatic specialisation of overloaded functions. + * Better strictness analysis, including "looking inside tuples" and + "absence analysis" (arguments that aren't used). + * New "simplifier" (program-transformation engine). + +Please see the release notes for a more complete list (including +Backward Incompatibilities to watch out for). + +To run this release, you need a machine with 16+MB memory, GNU C +(`gcc') [version 2.1 or greater], and `perl'. We have seen GHC work +in *some* form or fashion on: Sun4s, Sun3s, DECstations, DEC Alphas, +HP-PA boxes. Sun4s, our development platform, are by far the best +supported. We will distribute binaries as we build them. + +Once you have the distribution, please follow the pointers in +ghc/README to find all of the documentation in and about this release. + +Please report bugs to glasgow-haskell-bugs@dcs.glasgow.ac.uk and +direct general queries to glasgow-haskell-request@. + +We are very grateful to everyone who has sent a bug report, sent a +"look at this weird result" report, lent us a machine on which to try +a port, or (best of all) contributed code. Keep up the good work. + +Simon Peyton Jones + +Dated: 93/12/16 +.................................................................... + +"Should I start using GHC 0.19?" +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +* If you're using a previous release of GHC: YES. (Recompile everything.) + +* If you want to hack on a Haskell compiler: YES. + +* If you're new to Haskell: Try Gofer (an interpreter for a + Haskell-like language) first; then come back and say YES. + +* If you want time profiling as well as space profiling: YES. + +* If you need the Glasgow Haskell extensions, i.e., calling C, unboxed + datatypes, monadic I/O etc.: YES. (ghc/README says a little more + about these features.) + +* If you're using HBC at the moment: not a clear YES or NO. *We* + really like having both compilers to play against each other. For + example, HBC has better compilation times, but you'll like GHC's + error messages. And you can try them both before submitting a bug + report for either one. + +* If you want simulated parallel execution on a uniprocessor: NO. + (Use the "hbcpp" variant of HBC from York.) + +.................................................................... + +How to make sure every release of GHC will run your program (well) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +*Please* send us a copy! Part of our work is to collect and study +large and *realistic* Haskell programs. Only you can provide them. +They need not be final, polished versions -- they just have to run. + +Among other things, we run every release against our entire +collection, so if your program's in there... + +.................................................................... + +How to get it +~~~~~~~~~~~~~ +This release is available, in whole or in part, from the usual Haskell +anonymous FTP sites, in the directory pub/haskell/glasgow: + + ftp.dcs.glasgow.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.225.66) + nebula.cs.yale.edu (128.36.13.1) + +We are mirrored by src.doc.ic.ac.uk, in +computing/programming/languages/haskell/glasgow, and you can get files +from there by every means known to humanity. + +These are the available files (.Z for compressed, .gz for gzipped) -- +some are `on demand', ask if you don't see them: + +ghc-0.19-bin-sun4.tar.{Z,gz} A binary distribution -- unpack & run! + For SunOS 4.1.x; assumes you have GNU C (gcc) + version 2.x around... + +ghc-0.19-bin-.tar.gz Other binary distributions -- we will + make them available as we go along; they + will be announced on the Haskell mailing list + (not elsewhere). + +ghc-0.19-src.tar.gz The basic source distribution; about 3MB. + +ghc-0.19-hc-files.tar.gz The intermediate C (.hc) files for the + compiler proper, the prelude, and `Hello, + world'. + +ghc-0.19.ANNOUNCE This file + +ghc-0.19.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-0.19-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +ghc-0.19-hi-files-hbc.tar.gz + Interface files for the compiler proper + (ghc/compiler/*/*.hi), to be used if booting + with either HBC. (The distributed .hi files + assume GHC version 0.19.) + +There are no diffs from version 0.16, as they would be laughably huge. diff --git a/ghc/docs/ANNOUNCE-0.20 b/ghc/docs/ANNOUNCE-0.20 new file mode 100644 index 0000000..2e7f274 --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.20 @@ -0,0 +1,55 @@ +This is version 0.20 of the Glorious Glasgow Haskell compilation +system (GHC). + +Version 0.20 is an "internal" release, intended *ONLY* for the most +fanatical GHC hackers. + +* Many things about it may be broken, though it +does compile and run most programs. + +* I/O and ccall scheme re-done; any such low-level code probably needs + fixing; I/O attempts to follow 1.3 I/O proposal. All ccall + arguments and results are automagically "boxed". + +* PrimOps fiddled; any code that uses them directly will probably need + attention. + +* We've renamed some things, so as to move to a we-don't-steal-user- + name-space policy. Thus "tagCmp" has become "_tagCmp". Names starting + with underscores are now cool if -fglasgow-exts. + + You might want to see our "state-interface" document if you mess + with all this low-level/non-standard stuff; I'll try to remember to + put a copy up for FTP. + +* No promises about profiling. + +* Documentation is untouched since 0.19. + +Version 0.19 was the last public release. It has held up pretty well +and should be available wherever you got 0.20 from. I commend 0.19 to +all sane people. + +Configuring 0.20 is a little different than 0.19: + + % cd + % ./configure --with-boot=c + % ./STARTUP-ghc std + % cd ghc; make + +Things to note: + +* It's wrong for jmake to tell you "0: unknown flag -traditional"; but + it is harmless. + +* The 0.20 compiler seems more likely to run out of stack; use + -Rmax-stksize2m (or something) to increase; within the distribution, + probably something like... + + % make EXTRA_HC_OPTS="-H20m -Rmax-stksize4m" + +See the "configure" script if you want to know what other options are +-- there is no other documentation at this time! + +Will Partain, AQUA project typist +partain@dcs.glasgow.ac.uk diff --git a/ghc/docs/ANNOUNCE-0.22 b/ghc/docs/ANNOUNCE-0.22 new file mode 100644 index 0000000..d7fed2c --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.22 @@ -0,0 +1,109 @@ + The Glasgow Haskell Compiler -- version 0.22 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A new public release of the Glasgow Haskell Compiler is now +available (GHC, version 0.22). Binaries and sources are freely +available by FTP; details below. + +Highlights of what's new in 0.22 since 0.19 (December 1993): + + * Faster compilation times (now about 40% slower than HBC if not + using -O [on a Sun4]). + * Revamped state-tranformer stuff, which affects arrays, calling out + to C, and I/O (preparing for Haskell 1.3). + * "Threads" stuff -- can do quasi-parallel execution on a + uniprocessor. + * No more space leaks from lazy pattern-matching. + * Alastair Reid's "stable pointers" and "malloc pointers"; friendly + interaction with "C Land". + * Time profiling no longer attributes great chunks + of time to "CAF". (However, because of the many recent changes, + profiling is probably *less* reliable than before.) + * New "GHC system library" (analogous to the "HBC system library"); + not much there, but stay tuned. + * Fully supported on DEC Alphas. Some other porting progress. + * Much improved configuration. + * Less user namespace pollution by the system. + * New mailing lists about Glasgow Haskell. + + - The "glasgow-haskell-users" list is for GHC users to chat among + themselves. Subscribe by sending mail to + "glasgow-haskell-users-request@dcs.glasgow.ac.uk". Messages for the + list go to "glasgow-haskell-users". + + - The "glasgow-haskell-bugs" list is for submission of bug reports + and discussion thereof. Subscribe via + "glasgow-haskell-bugs-request@dcs.glasgow.ac.uk"; send bug + reports and rumination thereupon go to "glasgow-haskell-bugs". + +Please see the release notes for a complete discussion of What's New. + +To run this release, you need a machine with 16+MB memory, GNU C +(`gcc') [version 2.1 or greater], and `perl'. We have seen GHC work +in *some* form or fashion on: Sun4s, DEC Alphas, Sun3s, NeXTs, +DECstations, HP-PA and SGI boxes. Sun4s and Alphas, our development +platforms, are fully supported. We distribute binaries for them. + +*** LATE NEWS: Don't use GCC 2.6.0 on the Alpha *** + +Once you have the distribution, please follow the pointers in +ghc/README to find all of the documentation in and about this release. + +Please report bugs to glasgow-haskell-bugs@dcs.glasgow.ac.uk and +direct general queries to glasgow-haskell-request@. + +Simon Peyton Jones + +Dated: 94/07/27 +.................................................................... + +How to get it +~~~~~~~~~~~~~ +This release is available, in whole or in part, from the usual Haskell +anonymous FTP sites, in the directory pub/haskell/glasgow: + + ftp.dcs.glasgow.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.225.66) + nebula.cs.yale.edu (128.36.13.1) + +The Glasgow site is mirrored by src.doc.ic.ac.uk, in +computing/programming/languages/haskell/glasgow. + +These are the available files (.gz files are gzipped) -- some are `on +demand', ask if you don't see them: + +ghc-0.22-bin-sun4.tar.gz A binary distribution -- unpack & run! + For SunOS 4.1.x; assumes you have GNU C (gcc) + version 2.x around... + +ghc-0.22-bin-alpha.tar.gz A binary distribution -- unpack & run! + Built on OSF1 V2.0; assumes you have GNU C (gcc). + +ghc-0.22-bin-.tar.gz Other binary distributions -- we will + make them available as we go along; they + will be announced on the Haskell mailing list + (not elsewhere). + +ghc-0.22-src.tar.gz The basic source distribution; about 3MB. + +ghc-0.22-hc-files.tar.gz The intermediate C (.hc) files for the + compiler proper, the prelude, and `Hello, + world'. About 4MB. + +ghc-0.22.ANNOUNCE This file + +ghc-0.22.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-0.22-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +ghc-0.22-hi-files-hbc.tar.gz + Interface files for the compiler proper + (ghc/compiler/*/*.hi), to be used if booting + with HBC. Not recommended, but some might + want to. (The distributed .hi files assume + GHC version 0.22.) + +There are no diffs from version 0.19, as they would be monstrous. diff --git a/ghc/docs/ANNOUNCE-0.23 b/ghc/docs/ANNOUNCE-0.23 new file mode 100644 index 0000000..d7e7d94 --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.23 @@ -0,0 +1,124 @@ + The Glasgow Haskell Compiler -- version 0.23 + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A new public release of the Glasgow Haskell Compiler is now available +(GHC, version 0.23). Binaries and sources are freely available by +anonymous FTP; details below. + +Haskell is "the" standard lazy functional programming language [see +SIGPLAN Notices, May 1992]. The current language version is 1.2. + +GHC is a state-of-the-art batch compiler. For some idea of how it +compares against the competition, see Pieter Hartel's recent revision +of his FPCA '93 paper. Reference attached. Summary: we win! + +Highlights of what's new in GHC 0.23 since 0.22 (July 1994): + + * Faster compilation times (less than 10% slower than HBC if not + using -O [on a Sun4]). + + * Produces 10-15% smaller executables. The main compiler binary is + 1MB smaller than in 0.22. + + * >>> USER-VISIBLE changes <<< to "monadic I/O", because we are + switching to the Haskell 1.3 *draft* I/O proposal. Please see the + relevant bit of the User's Guide before doing monadic I/O things + with 0.23. + + * Native-code generator for DEC Alphas. + + * A _selective_ lambda lifter. + + * The yacc-based parser is now called directly from Haskell. + + * Configuration changed enough that "the same old thing" *won't* work. + Configuring binary distributions should be trivial now. + + * Quite a few bugs fixed; the usual big wad of code added. + +Please see the release notes for a complete discussion of What's New. + +Should you upgrade to 0.23? If you are a contented 0.22 user, +probably not. Otherwise, probably yes. + +To run this release, you need a machine with 16+MB memory, GNU C +(`gcc'), and `perl'. We have seen GHC work in *some* form or fashion +on: Sun4s, DEC Alphas, Sun3s, NeXTs, DECstations, HP-PA and SGI boxes. +Sun4s and Alphas, our development platforms, are fully supported; we +distribute binaries for them. The release notes give a full +what-ports-work report. + +Once you have the distribution, please follow the pointers in +ghc/README to find all of the documentation in and about this release. +NB: preserve modification times when un-tarring (no `m' option for +tar, please)! + +We run mailing lists for GHC users and bug reports; to subscribe, send +mail to glasgow-haskell-{users,bugs}-request@dcs.glasgow.ac.uk. +Please send bug reports to glasgow-haskell-bugs. + +Simon Peyton Jones + +Dated: 94/12/21 + +====================================================================== +Hartel reference: + +@techreport{Har94g, + author = {P. H. Hartel}, + title = {Benchmarking implementations of lazy functional + languages {II} -- Two years later}, + institution = {Dept. of Comp. Sys, Univ. of Amsterdam}, + type = {Technical report}, + number = {Cs-94-21}, + month = {Dec}, + year = {1994}} + +The paper is available from ftp.fwi.uva.nl, +file: pub/computer-systems/functional/reports/benchmarkII.ps.Z + +The programs are in file: pub/computer-systems/functional/packages/benchmark.tar.Z + +====================================================================== +How to get GHC: + +This release is available, in whole or in part, from the usual Haskell +anonymous FTP sites, in the directory pub/haskell/glasgow: + + ftp.dcs.glasgow.ac.uk (130.209.240.50) + ftp.cs.chalmers.se (129.16.227.140) + haskell.cs.yale.edu (128.36.11.43) + +The Glasgow site is mirrored by src.doc.ic.ac.uk (155.198.191.4), in +computing/programming/languages/haskell/glasgow. + +These are the available files (.gz files are gzipped) -- some are `on +demand', ask if you don't see them: + +ghc-0.23-bin-sun4.tar.gz A binary distribution -- unpack & run! + For SunOS 4.1.x; assumes you have GNU C (gcc) + +ghc-0.23-bin-alpha.tar.gz A binary distribution -- unpack & run! + Built on OSF1 V2.0; assumes you have GNU C (gcc). + +ghc-0.23-bin-.tar.gz Other binary distributions -- we will + make them available as we go along; they + will be announced on the Haskell mailing list + (not elsewhere). + +ghc-0.23-src.tar.gz The basic source distribution; about 3MB. + +ghc-0.23-hc-files.tar.gz The intermediate C (.hc) files for the + compiler proper, the prelude, and `Hello, + world'. About 4MB. + +ghc-0.23.ANNOUNCE This file + +ghc-0.23.{README,RELEASE-NOTES} From the distribution; for those who + want to peek before FTPing... + +ghc-0.23-ps-docs.tar.gz Main GHC documents in PostScript format; in + case your TeX setup doesn't agree with our + DVI files... + +There are no diffs from version 0.22, as they would be monstrous. diff --git a/ghc/docs/ANNOUNCE-0.25 b/ghc/docs/ANNOUNCE-0.25 new file mode 100644 index 0000000..a3da0c2 --- /dev/null +++ b/ghc/docs/ANNOUNCE-0.25 @@ -0,0 +1,54 @@ +A binary-only from-working-sources no-guarantees snapshot of the +Glasgow Haskell compiler (GHC) for Linux x86 machines is now available +by FTP from ftp.dcs.glasgow.ac.uk, in +pub/haskell/glasgow/ghc-0.25-linux.tar.gz. + +This release is the first, long-awaited "registerized" GHC for Linux, +which produces code of reasonable size and speed. We use our normal +technique of "stealing registers" with GCC's +global-variables-in-registers facility. We "steal" six of the x86's +eight general-purpose registers, including the C stack-pointer (%esp), +which we use for the heap pointer (Hp). + +To use this GHC, you need a special version of GCC, which is also +provided in the distribution (under "gcc-linux-to-linux"). Whatever +you do, please do *not* report any "bugs" in this GCC to bug-gcc -- +report them to *me* instead. + +One special thing you must watch out for: If GCC "crashes" with a +message about spilling registers, it is *not* a GCC problem. It means +you must get GHC to "back off" in its register "stealing". First try +a -monly-4-regs flag, then -monly-3-regs, and as a last resort, +-monly-2-regs. As far as we know, all Haskell code goes through GHC +with a -monly-2-regs flag (but it produces substantially worse code +with that flag). + +Profiling is not provided in this release. + +Please report any bugs to glasgow-haskell-bugs@dcs.glasgow.ac.uk. + +Will Partain +AQUA project (slave) + +Dated: 95/04/01 + +=== INSTALLATION NOTES ============================================== + +Unpack the distribution. + +Move "gcc-linux-to-linux" and "ghc-0.25-linux" wherever you like. + +Alter the "gcc" script to point to wherever you've put +"gcc-linux-to-linux", and put the "gcc" script wherever you wish in +your PATH. + +Make a link to ghc-0.25-linux/ghc/driver/ghc, so that "ghc" will be in +your PATH. + +Change *all* hardwired paths in ghc/driver/ghc and in +ghc/utils/hscpp/hscpp to point to where things are on your system. +Notably: where "perl" is (first line of each script), where $TopPwd is +(ghc script), where your gcc cpp is (hscpp script). + +GHC should then work. Try "ghc -v" on something simple, to make sure +it compiles and links a program correctly. diff --git a/ghc/docs/Jmakefile b/ghc/docs/Jmakefile new file mode 100644 index 0000000..6bbeb25 --- /dev/null +++ b/ghc/docs/Jmakefile @@ -0,0 +1,19 @@ +#define IHaveSubdirs + +/* just documents here */ +#define NoAllTargetForSubdirs +#define NoRunTestsTargetForSubdirs +#define NoInstallTargetForSubdirs +#define NoTagTargetForSubdirs + +SUBDIRS = add_to_compiler \ + users_guide \ + install_guide \ + release_notes + +XCOMM developers_guide ? +XCOMM interfaces ? +XCOMM pragmas ? + +XCOMM grasp_overview ? +XCOMM style_guide ? diff --git a/ghc/docs/NOTES.adding-PrimOp b/ghc/docs/NOTES.adding-PrimOp new file mode 100644 index 0000000..2d5b475 --- /dev/null +++ b/ghc/docs/NOTES.adding-PrimOp @@ -0,0 +1,51 @@ +This is a short note describing how I (ADR ) +added a new primitive operation (makeStablePtr#) to the compiler. It +serves as documentation of what I did and as a guide to anyone else +wanting to try it. + +1) Change compiler/prelude/PrimOps.lhs: + + - add @MakeStablePtrOp@ to the datatype @PrimitiveOp@. + + - add the following case to @primOpInfo@ + + primOpInfo MakeStablePtrOp + = AlgResult "makeStablePtr#" [] + [(ioWorldTy `UniFun` intPrimAndIoWorldTy), ioWorldTy] + intPrimAndIoWorldTyCon [] + -- makeStablePtr# :: IO_Int# -> IO_Int# + -- == makeStablePtr# :: (IoWorld -> (Int#, IoWorld)) -> (IoWorld -> (Int#, IoWorld)) + +2) Change compiler/prelude/AbsPrel.lhs: + + - add @MakeStablePtrOp@ to an appropriate place in @list_of_val_assoc_lists@ + + (This makes the operation visible to the programmer). + + Since this is a glasgow extension, I added it to one of + @extra_known_vals_2@, @unboxed_ops@, @boxed_ops@. @unboxed_ops@ + is made up of several lists of operators including + @prim_ops_used_unboxed_only@. By inspection I decided that this + (@prim_ops_used_unboxed_only@) was the one to go for. + +At this point I started recompiling the compiler - this took a long +time since the change to @PrimitiveOp@ changed the @.hi@ file +resulting in a complete (or near as makes no odds) recmpilation of the +compiler. (Is there a way of using fastmake that avoids this? + +3) Change imports/StgMacros.lh to generate code for @MakeStablePtr#@ + + - this is just adding a macro that calls the appropriate operation. + + (I suspect I could omit this step if I wanted since all this does + (ahem, will do) is call a function in the runtime system.) + +4) Change runtime/storage/SMap.lc to implement the new operation. + + I won't bother describing this just now. + + +This is a little untidy. I should perhaps add a new flag to the system +which turns my extension off and checks that it is only used in +conjunction with the Appel generational collector. But we're going to +do the same to every collector eventually aren't we? diff --git a/ghc/docs/NOTES.arbitary-ints b/ghc/docs/NOTES.arbitary-ints new file mode 100644 index 0000000..964a2cf --- /dev/null +++ b/ghc/docs/NOTES.arbitary-ints @@ -0,0 +1,54 @@ + +Boxed structure of BigInts + + +----> Info1 Pointer + | Pointer passed to BigNum package + | | + \/ \/ + Info2 Size Integer .... + + (size excludes info ptr & size field) + +Unboxed (Compiler must place on pointer stack not data stack + Must also tell GC if it is in a register when GC invoked) + +----> Info2 Size Integer + + + +Info1: + SPEC_INFO_TABLE(Info1, BigNum_entry, 1, 1); (Min Size 2 ?) + + Entering this returns the BigNum using agreed return convention + +Info2: + DATA_INFO_TABLE(Info2, Dummy_entry); + + This never actually entered -- just required for GC. + +------------------------------------------------------------------------------ + +Boxed structure of BigInts (the alternative one) + + Pointer passed to BigNum package + | + \/ +----> Info Size Integer .... + + (size excludes info ptr & size field) + +Unboxed (Compiler must place on pointer stack not data stack + Must also tell GC if it is in a register when GC invoked) + + +Info: + DATA_INFO_TABLE(Info, BigNum_entry); + + Entering this returns the BigNum using agreed return convention + + + +Note that the Boxed and Unboxed representation are identical !!! + +(unboxing represents evaluationhood, not pointerhood) diff --git a/ghc/docs/NOTES.c-optimisation b/ghc/docs/NOTES.c-optimisation new file mode 100644 index 0000000..3320ae1 --- /dev/null +++ b/ghc/docs/NOTES.c-optimisation @@ -0,0 +1,2361 @@ +Optimisation of C-code (runtime and compiled) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- Placing of STG registers in machine registers +- Optimisation of interpreter loop (tail calls) + +/* TODO: flags */ +-OC flag to ghc causes optimisation + + +ANSI C +~~~~~~ +For functions with no args we declare them as + + foo( STG_NO_ARGS ) + +rather than foo(), because you can tell ANSI C a little more +by making STG_NO_ARGS expand to void. Maybe something to do with +forward declarations? + + +Optimisation with GCC +~~~~~~~~~~~~~~~~~~~~~ + +We are concentrating most optimisation with gcc which allows +suitable global register declarations. + + +REGISTERS: + +See StgOpt.h for a description of register usage + +Note that all modules that reference the STG registers must be +compiled the same way so they look at the registers and not the +global variables. + + +TAIL CALLS: + +Seperate modules for tail call optimisations are required. +Requitre to partition runtime system code. + +.hc: + Modules with tail call routines (most runtime and all compiled) + are labeled .hc (literate = .lhc). + These are compiled to assember with tail call optimisation on + and then post processed with sed (Yuk!) + + All routines which return a continuation (STGJUMP) must be + compiled this way. + + (The only exeption to this is continuations which exit/abort which + may live in .c files) + +.c: + These modules are not compiled with the tail call optimisation + and don't have sed processing. + Sed processing would destroy the code! + + All routines which are not continuations (called and return + conventionally) must be compiled this way. + + This includes various parts of the runtime system. + + + + +See Also ~sansom/work/gcstats/OBSERVATIONS + + + + +Info Recieved from Eliot Miranda: + +Received: from dcs.glasgow.ac.uk (tutuila) by vanuata.dcs.glasgow.ac.uk; Thu, 4 Jul 91 09:40:34 BST +Message-Id: <15456.9107040841@dcs.glasgow.ac.uk> +X-Comment1: ############################################################# +X-Comment2: # uk.ac.glasgow.cs has changed to uk.ac.glasgow.dcs # +X-Comment3: # If this address does not work please ask your mail # +X-Comment4: # administrator to update your NRS & mailer tables. # +X-Comment5: ############################################################# +To: simonpj +Cc: sansom +Subject: Miranda's original msg +Date: Thu, 04 Jul 91 09:41:19 +0100 +From: Simon L Peyton Jones + + + + + +>From eliot@.cs.qmw.ac.uk Mon Apr 1 11:16:06 1991 +From: eliot@.cs.qmw.ac.uk (Eliot Miranda) +Newsgroups: comp.compilers +Subject: Portable Fast Direct Threaded Code +Keywords: interpreter, design +Date: 28 Mar 91 12:20:06 GMT +Reply-To: Eliot Miranda +Organization: Computer Science Dept, QMW, University of London, UK. + +Various people have asked me for details on how I do threaded code +in my dynamic translation Smalltalk-80 VM. So here's the gory details +as well as the first published benchmarks for the system. + + How to do "Machine-Independent" Fast Direct Threaded Code: + + +First off, use C (although other flexible machine-oriented imperative +languages would probably work too). + +Global registers: + If you can use GCC >v1.33 you can use global register variables to +hold the threaded code machine's registers. If you have various forms of +stupid C compiler then you can get global register variables by declaring +your globals as register variables in every function, and later editing the +assembler generated by the C compiler to remove global register saves & +restores (details in [Miranda]). + + +Threaded Code: + Threaded code instructions (TCIs) are written as C procedures. +They are compiled to assembler by the C compiler. Subsequently a simple +editor script is run on the assembler to remove the prologues and epilogues +from the threaded code procedures, and possibly to insert direct threaded +code jumps. + +How to Identify Threaded Code Instructions: + The method I prefer is to segregate TCIs from other procedures & +functions in the machine by placing related groups of TCIs in separate +source files. I give my threaded code source files the .tc extension and +they have a rule in the makefile that will run the editor script on the +assembler. An alternative is to identify each threaded code procedure with +a special prefix which is spotted by the editor script. This is probably +more error prone & doesn't fit well with leaf-routine optimization (see +below). + +How to Write Threaded Code Instructions: +Each TCI is writen an a void function of no arguments. It is wise to start +and end each TCI with two special macros to replace '{' and '}'. So, using +GCC on the SPARC, given some declarations: + + + typedef void (*TCODE)(); /* a TCODE is a pointer to a function */ + typedef ???? ObjectPointer; + + . . . + + register TCODE *tcip asm("%g7"); /*threaded code instruction pointer*/ + register ObjectPointer *stackPointer asm("%g5"); + +e.g. popStack would be written: + + void popStack() + TBEGIN + stackPointer--; + TEND + +With GCC TBEGIN is + + #define TBEGIN { + +With stupid C compilers it can be defined to be the list of global register +variables. Further, if you want to build a debuger for your threaded code +machine you could compile the system with + + #define TBEGIN { int frig = checkForBreakPoint(); + +and ignore lots of warnings about variable frig being unused :-). + +TEND has to do a direct threaded code jump. In my system I want an indirect +post-increment jump on tcip; i.e. jump to *tcip++. On the SPARC with tcip +in %g7 the jump is + + ld [%g7],%o0 ! get *tcip + jmpl %o0,%g0 ! jump to it + add %g7,4,%g7 ! increment tcip in the jump's delay slot + +On the 68k with tcip in a5 the jump is + + movl a5@+,a0 + jmp a0@ + +With GCC this is implemented by the JUMPNEXT macro. On the SPARC: + #define JUMPNEXT do{ \ + asm("ld [%g7],%o0; jmpl %o0,%g0; add %g7,4,%g7");\ + return;}while(0) + +Note the return, it tells the compiler that control does not pass this point. +On the 68k: + /* SBD = Silent But Deadly = Stack Bug Dummy. gcc has a bug with + no-defer-pop. it always depers the pop of the last function call in + a routine. SBD is a dummy call to ensure no other previous call gets + its pop deferred. + */ + extern void SBD P((void)); + + #define JUMPNEXT do{ \ + asm("movl a5@+,a0; jmp a0@");\ + SBD();return;}while(0) + +SBD is then removed by the editor script. + +So TEND is defined to be + #define TEND JUMPNEXT; } + +On the SPARC popStack is expanded to + void popStack() + { + stackPointer--; + do{asm("ld [%g7],%o0; jmpl %o0,%g0; add +%g7,4,%g7");return;}while(0); + } + +Its compiled to: + _popStack: + !#PROLOGUE# 0 + save %sp,-80,%sp + !#PROLOGUE# 1 + add %g5,-4,%g5 + ld [%g7],%o0; jmpl %o0,%g0; add %g7,4,%g7 + ret + restore +The editor script then reduces this to:` + _popStack: + ! [gotcher] + add %g5,-4,%g5 + ld [%g7],%o0; jmpl %o0,%g0; add %g7,4,%g7 + +On the 68k you end up with: + .globl _popStack + _popStack: + subqw #4,a3 + movl a5@+,a0; jmp a0@ + +Global Register Variables and Stupid C Compilers: + Some C compilers are stupid enough to provide straight-forward global +registers. A C compiler on a nat-semi based system I used just allocated +registers in the order they were declared. The assembler syntax was very +simple to edit. Global register variables could thus be obtained easily. + + Some C compilers are stupid but think they're clever. Sun's SUN3 +compiler is a case in point. It also allocates registers in the order declared. +However, it tries to be clever by removing 'dead assignments' (assignments to +subsequently unused register variables). These compilers are easy to fool. +Simply arrange that the register variables are always used before leaving a +function. I do this by always writing RETURN or RETURNV(e) instead of +return and return e. On systems with such stupid C compilers RETURN(e) +is defined thus: + + #define RETURNV(e) do{DummyUseRegs(GR1,GR2,GR3); return e;}while(1) + +The call on DummyUseRegs fools the compiler into thinking the registers +are live & hence saves assignments to them. The editor scripts can then +remove calls on DumyUseRegs. + + Of course on systems with marginally clever C compilers (SUN4 +HP-UX etc) +you're stuffed. However, in clever C compilers like GCC and Acorn's C compiler +you can declare global registers & everything is clean & wholesome :-). + + + +Conditional TCODE Jumps: + Say we wanted a conditional tcode jump. This might be writen: + void skipIfTrue() + TBEGIN + if (*stackPointer-- == TrueObject) { + tcip += 1; + JUMPNEXT; + } + TEND + +How this All Works: +With the above scheme, each threaded code procedure runs in the same C +stack frame, and jumps directly to the next procedure, eliminating an +unnecessary , pair. Once we establish a +stack frame and call the first function away we go. Assuming that you've +produced your first threaded code method (a sequence of pointers to +threaded code procedures), and that tcip points at the start, then +StartTCMachine might be defined as follows: + + volatile void + StartTCMachine() + { char *enoughSpaceForAllTCIStackFrames; + + enoughSpaceForAllTCIStackFrames = alloca(1024); + + while(1) { (*tcip++)(); } + } + +The alloca allocates space on the stack. After the first (*tcip++)() +control goes off into threaded code land and never returns. + +Leaf Routine Optimization: +The threaded code machine will make calls on support routines e.g. +graphics, garbage collector etc. Any group of routines that dont access +the global registers and don't directly or indirectly call routines that +need to access the global registers can be optimized. These routines +should be compiled without declaring the global registers. These routines +will then use as many registers as the compiler will give them and will +save & restore any registers they use, preserving the values of the global +register variables. + + +Details of my Smalltalk Threaded Code Machine: + I use a pair of words for each TCI, a pointer to the procedure followed +by an optional operand. This avoids going out of line to access arguments. +e.g. pushLiteral is: + void pushLit() + TBEGIN + *++stackPointer = (OOP)*tcip++; + TEND +where OOP is an ordinary object pointer. So on entry to push lit we have: + + tcip-> + + +and popStack must therefore be written + void popStack() + TBEGIN + stackPointer--; + tcip++; + TEND + +I dynamically compile Smalltalk-80 bytecodes to threaded code. I use 128k +bytes of memory to hold all threaded code. This 'tspace' is periodically +scavenged to reclaim space. The architecture is similar to +[DeutschSchiffman]. Using an eighth of the space used by the Deutch +Schifman machine I get around 75% of the performance on the non-graphics +benchmarks. Here are the Smalltalk macro benchmarks for BrouHaHa +Smalltalk-80 v2.3.2t running on a monochrome SUN3/60 (20MHz 68020): + + BitBLT 76.7308 + TextScanning 222.857 + ClassOrganizer 80.6667 + PrintDefinition 59.0278 + PrintHierachy 142.857 + AllCallsOn 112.5 + AllImplementors 130.0 + Inspect 116.667 + Compiler 86.4341 + Decompiler 101.639 + KeyboardLookAhead 212.5 + KeyboardSingle 302.778 + TextDisplay 148.837 + TextFormatting 273.81 + TextEditing 180.342 + Performance Rating 134.198 + +and on the same machine under the same conditions are the timings for +ParcPlace Smalltalk-80 V2.3: + + BitBLT 99.75 + TextScanning 390.0 + ClassOrganizer 155.128 + PrintDefinition 137.097 + PrintHierachy 192.308 + AllCallsOn 120.0 + AllImplementors 108.333 + Inspect 146.774 + Compiler 118.617 + Decompiler 129.167 + KeyboardLookAhead 303.571 + KeyboardSingle 473.913 + TextDisplay 172.973 + TextFormatting 442.308 + TextEditing 285.135 + Performance Rating 189.504 + +134.198/189.504 = 0.708154 + +WARNING!! These systems ARE different, these benchmarks are included only +to give a feeling for ball-park performance. +Example differences: + BrouHaHa ParcPlace + closures blue-book BlockContexts + immediates: + characters, smallints, fixedpoints immediate smallintegers + 5844 compiled methods 5136 compiled methods + (5026 ordinary methods) (4798 ordinary methods) + (818 quick methods) (338 quick methods) + + + +More Portable File Organization: +To keep the code as clean looking as possible all machine-dependencies are +isolated in separate files. e.g. tcode.h gives machine independent +definitions for TCODE. It includes machine dependencies from another file: + + /* for debugging purposes; single step breakpoint at start of +each tcode + */ + #define DEBUG_FETCH_BREAK int frig = fetchBrk(); + + #ifdef FAST + # include "fasttcode.h" + #else + + TCODE *tcip; /* the tcode ip points at TCODEs */ + + # define JUMPNEXT return + # ifdef BIDebug + # define TBEGIN { DEBUG_FETCH_BREAK + # else + # define TBEGIN { + # endif + # define TEND } + #endif + +GCC/SPARC/fasttcode.h: + /* tcodeip in g7 */ + register TCODE *tcip asm("%g7"); + + #define JUMPNEXT do{asm("ld [%g7],%o0; jmpl %o0,%g0; add +%g7,4,%g7");return;}while(0) + + #ifdef BIDebug + # define TBEGIN { DEBUG_FETCH_BREAK + #else + # define TBEGIN { + #endif + #define TEND JUMPNEXT; } + +I also don't want to include the necessary definitions for the global registers +in every file. So for those non-leaf routines that must avoid using the +global registers there's a fastglobal.h file that gives dummy definitions for +these registers. e.g. GCC/SPARC/fastglobal.h: + /* machine specific FAST defines. + Gnu C 1.33 systems can use nice compiler provided global registers. + */ + + #define BEGIN { + #define END } + #define RETURN(e) return e + #define RETURNV return + + register char *GlobRegDummy1 asm("a5"); + register char *GlobRegDummy2 asm("a4"); + register char *GlobRegDummy3 asm("a3"); + register char *GlobRegDummy4 asm("d6"); + + #ifdef MASKREGISTER + register char *GlobRegDummy5 asm("d7"); + #endif + +I use symbolic links to set up the machine dependent include files. +This has the +advantage that if you add a new machine you don't have to remake all +the others. + + +The Tedious Bit: +The only tedious bit is writing the sed-scripts. For the SPARC this took 1 day. +Here are the sed scripts I use for SUN 3, MAC2AUX (using GAS) and SUN4, +all using GCC (v1.33 upwards). There's a problem on the SPARC in that the ABI +does not seem to define the status of the global registers. Some math and +library routines stomp on the global registers (beware getwd!), so I've +included +GCC/SUN4/sed.globreg.bugfix as an example of how to spot the offending math +routines: + +SUN3/GCC/lib/sed.tcode.opt: +# script to strip prolog & epilog from threaded code under gcc. +# WARNING the script may strip a push of a register argument if a call is the +# first statement of a function!! +# +/^_.*:$/{n +N +N +s/ link a6,#[^\n]*\n// +/ fmovem #[^\n]*,sp@-/{ +N +s/ fmovem #[^\n]*,sp@-\n// +} +s/ moveml .*,sp@-\n// +s/ movel [ad][0-7],sp@-\n// +} +/ moveml a6@(-[1-9][0-9]*),#/{N +s/ moveml a6@(-[1-9][0-9]*),#[^\n]*\n unlk a6// +} +/ movel a6@(-[1-9][0-9]*),[ad][0-7]/{N +s/ movel a6@(-[1-9][0-9]*),[ad][0-7]\n unlk a6// +} +/ movel sp@+,/d +/ moveml sp@+,#/d +/ unlk a6/d +/ rts/d +/ jbsr _SBD/d + +MAC2AUX/GCC/lib.gas/sed.tcode.opt: +/COMMENT/{ +i\ + script to strip prolog & epilog from threaded code under gcc. WARNING \ + the script may strip a push of a register argument if a call is the\ + first statement of a function!! +} +/^gcc_compiled:/d +/^.[^%].*:$/{ n +/ link %a6/{ +N +N +s/ link %a6,#[x0-9-]*\n// +/ fmovem #[^\n]*,%sp@-/{ +N +s/ fmovem #[^\n]*,%sp@-\n// +} +s/ moveml #[x0-9a-f]*,%sp@-\n// +s/ movel %[ad][0-7],%sp@-\n// +n +} +} +/ moveml -[1-9][0-9]*%a6@,#/{ N +s/ moveml -[1-9][0-9]*%a6@,#[x0-9a-f-]*\n unlk %a6// +} +/ movel -[1-9][0-9]*%a6@,%[ad][0-7]/{ N +s/ movel -[1-9][0-9]*%a6@,%[ad][0-7]\n unlk %a6// +} +/ movel %sp@+,%/d +/ moveml %sp@+,#/d +/ movel %d0,%a0/{ +N +s/ movel %d0,%a0\n unlk %a6// +/ movem*l %a6/{ +N +s/ movel %d0,%a0\n movem*l %a6.*\n unlk %a6// +/ fmovem %a6/{ +N +s/ movel %d0,%a0\n movem*l %a6.*\n fmovem %a6.*\n unlk %a6// +} +} +} +/ unlk %a6/d +/ rts/d +/ jbsr SBD/d + + +SUN4/GCC/lib/sed.tcode.opt: +# script to strip prolog & epilog from threaded code under gcc. +# +/^_.*:$/{n +N +N +s/ !#PROLOGUE# 0\n save %sp,[-0-9]*,%sp\n !#PROLOGUE# 1/ ! [gotcher]/ +} +/ ret/d +/ restore/d + +SUN4/GCC/lib/sed.globreg.bugfix: +# Some of the libc builtin routines (.rem .urem .div & .udiv so far known) +# stamp on %g3 which is the maskReg (it contains 0x7FFFFF). +# This script reassigns the value of maskReg after each of these routines +# has been called. +/call[ ]\.div,[0-9]/{n +n +i\ + sethi %hi(0x7FFFFF),%g3 ![globregfix]\ + or %lo(0x7FFFFF),%g3,%g3 +} +/call[ ]\.udiv,[0-9]/{n +n +i\ + sethi %hi(0x7FFFFF),%g3 ![globregfix]\ + or %lo(0x7FFFFF),%g3,%g3 +} +/call[ ]\.rem,[0-9]/{n +n +i\ + sethi %hi(0x7FFFFF),%g3 ![globregfix]\ + or %lo(0x7FFFFF),%g3,%g3 +} +/call[ ]\.urem,[0-9]/{n +n +i\ + sethi %hi(0x7FFFFF),%g3 ![globregfix]\ + or %lo(0x7FFFFF),%g3,%g3 +} + + +You can now see why I put "Machine-Independent" in quotes. Here's the count +of machine dependent code for the SPARC: + + 25 99 786 fastcache.h + 68 262 1882 fastglobal.h + 31 112 906 fasttcode.h + 28 80 595 ../tcsrc/SUN4/GCC/lib/sed.globreg.bugfix + 5 34 222 ../tcsrc/SUN4/GCC/lib/sed.peep.opt + 9 30 173 ../tcsrc/SUN4/GCC/lib/sed.tcode.opt + 166 617 4564 total + +Of these 166 lines 51 lines are banner headers. 100 odd lines are +machine dependent. A whole VM is around the 20k lines mark. So +machine dependencies are down in the 0.5% range. + + + +Use this stuff as part of what ever you like. If you try & assert ownership +I'll fight & batter you over the head with the GPL ('bout time we had some +serious steel in that thar GPL). + +Share And Enjoy! + +P.S. The BrouHaHa machine is available to educational institutions with a +valid ParcPlace Smalltalk-80 licence, subject to a strict non-disclosure +agreement. email me if you want it. I am slow to answer requests! +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From crowl@cs.rochester.edu Tue Apr 2 10:34:53 1991 +From: crowl@cs.rochester.edu (Lawrence Crowl) +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, design +Date: 31 Mar 91 18:06:35 GMT +Reply-To: crowl@cs.rochester.edu (Lawrence Crowl) +Organization: Computer Science Department University of Rochester + +In article <3035@redstar.cs.qmw.ac.uk> +Eliot Miranda writes: +>The threaded code machine will make calls on support routines, e.g. graphics, +>garbage collector etc. Any group of routines that don't access the global +>registers and don't directly or indirectly call routines that need to access +>the global registers can be optimized. These routines should be compiled +>without declaring the global registers. These routines will then use as many +>registers as the compiler will give them and will save & restore any +>registers they use, preserving the values of the global register variables. + +This scheme assumes that procedure calls use a "callee saves" register +convention, and does not work if you allocate the global register +variables out of the "caller saves" set of registers. The problem is that +the caller does not save the register (because it is global) and the +callee writes over the register (because the caller saved it). In this +situation, the programmer must insert explicit saves and restores of the +global register variables. + +The obvious solution to this problem is to allocate all global register +variables out of the "callee saves" set of registers. However, the +Alliant has _no_ callee saves registers. Library routines on the Alliant +will trash every register you have. In addition, implicit library calls +to routines like bcopy will also trash your registers. (I learned this +the hard way.) + +The lesson is that calling library routines with global register variables in +caller saves registers requires special handling. It is not automagic. +-- + Lawrence Crowl 716-275-9499 University of Rochester + crowl@cs.rochester.edu Computer Science Department + ...!rutgers!rochester!crowl Rochester, New York, 14627-0226 +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From Tom.Lane@G.GP.CS.CMU.EDU Wed Apr 3 10:38:09 1991 +From: Tom.Lane@G.GP.CS.CMU.EDU +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, design +Date: 1 Apr 91 15:21:14 GMT +Reply-To: Tom.Lane@G.GP.CS.CMU.EDU +Organization: Compilers Central + +Lawrence Crowl points out one important problem with Eliot Miranda's +scheme for global register use in C. There's an even more fundamental +problem, though: there is *no guarantee whatever* that the compiler will +assign the same registers to the global variables in every routine. + +Compilers that do intelligent allocation of variables to registers may +refuse to honor the "register" declarations at all if the global variables +are not heavily used in a given routine, and in any case the globals need +not be assigned to the same registers every time. Miranda's scheme thus +relies heavily on the assumption of a dumb register allocator (or else a +compiler that supports global register variable declarations). + +This scheme may be "fast" direct threaded code, but it's hardly "portable". +-- + tom lane +Internet: tgl@cs.cmu.edu BITNET: tgl%cs.cmu.edu@cmuccvma +[GCC lets you specify what register to use for global register variables, but +that is of course both machine and compiler specific. -John] +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From pardo@cs.washington.edu Thu Apr 4 17:34:39 1991 +From: pardo@cs.washington.edu (David Keppel) +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, design, bibliography +Date: 2 Apr 91 19:21:25 GMT +Reply-To: pardo@cs.washington.edu (David Keppel) +Organization: Computer Science & Engineering, U. of Washington, Seattle + +metzger@watson.ibm.com (Perry E. Metzger) writes: +>[I'd like a reference on threaded code interpreters.] + +3 citations follow: + +%A James R. Bell +%T Threaded Code +%J Communications of the ACM (CACM) +%V 16 +%N 2 +%D June 1973 +%P 370-372 +%X Describes the basic idea of threaded code. +Compares to hard code (subroutine calls) and interpreters. + +%A Richard H. Eckhouse Jr. +%A L. Robert Morris +%T Minicomputer Systems Organization, Programming, and Applications +(PDP-11). 2nd Ed. +%I Prentice-Hall, Inc. +%P 290-298 +%X Describes threaded code and ``knotted code''. I (pardo) think that +this is a very clear introduction to threaded code. + +%A Peter M. Kogge +%T An Architectural Trail to Threaded Code Systems +%J IEEE Computer +%P 22-33 +%D March 1982 +%W rrh (original) +%W Pardo (copy) +%X Describes how to build a threaded code interpeter/compiler from +scratch. + * Direct threaded/indirect threaded. + * Less than 2:1 performance hit of threading compared to full +compilation. + * Note about bad compilers contributing to relative OK-ness of +threaded code. + * Ease of rewriting stuff. + * Ease of tuning. + +My favorite of the three is Eckhouse & Morris; however I don't know +where to get it. The pages that I have are photocopies graciously +sent to me by a friend. As the title implies, this book is several +years old and undoubtedly out-of-print. + + ;-D on ( Following this thread of the discussion... ) Pardo +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From simonpj Fri Apr 5 09:52:33 1991 +Received: from tutuila.dcs.glasgow.ac.uk by vanuata.cs.glasgow.ac.uk; +Fri, 5 Apr 91 09:52:27 BST +Message-Id: <2763.9104050851@tutuila.dcs.glasgow.ac.uk> +X-Comment1: ############################################################# +X-Comment2: # uk.ac.glasgow.cs has changed to uk.ac.glasgow.dcs # +X-Comment3: # If this address does not work please ask your mail # +X-Comment4: # administrator to update your NRS & mailer tables. # +X-Comment5: ############################################################# +From: Simon L Peyton Jones +To: eliot@cs.qmw.ac.uk +Cc: simonpj, partain +Subject: Threaded code +Date: Fri, 05 Apr 91 09:51:48 +0100 + + +Eliot + +I saw your article about threaded code. Like you and others, we are +using C as an assembler, only for a pure functional language, Haskell. +I have some brief questions. + +1. By telling GCC not to use a frame pointer, one can eliminate +the prolog entirely, can't one? So why edit it out? + +I guess the answer is going to be local variables, allocated once for +all by the StartTCMachine routine. Still, it seems quite a pain. I guess +one could sacrifice some (perhaps slight) speed by using a bunch of +globals instead. + +2. You edit out the epilogue for tidiness only, I take it. It doesn't +cause any problems if you leave it in, does it? + +3. Why do you use no-defer-pop (with the associated bug)? + +4. Why does JUMPNEXT have a loop? Surely the jump leaves the loop right +away. Presumably you are tricking the compiler somehow. + +Thanks + +Simon L Peyton Jones +Glasgow University + + + + +Simon +============================= Address change ======================= +My email address is now officially: simonpj@dcs.glasgow.ac.uk +This may fail if your local site has out-of-date mail tables. +The old address (simonpj@cs.glasgow.ac.uk) will work for quite a long while, +so stay with the old one if the new one fails. +==================================================================== + +>From eliot@cs.qmw.ac.uk Fri Apr 5 12:18:18 1991 +Via: uk.ac.qmw.cs; Fri, 5 Apr 91 12:18:06 BST +Received: from aux47 by redstar.cs.qmw.ac.uk id aa26828; 5 Apr 91 12:17 BST +Reply-To: eliot@cs.qmw.ac.uk +In-Reply-To: Simon L Peyton Jones's mail message +<2763.9104050851@tutuila.dcs.glasgow.ac.uk> +Message-Id: <9104051217.aa26828@uk.ac.qmw.cs.redstar> +From: Eliot Miranda +To: simonpj +Cc: partain +Subject: re: Threaded code +Date: Fri, 5 Apr 91 10:54:25 BST + +> +>Eliot +> +>I saw your article about threaded code. Like you and others, we are +>using C as an assembler, only for a pure functional language, Haskell. +>I have some brief questions. +> +>1. By telling GCC not to use a frame pointer, one can eliminate +>the prolog entirely, can't one? So why edit it out? +No, registers local to the procedure will still be saved & stack space +allocated for automatic variables. This IS a problem since the +threaded-code jump at the end of the procedure will miss the register +restores before the epilogue. Consequently the stack will grow unless +these register saves & stack-space allocations are removed. +> +>I guess the answer is going to be local variables, allocated once for +>all by the StartTCMachine routine. Still, it seems quite a pain. I guess +>one could sacrifice some (perhaps slight) speed by using a bunch of +>globals instead. +For certain routines, not using register variables will be expensive +(e.g. a simple integer arithmetic primitive). +> +>2. You edit out the epilogue for tidiness only, I take it. It doesn't +>cause any problems if you leave it in, does it? +No, but given that the prologue has to be removed & removing the epilogue +is as easy (& given finite memory :-) one might as well remove it. +> +>3. Why do you use no-defer-pop (with the associated bug)? +OK. This is again to avoid stack growth. On conventional stack architectures +gcc will try & combine the argument popping code of a sequence of +procedure calls. +e.g. +extern long a, b, c; +void doit() { + foo(a); bar(b); baz(c); +} + +with -O -no-defer-pop one might expect gcc to generate + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp + movel c,%sp@- + jbsr baz + addqw #4,%sp + unlk %a6 + rts + +but because gcc knows that the unlk instruction will roll back the stack +in fact gcc generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp + movel c,%sp@- + jbsr baz + unlk %a6 + rts + +With -O -fdefer-pop gcc optimizes out the pops completely & generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar + movel c,%sp@- + jbsr baz + unlk %a6 + rts + +with -O -fomit-frame-pointer -fdefer-pop gcc generates: + + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar + movel c,%sp@- + jbsr baz + addw #12,%sp + rts + +& with -O -fomit-frame-pointer -fno-defer-pop gcc generates: + + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp + movel c,%sp@- + jbsr baz + addqw #4,%sp + rts + +All the above cases are as one would wish. The elimination of all +defered pops in the unlk instruction is especially clever. + +However, in the presence of the threaded-code jump the waters darken! +Consider what gcc generates for: + + register void (**tcip)() asm("%a5"); + + #define JUMPNEXT do{asm("movl %a5@+,%a0; jmp %a0@");return;}while(0) + + extern long a, b; + void doit() { + foo(a); bar(b); JUMPNEXT; + } +with -O -fdefer-pop gcc generates + +doit: + link %a6,#0 + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +This is clearly no good because the arguments to both foo & bar +will never be popped. Every time doit() is executed the stack will grow +by 8 bytes. Soon your program will dump core with a very large stack +segment! + +with -O -fno-defer-pop gcc generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +Again useless because bar's pop has been folded into the unlk +which won't be executed. + +with -O -fdefer-pop -fomit-frame-pointer gcc generates + + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar + addqw #8,%sp +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + rts + +This is great. However, not all functions are susceptible to +the omit-frame-pointer optimization (i.e. functions +with local variables). E.g. the code generated for: + + register void (**tcip)() asm("%a5"); + + #define JUMPNEXT do{asm("movl %a5@+,%a0; jmp %a0@");return;}while(0) + + extern long a, b; + void doit() { + char large[1024]; + foo(a,large); bar(b); JUMPNEXT; + } + +with -O -fomit-frame-pointer -fdefer-pop is: + + link %a6,#-1024 + pea %a6@(-1024) + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +so in general one can't rely on -fomit-frame-pointer. +For the above example both + -O -fomit-frame-pointer -fno-defer-pop +and + -O -fno-defer-pop +generate: + +doit: + link %a6,#-1024 + pea %a6@(-1024) + movel a,%sp@- + jbsr foo + addqw #8,%sp + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +This is also useless because bar's argument pop has been folded away. +The problem is that gcc will always fold away the last call's argument +pop if the function has a frame pointer, and -fomit-frame-pointer +can't allways get rid of the frame pointer. In fact, in the presence +of variable sized automatic variables or calls on alloca it would be +very hard (impossible for recursive functions?) to do. + +The eatest solution I've come up with is to use -fno-defer-pop +and a dummy function call between the threaded-code jump and +the return: + + register void (**tcip)() asm("%a5"); + + #define JUMPNEXT do{asm("movl %a5@+,%a0; jmp +%a0@");SBD();return;}while(0) + + extern long a, b; + void doit() { + foo(a); bar(b); JUMPNEXT; + } +with -O -fno-defer-pop gcc generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + jbsr SBD + unlk %a6 + rts + +Now bar's argument pop is not folded because its no longer the last +call in the routine, SBD is. +So the call to SBD + a) prevents gcc's 'last call argument pop fold into unlk' optimization + which prevents uncontrolled stack growth. + b) doesn't get executed because of the jump + c) is trivial to remove from the assembler with a sed-script + + +>4. Why does JUMPNEXT have a loop? Surely the jump leaves the loop right +>away. Presumably you are tricking the compiler somehow. +> +This is old C lore. The problem is + 'How do you write a macro that is a sequence of statements + that can be used wherever a single statement can?' + +take the following definition of JUMPNEXT: +#define JUMPNEXT asm("movl %a5@+,%a0; jmp %a0@");return; + +Now invoke it here: + if (its_time_to_jump) + JUMPNEXT; + do_something_else(); + +This expands to: + if (its_time_to_jump) + asm("movl %a5@+,%a0; jmp %a0@"); + return; + do_something_else(); + +Not at all whats intended! + +There are two tricks I know of (the first I saw in Berkely Smalltalk, +the second in Richard Stallman's gcc manual. I expect they're both +quite old). +The first is to surround your statements with +if (TRUE){statements}else +i.e. +#define JUMPNEXT if(1){asm("movl %a5@+,%a0; jmp %a0@");return;}else +So now we get: + if (its_time_to_jump) + if (1){ + asm("movl %a5@+,%a0; jmp %a0@"); + return; + else; + do_something_else(); + +which works because C binds elses innermost first. However, some +compilers will whine about dangling elses. The second scheme is +more elegant (-: + +Surround your statements with +do{statements}while(FALSE); +which will execute statements precisely once (its NOT a loop). +i.e. +#define JUMPNEXT do{asm("movl %a5@+,%a0; jmp %a0@");SBD();return;}while(0) +expands to + + if (its_time_to_jump) + do { + asm("movl %a5@+,%a0; jmp %a0@"); + return; + while(0); + do_something_else(); + +which does what's wanted and doesn't incur compiler whines. + + +>Thanks +> +>Simon L Peyton Jones +>Glasgow University + +Eliot Miranda email: eliot@cs.qmw.ac.uk +Dept of Computer Science Tel: 071 975 5229 (+44 71 975 5229) +Queen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk +Mile End Road UUCP: eliot@qmw-cs.uucp +LONDON E1 4NS + +>From vestal@SRC.Honeywell.COM Fri Apr 5 12:26:11 1991 +From: vestal@SRC.Honeywell.COM (Steve Vestal) +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, performance, design +Date: 3 Apr 91 18:23:34 GMT +Reply-To: vestal@SRC.Honeywell.COM (Steve Vestal) +Organization: Honeywell Systems & Research Center +In-Reply-To: pardo@cs.washington.edu's message of 2 Apr 91 19:21:25 GMT + +In article <1991Apr2.192125.7464@beaver.cs.washington.edu> +pardo@cs.washington.edu (David Keppel) writes: +[references about threaded code, much stuff deleted] + +David> %X Describes how to build a threaded code interpeter/compiler from +David> scratch. +David> * Less than 2:1 performance hit of threading compared to full +David> compilation. + +I have a question about this. Numbers like this are often cited for +threaded-type code, but in Bell's paper this was for the PDP-11 (whose +addressing modes made it a natural for threaded code). Paul Klint's +"Interpretation Techniques" paper (Software P&E, v11, 1981) cites a +significant difference for interpreter fetch/decode times on different +architectures. He cited numbers around 2:1 for the PDP-11, but something +more like 9:1 for a Cyber. I did a Q&D evaluation of this for a RISC, and +the ratio I guestemated was closer to that Klint gave for the Cyber than +for the PDP-11 (not unexpectedly). + +How architecturally dependent is the performance of these techniques +(relative to compiling to native code)? + +Steve Vestal +Mail: Honeywell S&RC MN65-2100, 3660 Technology Drive, Minneapolis MN 55418 +Phone: (612) 782-7049 Internet: vestal@src.honeywell.com +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From E.Ireland@massey.ac.nz Fri Apr 5 12:29:20 1991 +From: E.Ireland@massey.ac.nz (Evan Ireland) +Newsgroups: comp.lang.functional +Subject: Three address code +Date: 4 Apr 91 21:49:21 GMT +Reply-To: E.Ireland@massey.ac.nz +Organization: Information Sciences, Massey University, New Zealand + +I've had no luck with mail, so this is for csdw at Rhodes University. + +> +>In an attempt to optimize a functional language, I would like to +>turn the stack based intermediate code into three address code. +> +>Has anyone done similar conversions? Any references would be +>greatly appreciated. + +I do not have any references, but I thought that one aspect of my FAM +implementation might be of interest. + +A number of interpreters and compilers that I have seen implement a stack +pointer in a register or global variable. Then to implement various stack +operations, they use auto-increment or auto-decrement operations on the stack +pointer register. Since I generate portable C, and thus cannot assume I have + + DATA *f (register DATA *fp) + { + .... + } + +Thus I pass to each function the current pointer to top of stack, from which it +can index downwards to find its arguments. Within the function, I use indexing +operations on fp, e.g. fp[3] = fp[1], to manipulate values on the stack, so I +am not continually manipulating the stack pointer. If "f" calls another +function, it will pass the address of the current top of stack, e.g. g (&f[5]). + +The advantage to me is that I have a register for a stack pointer even though I +am generating portable C code. + +Now the relationship to three-address code. If you adopt such a scheme, and +your three address instructions allow some indexing, you can sometimes generate + + ADD fp[3],f[4],fp[3] + +I hope this helps. +_______________________________________________________________________________ + +E.Ireland@massey.ac.nz Evan Ireland, School of Information Sciences, + +64 63 69099 x8541 Massey University, Palmerston North, New Zealand. + +>From pardo@cs.washington.edu Sat Apr 6 14:32:24 1991 +From: pardo@cs.washington.edu (David Keppel) +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, performance, design +Date: 4 Apr 91 17:10:55 GMT +Reply-To: pardo@cs.washington.edu (David Keppel) +Organization: Computer Science & Engineering, U. of Washington, Seattle + +>>>[Threaded code vs. compilation] + +>pardo@cs.washington.edu (David Keppel) writes: +>>[Less than 2:1 performance hit of threading vs. full compilation.] + +Note also that the reference that claimed 2:1 (Peter M. Kogge, IEEE +Computer pp 22-33 March 1982) also attributed part of that ratio to the +poor state of compiler optimization. + + +vestal@SRC.Honeywell.COM (Steve Vestal) writes: +>[Klint says 2:1 for PDP-11 v. 9:1 for Cyber. +> How architecturally dependent are these techniques?] + +Suppose that the statically-compiled code fragments that are threaded +together are called `primitives'. + + +When the execution time of a primitive is large, then the overhead for the +interpreter can be large and still have a small effect on performance. +The performance of the interpreted code is dominated by the time in a +primitive vs. the overhead of moving between primitives. + +When the execution time of the primitives is small, then the overhead for +moving between primitives can be a large fraction of the total execution +time. Overhead comes from at least two sources: + + * Control flow: the address of the the next primitive is loaded + from data memory and the processor executes an indirect jump. + + * Register allocation: a primitive is essentially a function with + a fast calling convention (no stack adjustment). Thus, all the + traditional problems with interprocedural register allocation. + +Examples of `large primitives' are ``draw circle'' and ``interpolate +spline''. Examplees of small primitives are ``push'', ``add'', etc. + + +* Architectural dependency of control flow + +Examples: + + Direct jumps in full compilation: + + op1 + op2 + br next // direct jump + + Indirect jumps for threading for a CISC: + + op1 + op2 + br *(r0)+ // load, increment, jump + + Indirect jumps for threading for a RISC: + + ld *r0, r1 // scheduled load + op1 + op2 + br *r1 // jump + add r1, #4, r1 // delay slot increment + +Direct jumps in full compilation can frequently use one instruction (a +``near branch'') both to find the address of the next code fragment and +perform the control transfer. On a CISC, branches are typically two or +three bytes. On a RISC, branches are typically four bytes. The threaded +indirect (load, increment, jump) is typically three bytes on a CISC and +twelve bytes (three instructions) on a RISC. + +Direct jumps in full compilation take typically one instruction time. +Indirect jumps take at least the following operations: load, increment, +jump indirect. On a CISC, the three operations can typically be `folded' +in to one instruction. There may be a load penalty of one instruction +time but the increment is overlapped, so the total time is three machine +units (one `unit' is about one register->register operation). On a RISC, +the total penalty is three machine units. + +Direct jumps take one (I-cache) cycle to fetch both the branch instruction +and the address of the branch target. Indirect jumps take a D-cache cycle +to fetch the address of the branch target and an I-cache cycle to fetch +the branch instruction. + +Direct jumps can take advantage of instruction prefetching since the +address of the next instruction is known at the time that the instruction +prefetch reads the direct jump. Threaded indirects require an indirect +branch off of a register. Current RISC and CISC machines are about +equivalent in that they do little prefetching. Some machines being +designed do more prefetching so the threading overhead for them will be +greater. + + +* Architectural dependency of register allocation + +In a machine with a small number of registers, many of the registers are +in-use in each primitive and the best possible register allocation will +contain many loads and stores. In a machine with a large number of +registers, the full-compilation implementation can make much better use of +registers than the threaded primitives implementation (again, for small +primitives). The savings from full compilation are exactly analagous to +the improvements in register allocation from doing inlining of small +procedures. + + +* Other points to ponder + +In some cases the threaded code implementation is substantially smaller +than the full-compilation implementation. For large functions or a +machine with small caches, the loss of performance from threading might be +overwhelmed by the gain in cache performance. + +On RISC machines, procedure call/return is about twice the cost of other +control flow, except for the overhead of register management. Thus, +call-dense RISC code from full compilation may behave about the same as +threaded code. +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From airs!ian@uunet.UU.NET Sat Apr 6 14:32:56 1991 +From: airs!ian@uunet.UU.NET (Ian Lance Taylor) +Newsgroups: comp.compilers +Subject: Threaded code +Keywords: books, interpreter, design +Date: 4 Apr 91 07:19:41 GMT +Reply-To: airs!ian@uunet.UU.NET (Ian Lance Taylor) +Organization: Compilers Central + +The book ``Threaded Interpretive Languages'' has a quite complete +implementation of a threaded version of Forth in Z80 assembler. It's +a very complete description of why threaded implementations exist and +how to implement them easily. It's by R. G. Loeliger and was +published by Byte Books (ISBN 0-07-038360-X). It was published in +1981, though, and I'm sure it's long out of print. + +Ian Taylor airs!ian@uunet.uu.net uunet!airs!ian +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From firth@sei.cmu.edu Sun Apr 7 14:33:13 1991 +From: firth@sei.cmu.edu (Robert Firth) +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, performance, design +Date: 4 Apr 91 13:27:21 GMT +Reply-To: firth@sei.cmu.edu (Robert Firth) +Organization: Software Engineering Institute, Pittsburgh, PA + +In article <1991Apr3.182334.16164@src.honeywell.com> +vestal@SRC.Honeywell.COM (Steve Vestal) writes: + +>How architecturally dependent is the performance of these techniques +>(relative to compiling to native code)? + +[cost of threaded code on PDP-11, RISC &c] + +We might have a misunderstanding here, because what I think of as threaded +code doesn't have a decoding and interpretation step. But I'll talk of +what I know. + +A program in threaded code is just an array of addresses, possibly +interspersed with operands. So the fragment + + c := a + b + +becomes something like + + address of 'load' + address of 'a' + address of 'load' + address of 'b' + address of '+' + address of 'store' + address of 'c' + +This implies a very simple virtual stack machine - you can get more clever +by implementing a virtual register machine. + +The basic execution thread then does this. We point a global register at +the table of addresses, and each primitive has the form + + treg := treg + address'size + ... + jump (treg) + +As you can see, this is great on the PDP-11, since that reduces to one +instruction + + MOV (treg)+,PC ; NOTE TO MAINTAINER: FASTER THAN JMP - DON'T TOUCH! + +On a typical RISC machine, it's two cycles, since you can put almost +anything in the delay slot(s) after the jump. + +Now, the load instruction, for instance, would say + +load: treg := treg + address'size + load (treg) into tempreg + treg := treg + address'size + push (tempreg) onto simulated stack + jump (treg) + +On the PDP-11, that's + + MOV @(treg)+, -(SP) + MOV (treg)+, PC + +On a RISC, it's much more like + + L R0, 4(treg) ; get operand address + L R0, 0(R0) ; dereference to get operand + SUBI SP, #4 ; decrement simulated SP + S R0, 0(SP) ; push operand on stack + ADDI treg, #8 ; step over two addresses (mine & operands) + JR (treg) ; over to you, Moriarty! + +[to fill delay slots, shuffle the above to 132564] + +Well, if you have one load delay slot and one branch delay slot, you can +fill all three of them, so that's 6 cycles. Given that a typical load is +only 1.1 cycles in direct code (90% of the delays filled), this is +certainly a lot more than a 2:1 overhead! When you add the cost of a +simulated stack (lots of needless loads and stores), I can well believe +10:1 time expansion for simple code. + +In fact, it was more than that on the PDP-11, if you compared threaded +code with direct code from a decent compiler. The big win in the Fortran +compiler came from (a) very compact threaded code, and (b) the floating +point operations were implemented in software, so the overhead of threaded +code was swamped by the cost of floating addition, subtraction &c. + +Here's the full code of the above example, so you can see for yourself + +Direct: + MOV a, R0 + ADD b, R0 + MOV R0, c + +Threaded: + MOV @(treg)+, -(SP) + MOV (treg)+, PC +* MOV @(treg)+, -(SP) +* MOV (treg)+, PC +* ADD (SP)+,(SP) + MOV (treg)+, PC + MOV (SP)+, @(treg)+ + MOV (treg)+, PC + +Note that, if you implement a one-address add, you save two instructions, +since the *** bit reduces to + + ADD @(treg)+, (SP) + +But even then, it's coming out at over 4:1. + +What architectural features make threaded code more efficient? The +fundamental one is main memory that is fast (or not too slow) relative to +registers, since you're doing a lot more fetching. Another is a set of +address modes with double indirection, since you're accessing most +operands one level of indirection further back. And good old +autoincrement helps a little, too. Alas, none of that says 'risc', and +much of it says '1960s'. + +Incidentally, if I were to do this again today, I'd definitely simulate a +general-register machine and use a subset of the real machine's registers. +If you take 8 of them, you then have 8 loads and stores, one for each +register, but if you make an absolute rule that nobody even thinks about +touching one of those 8 that doesn't belong to him, then all the good +tricks about register allocation, slaving &c will still work. If you then +implement the operations as one-address general-register, you have again 8 +versions (add into R0, add into R1, ...) and lo! you're programming a very +familiar old friend. + +"But that was in another country, and besides, the machine is dead..." + +Robert Firth +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From bpendlet@bambam.es.com Tue Apr 9 20:35:22 1991 +From: bpendlet@bambam.es.com (Bob Pendleton) +Newsgroups: comp.compilers +Subject: Re: Portable Fast Direct Threaded Code +Keywords: interpreter, design +Date: 8 Apr 91 19:48:00 GMT +Reply-To: bpendlet@bambam.es.com (Bob Pendleton) +Organization: Compilers Central + +In article <23613@as0c.sei.cmu.edu> you write: + +> A program in threaded code is just an array of addresses, possibly +> interspersed with operands. So the fragment +> +> c := a + b +> +> becomes something like +> +> address of 'load' +> address of 'a' +> address of 'load' +> address of 'b' +> address of '+' +> address of 'store' +> address of 'c' +> +> This implies a very simple virtual stack machine - you can get more clever +> by implementing a virtual register machine. + +About 10 years ago I was working on a lisp compler that compiled to +threaded code. I was trying to get small code and still have some +performance. (Since I wanted to run the code on a Z80 or 8080 small was +important. My how things change :-) + +I found that the 3 most common operations in threaded code were load, +store, and execute. So I put those operations with the operands. This +made the operands look rather like classes with load, store, and +execute as virtual functions. If you let the evaluate operation +subsume the load and execute operations the threaded code for + + c := a + b; + +becomes + + address of 'a.evaluate()' + address of 'b.evaluate()' + address of '+' + address of 'c.store()' + +and + + g := F(x, y); + +becomes + + address of 'x.evaluate()' + address of 'y.evaluate()' + address of 'F.evaluate()' + address of 'g.store()' + + +Which is much smaller than the original version of threaded code. + +Later, while working on a homebrew version of FORTH I gave up on +threaded code completely. I found, like most who have expolored it, +that symbolic execution of RPN code is a nice way to generated machine +code. Machine code that runs much faster than threaded code, and that +the machine code, even on an 8080, was only about 25% bigger than +threaded code. +-- + Bob Pendleton + bpendlet@dsd.es.com or decwrl!esunix!bpendlet or utah-cs!esunix!bpendlet +[The DEC PDP-11 Fortran compiler did something similar, writing load routines +for commonly used variables. -John] +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From pardo@june.cs.washington.edu Wed Apr 24 09:26:32 1991 +From: pardo@june.cs.washington.edu (David Keppel) +Newsgroups: comp.compilers +Subject: Re: Fast Interpreted Code +Keywords: interpreter, threaded code +Date: 23 Apr 91 02:06:21 GMT +Reply-To: pardo@june.cs.washington.edu (David Keppel) +Organization: Computer Science & Engineering, U. of Washington, Seattle + +ssinghani@viewlogic.com (Sunder Singhani) writes: +>[Our threaded code isn't fast enough. What's faster?] + +As far as I know, threaded code gives the fastest primitives/second +dispatch rate on a variety of architectures. The general techniques for +making things faster (that I know of!) are to change things so that the +dispatch rate can go down without changing the work that gets done (or use +hardware, but we'll ignore that for the moment.) + +* Use a different v-machine instruction set + + The overhead of interpreting is almost nothing in generic PostScript + imaging code because all the time is spent in non-interpretded + primitives. If you can characterize your key operations (perhaps + info in [Davidson & Fraser ??, Fraser, Myers & Wendt 84] can help + you analyze for common operations instead of the more normal time in + routines) then you can re-code your virtual instruction set to have + as primintives oeprations that are performed frequently. + +* Dynamic compilation to native machine code + + This is what is done in ParcPlace System's Smalltalk-80 + implementation, [Deutsch & Schiffman 84] also Insignia Solution's + 8086 interpreter. + + Dynamic compilation suffers from the need to do compilation at + runtime: a compiler that produces better code will take longer to + run and the compile time contributes to the overall program runtime. + Also, program text isn't shared, even if multiple instances are + running simultaneously. + +* Native-coding key routines + + If you believe that your program spends 80% of its time in a few key + routines, then compiling just these routines -- statically, adding + them to the primitive set, statically adding them as library + routines, or dynamically -- can improve performance substantially + [Pittman 87]. + + +5 Citations follow: + +%A Robert Bedichek +%T Some Efficient Architecture Simulation Techniques +%J Winter '90 USENIX Conference +%D 26 October, 1989 +%W Robert Bedichek. +%W Pardo has a copy. +%X Describes a simulator that uses threaded-code techniques to emulate +a Motorola 88000. Each 88k instruction is executed in about 20 host +(68020) instructions. Discusses techniques used to get the simulation +down from several thousand host instructions in many other +simulators. + +%A Jack W. Davidson +%A Chris W. Fraser +%T Eliminating Redundant Object Code +%J POPL9 +%P 128-132 + +%A Peter Deutsch +%A Alan M. Schiffman +%T Efficient Implementation of the Smalltalk-80 System +%J 11th Annual Symposium on Principles of Programming Languages +(POPL 11) +%D January 1984 +%P 297-302 +%X Dynamic translatin of p-code to n-code (native code). +Resons for not using straight p-code or straight n-code: + * p-code is smaller than n-code (<= 5X). + * The debugger can debug p-code, improving portability. + * Native code is faster (<= 2X). Reasons include +special fetch/decode/dispatch hardware; +p-machine and n-machine may be very different, e.g., +stack machine vs. register-oriented. + * Threaded code does reduce the cost of p-code fetch/decode. +Does not help with operand decoding. +Does not allow optimizations to span more than one instruction. +[pardo: that's not technically true, but each optimized +instruction must exist in addition to the unoptimized version. +That leads to exponential blowup of the p-code. Example: delayed +branch and non-delayed branch versions of Robert Bedichek's 88k +simulator.] + The system characteristics: + * The time to translate to n-code via macro expansion is about the +same as the execute time to interpret the p-code. + * (pg 300:) Self-modifying code (SMC) is deprecated but used in a +``well-confined'' way. Could indirect at more cost. Use SMC on the +machines where it works, indirection where SMC. +doesn't. + * Performance is compared to a ``straightforward'' interpreter. +What's that? + +%A Christopher W. Fraser +%A Eugene W. Myers +%A Alan L. Wendt +%T Analyzing and Compressing Assembly Code +%J CCC84 +%P 117-121 + +%A Thomas Pittman +%T Two-Level Hybrid Interpreter/Native Code Execution for Combined +Space-Time Program Efficiency +%D 1987 +%J ACM SIGPLAN +%P 150-152 +%X Talks about native code execution vs. various kinds of interpreting +and encoding of key routines in assembly. + + +Hope this helps! + + ;-D on ( This is all open to interpretation ) Pardo +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From eliot@cs.qmw.ac.uk Tue Apr 30 15:55:17 1991 +From: eliot@cs.qmw.ac.uk (Eliot Miranda) +Newsgroups: comp.compilers,gnu.gcc.bug,alt.sources +Subject: re: Threaded Code +Keywords: design, interpreter +Date: 5 Apr 91 11:43:51 GMT +Reply-To: Eliot Miranda +Followup-To: comp.compilers +Organization: Computer Science Dept, QMW, University of London, UK. + +I recently posted articles to comp.compilers & alt.sources on how +to write threaded code machines in C. I received the following questions +from Simon Peyton Jones at Glasgow. They are specific to GCC. +Since they have non-obvious answers & since the answers suggest +augmentation of the GCC compiler I'm posting my response to Simon. + +>From: Simon L Peyton Jones +> +>I saw your article about threaded code. Like you and others, we are +>using C as an assembler, only for a pure functional language, Haskell. +>I have some brief questions. +> +>1. By telling GCC not to use a frame pointer, one can eliminate +>the prolog entirely, can't one? So why edit it out? + +No, registers local to the procedure will still be saved & stack space +allocated for automatic variables. This IS a problem since the +threaded-code jump at the end of the procedure will miss the register +restores before the epilogue. Consequently the stack will grow unless +these register saves & stack-space allocations are removed. Also +GCC can not always eliminate the frame pointer. + +>I guess the answer is going to be local variables, allocated once for +>all by the StartTCMachine routine. Still, it seems quite a pain. I guess +>one could sacrifice some (perhaps slight) speed by using a bunch of +>globals instead. +For certain routines, not using register variables will be expensive +(e.g. a simple integer arithmetic primitive). + +>2. You edit out the epilogue for tidiness only, I take it. It doesn't +>cause any problems if you leave it in, does it? +No, but given that the prologue has to be removed & removing the epilogue +is as easy (& given finite memory :-) one might as well remove it. +> +>3. Why do you use no-defer-pop (with the associated bug)? +OK. This is again to avoid stack growth. On conventional stack architectures +gcc will try & combine the argument popping code of a sequence of +procedure calls. +e.g. +extern long a, b, c; +void doit() { + foo(a); bar(b); baz(c); +} + +with -O -no-defer-pop one might expect gcc to generate + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp + movel c,%sp@- + jbsr baz + addqw #4,%sp + unlk %a6 + rts + +but because gcc knows that the unlk instruction will roll back the stack +in fact gcc generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp + movel c,%sp@- + jbsr baz + unlk %a6 + rts + +With -O -fdefer-pop gcc optimizes out the pops completely & generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar + movel c,%sp@- + jbsr baz + unlk %a6 + rts + +with -O -fomit-frame-pointer -fdefer-pop gcc generates: + + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar + movel c,%sp@- + jbsr baz + addw #12,%sp + rts + +& with -O -fomit-frame-pointer -fno-defer-pop gcc generates: + + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp + movel c,%sp@- + jbsr baz + addqw #4,%sp + rts + +All the above cases are as one would wish. The elimination of all +defered pops in the unlk instruction is especially clever. + +However, in the presence of the threaded-code jump the waters darken! +Consider what gcc generates for: + + register void (**tcip)() asm("%a5"); + + #define JUMPNEXT do{asm("movl %a5@+,%a0; jmp %a0@");return;}while(0) + + extern long a, b; + void doit() { + foo(a); bar(b); JUMPNEXT; + } +with -O -fdefer-pop gcc generates + +doit: + link %a6,#0 + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +This is clearly no good because the arguments to both foo & bar +will never be popped. Every time doit() is executed the stack will grow +by 8 bytes. Soon your program will dump core with a very large stack +segment! + +with -O -fno-defer-pop gcc generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +Again useless because bar's pop has been folded into the unlk +which won't be executed. + +with -O -fdefer-pop -fomit-frame-pointer gcc generates + + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar + addqw #8,%sp +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + rts + +This is great. However, not all functions are susceptible to +the omit-frame-pointer optimization (i.e. functions +with local variables). E.g. the code generated for: + + register void (**tcip)() asm("%a5"); + + #define JUMPNEXT do{asm("movl %a5@+,%a0; jmp %a0@");return;}while(0) + + extern long a, b; + void doit() { + char large[1024]; + foo(a,large); bar(b); JUMPNEXT; + } + +with -O -fomit-frame-pointer -fdefer-pop is: + + link %a6,#-1024 + pea %a6@(-1024) + movel a,%sp@- + jbsr foo + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +so in general one can't rely on -fomit-frame-pointer. +For the above example both + -O -fomit-frame-pointer -fno-defer-pop +and + -O -fno-defer-pop +generate: + +doit: + link %a6,#-1024 + pea %a6@(-1024) + movel a,%sp@- + jbsr foo + addqw #8,%sp + movel b,%sp@- + jbsr bar +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + unlk %a6 + rts + +This is also useless because bar's argument pop has been folded away. The +problem is that gcc will always fold away the last call's argument pop if +the function has a frame pointer, and -fomit-frame-pointer can't allways +get rid of the frame pointer. In fact, in the presence of variable sized +automatic variables or calls on alloca it would be very hard (impossible +for recursive functions?) to do. + +The neatest solution I've come up with is to use -fno-defer-pop and a +dummy function call between the threaded-code jump and the return: + + register void (**tcip)() asm("%a5"); + + #define JUMPNEXT do{asm("movl %a5@+,%a0; jmp +%a0@");SBD();return;}while(0) + + extern long a, b; + void doit() { + foo(a); bar(b); JUMPNEXT; + } +with -O -fno-defer-pop gcc generates: + + link %a6,#0 + movel a,%sp@- + jbsr foo + addqw #4,%sp + movel b,%sp@- + jbsr bar + addqw #4,%sp +#APP + movl %a5@+,%a0; jmp %a0@ +#NO_APP + jbsr SBD + unlk %a6 + rts + +Now bar's argument pop is not folded because its no longer the last +call in the routine, SBD is. +So the call to SBD + a) prevents gcc's 'last call argument pop fold into unlk' optimization + which prevents uncontrolled stack growth. + b) doesn't get executed because of the jump + c) is trivial to remove from the assembler with a sed-script + + +One an try to use -fcaller-saves, but this surrounds calls with unnecessary +register saves & restores that for the code to be optimal have to be +edited out. + +>4. Why does JUMPNEXT have a loop? Surely the jump leaves the loop right +>away. Presumably you are tricking the compiler somehow. + +This is old C lore. The problem is + 'How do you write a macro that is a sequence of statements + that can be used wherever a single statement can?' + +take the following definition of JUMPNEXT: +#define JUMPNEXT asm("movl %a5@+,%a0; jmp %a0@");return; + +Now invoke it here: + if (its_time_to_jump) + JUMPNEXT; + do_something_else(); + +This expands to: + if (its_time_to_jump) + asm("movl %a5@+,%a0; jmp %a0@"); + return; + do_something_else(); + +Not at all whats intended! + +There are two tricks I know of (the first I saw in Berkely Smalltalk, +the second in Richard Stallman's gcc manual. I expect they're both +quite old). +The first is to surround your statements with +if (TRUE){statements}else +i.e. +#define JUMPNEXT if(1){asm("movl %a5@+,%a0; jmp %a0@");return;}else +So now we get: + if (its_time_to_jump) + if (1){ + asm("movl %a5@+,%a0; jmp %a0@"); + return; + else; + do_something_else(); + +which works because C binds elses innermost first. However, some +compilers will whine about dangling elses. The second scheme is +more elegant (-: + +Surround your statements with +do{statements}while(FALSE); +which will execute statements precisely once (its NOT a loop). +i.e. +#define JUMPNEXT do{asm("movl %a5@+,%a0; jmp %a0@");SBD();return;}while(0) +expands to + + if (its_time_to_jump) + do { + asm("movl %a5@+,%a0; jmp %a0@"); + return; + while(0); + do_something_else(); + +which does what's wanted and doesn't incur compiler whines. + + +>Thanks +> +>Simon L Peyton Jones, Glasgow University + +More and more people are taking the 'use C as an assembler' route, and +more and more people are using GCC to do it (because its code quality is +good, it had global register variables, and it has an excellent asm +facility). The threaded-code in C idea is also becomming more popular. +But as the code above demonstrates, one does have to side-step +optimizations and develop system-specific assembler editing scripts. + +I'd like to ask Richard Stallman & the GCC development team for + -fno-prolog -fno-epilog +flags that instruct gcc to generate + a) no register saves or restores + b) no automatic variable allocation + c) no procedure linkage/frame creation + +Then the optimal 'Threaded-Code Machine in GCC C' can be compiled without +any assembler editing scripts at all. + +Also nice would be a way of telling GCC that an asm statement +changed the flow of control so GCC could + a) warn about not-reached code + b) eliminate unnecessary code (do more code folding) +-- +Eliot Miranda email: eliot@cs.qmw.ac.uk +Dept of Computer Science Tel: 071 975 5229 (+44 71 975 5229) +Queen Mary Westfield College ARPA: eliot%cs.qmw.ac.uk@nsf.ac.uk +Mile End Road UUCP: eliot@qmw-cs.uucp +LONDON E1 4NS +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + +>From brennan@bcsaic.boeing.com Sat May 4 11:28:41 1991 +From: brennan@bcsaic.boeing.com (Michael D Brennan) +Newsgroups: comp.compilers +Subject: re: Threaded code +Keywords: interpreter, design +Date: 2 May 91 19:50:23 GMT +Reply-To: brennan@bcsaic.boeing.com (Michael D Brennan) +Organization: Boeing Aerospace & Electronics, Seattle WA + +Another method for obtaining threaded byte code for an interpreter +is to edit the assembler output of a big switch +rather than editing the prologue and epilogue off functions calls. + +You don't need gcc, global vars in registers, works with smart and +dumb compilers, and all optimization can be turned on. + +For example: + +This C routine executes (unthreaded) byte code for an interpreter +that can add, subtract and print. + +#define HALT 0 +#define PUSH 1 +#define ADD 2 +#define SUB 3 +#define PRINT 4 + +static int stack[32] ; + +void execute(code_ptr) + register int *code_ptr ; +{ + register int *stack_ptr = stack - 1 ; + + + while ( 1 ) + { + switch( *code_ptr++ ) + { + case HALT : return ; + case PUSH : + * ++ stack_ptr = *code_ptr++ ; + break ; + + case ADD : + stack_ptr-- ; + *stack_ptr += stack_ptr[1] ; + break ; + + case SUB : + stack_ptr-- ; + *stack_ptr -= stack_ptr[1] ; + break ; + + case PRINT : + printf("%d\n", *stack_ptr--); + break ; + } + } +} + +------------------------------------------------------- + +to interpret 2 + (3 - 4) + +the front end "compiles" in int code[] + +PUSH, 2, PUSH, 3, PUSH, 4, SUB, ADD, PRINT, HALT + +and calls execute(code). + +------------------------------------------------------ + +The difference between this and the threaded code discussed over +the last few weeks is the switch gets compiled as + + jmp TABLE[ *code_ptr++ ] + +where TABLE is the jump table generated by the compiler which holds +the addresses of the case labels. + +With threading, the transitions between functions become + + jmp *code_ptr++ + + +but this is easy to get by editing the assembler output to +export the case label and recode the switch. + +-------------------------------------------------- + +For example on a SPARC: + +code_ptr is %o0 +stack_ptr is %i5 + + + ..... + ! case PUSH +L77004: + ld [%i0],%o1 + inc 4,%i5 + inc 4,%i0 + b L77008 + st %o1,[%i5] + + ..... + + ! the switch, doesn't change structure + ! as you add new op codes + +L77008: + mov %i0,%i4 + ld [%i4],%i4 + inc 4,%i0 + cmp %i4,4 + bgu L77008 + sll %i4,2,%i4 + sethi %hi(L2000000),%o1 + or %o1,%lo(L2000000),%o1 ! [internal] + ld [%i4+%o1],%o0 + jmp %o0 + nop +L2000000: ! the jump TABLE + .word L77003 ! HALT etc + .word L77004 + .word L77005 + .word L77006 + .word L77007 + + +------------------------------------------- +modify by adding global labels and edit the switch + + + + ..... + ! case PUSH +_push : +L77004: + ld [%i0],%o1 + inc 4,%i5 + inc 4,%i0 + b L77008 + st %o1,[%i5] + + ..... + + ! the edited switch +L77008: + mov %i0,%i4 + ld [%i4],%i4 + inc 4,%i0 + jmp %i4 + nop + ! remove TABLE + +------------------------------------------- + +For another example on an Intel 8088 + +stack_ptr is si +code_ptr is di + + ; while ( 1 ) + ; { + ; switch( *code_ptr++ ) + ; +@1@50: + mov bx,di + inc di + inc di + mov bx,word ptr [bx] + cmp bx,3 + ja short @1@50 + shl bx,1 + jmp word ptr cs:@1@C738[bx] + + +@1@122: + ; + ; case PUSH : + ; * ++ stack_ptr = *code_ptr++ ; + ; + inc si + inc si + mov ax,word ptr [di] + mov word ptr [si],ax + inc di + inc di + ; + ; break ; + ; + jmp short @1@50 + ; + + .... + +@1@C738 label word ; jump TABLE + dw @1@194 ; HALT + dw @1@122 ; PUSH etc + dw @1@146 + + .... + +------------------------------------------------ + +edited the jump can be computed inline + + ; while ( 1 ) + ; { + ; switch( *code_ptr++ ) + ; +@1@50: ; switch code is replaced by code only executed once + + inc di + inc di + jmp [di-2] + + ..... + +_push : +@1@122: + ; + ; case PUSH : + ; * ++ stack_ptr = *code_ptr++ ; + ; + inc si + inc si + mov ax,word ptr [di] + mov word ptr [si],ax + inc di + inc di + ; + ; break ; + ; + inc di ; jmp to *code_ptr++ inline + inc di + jmp [di-2] + ; + .... + +---------------------------------------------- + +the "front end" has defines + +typedef void (*TCODE)() ; + +extern void halt(), push(), add(), sub(), print() ; + +TCODE code[CODESIZE] ; + +in the array code[], the front end compiles + + +push, 2, push, 3, push, 4, sub, add, print, halt + +and calls execute(code). + + +-- +Mike Brennan +brennan@bcsaic.boeing.com +-- +Send compilers articles to compilers@iecc.cambridge.ma.us or +{ima | spdcc | world}!iecc!compilers. Meta-mail to compilers-request. + + diff --git a/ghc/docs/NOTES.core-overview b/ghc/docs/NOTES.core-overview new file mode 100644 index 0000000..8f22299 --- /dev/null +++ b/ghc/docs/NOTES.core-overview @@ -0,0 +1,94 @@ +\documentstyle[11pt,a4wide]{article} +\begin{document} + +%**************************************** +%* * +%* The Core language * +%* * +%**************************************** + + +\title{The Core language} +\author{Simon L Peyton Jones \and +Will Partain \and +Patrick Sansom} + +\maketitle + +\section{Introduction} + +This document describes the Glasgow Haskell Core-language data type +in sufficient detail for an implementor to be able to use it. + +\section{Overview} + +The Core language is, roughly speaking, the second-order polymorphic +lambda calculus, augmented with @let@, @letrec@ and @case@. +It is a Haskell data type (defined shortly), but for convenience in this +document we give it the concrete syntax given in Figure~\ref{fig:core-syntax}. + +Here are some of its important characteristics: +\begin{description} +\item[The Core language includes the second-order lambda calculus.] +That is, type abstraction and type application are provided. +\item[Constructors and primitive operators are always saturated.] +This is easily done by adding extra lambdas and performing $\eta$-expansion. +\item[All pattern-matching is done by simple @case@ expressions.] +The @case@ expressions are simple in the sense that their patterns +have only one level. +\item[Every identifier includes its type.] +This is not immediately obvious from the syntax, but will be fleshed out +later. The point is that it is easy to tell the type of any identifier or, +in general, any Core expression. +\item[There is no shadowing.] +Identifiers may not be globally unique, +but there are no ``holes in the scope'' of any identifier. +\end{description} +All these properties should be maintained by programs which manipulate Core-langauge +programs. + +\section{Identifiers: the type @Id@} + +Identifiers have the (abstract) type @Id@. +\begin{description} +\item[Equality.] +Identifiers have a unique number inside them, +so they can be compared efficiently for equality. +They are an instance of the class @Eq@. +\item[Type.] +The function +\begin{verbatim} + getIdUniType :: Id -> UniType +\end{verbatim} + gets the type of an identifer. + \end{description} + + \section{Types: the type @UniType@} + + \subsection{@TyCon@} + + The type @TyCon@ ranges over {\em data} type constructors, + not over the function type constructor. + + A @TyCon@ can be one of: + \begin{itemize} + \item A primitive type. + \item A tuple type. + \item An algebraic data type (other than tuples). + \end{itemize} + + \section{The Core language data type} + + \subsection{@coreExpr@} + +Tycon in @case@. + +\subsection{@coreBinding@} + +\subsection{@coreProgram@} + +\subsection{@plainCore@ things} + + + +\end{document} diff --git a/ghc/docs/NOTES.desugar b/ghc/docs/NOTES.desugar new file mode 100644 index 0000000..b9e6ce7 --- /dev/null +++ b/ghc/docs/NOTES.desugar @@ -0,0 +1,323 @@ +(91/08/08: OLD!) + +These are notes about a _simple_ but complete pattern-matching +compiler for Haskell. I presume familiarity with Phil's +pattern-matching stuff in Simon's book and use roughly the same notation. + +Abbreviations: "p" for pattern, "e" (or "E") for expression, "g" for +guard, "v" for variable, "u" for new variable I made up. "[]" for +FATBAR. + +Subscripts: "p11" is really short for "p_{1,1}". Sometimes I'll use +a "?", as in "pm1 ... pm?", to mean the second subscript goes up to +something I'm really not worried about. + +NB: LETRECS NOT DEALT WITH YET. + +--------------------------------------------------------------------- +We need a slightly souped-up "match" for Haskell (vs the Phil-chapter +one). Simon suggested a re-arrangement of things, which I have then +further re-arranged... + +Proposal (Simon) +~~~~~~~~ + +Eliminate default arg of match (3rd arg in Phil-chapter match) in +favour of returning the variable (not special value) fail. Thus a +possible translation for + + f [] [] = e1 + f x y = e2 + +would be + + f p q = case p of + [] -> case q of + [] -> e1 + _ -> fail + _ -> fail + where + fail = e2 + +Now the issue of whether to duplicate code or share it becomes whether +to substitute copies of e2 or not. This is a decision we need to take +anyway for all other let-bound things, so why not for fail too? If +fail is used only once, we will certainly substitute for it. + +We could even detect that fail is used only in a head position, so it +can be implemented as a stack-adjust then a jump. This might well +apply to other let-bound things too. + +Now here's a proposal for the "match" function. The main difference is + 1) no default argument + 2) [contra simon's suggestion] Patterns are still per-row as in + Phil's chapter. + 3) [partain] even the input exprs are CoreExprs + +OK, for a "match" for m equations each with n patterns: + +match :: [Name] + -- n (variable) names, one per pattern column, bound + -- to the n expressions we are matching against the + -- patterns + + -> [([Pat], CoreExpr)] + -- one pair for each of the m equations: the n + -- patterns in that equation, then the CoreExpr that + -- is evaluated if we get a match. The CoreExpr may + -- contain free "fail"s; some hackery required to + -- ensure that is OK; see below + + -> CoreExpr + -- the resulting code to do the matching + +In words, + takes + (1) a list of n (match-expression, pattern-column) pairs + (2) a list of m post-match expressions, expr i to be inserted + immediately after equation i's lhs matches + returns + (1) a desugared expr equivalent of the whole "match" + +Meaning +~~~~~~~ + match [u1, ..., un] + [([p11, ..., p1n], e1), ..., ([pm1, ..., pmn], em)] + + match [ (e1, [p11, ...,pm1]), ..., (en, [p1n, ...,pmn])] + [ E1, ... Em ] + + ********* MEANS ********* + + case (u1, ..., un) of + (p11, ..., p1n) -> e1 + _ -> fail + where + fail = case (u1, ..., un) of + (p21, ..., p2n) -> e2 + _ -> fail + ... and so on ... + +Alternatively, this specification could be given in terms of +pattern-matching lambdas, as in Phil's chapter. + +NOT CHANGED BEYOND HERE + +------------------------------------------------------------------- +Cranking through a good old function definition with the above: + + f p11 p12 ... p1n | g11 = e11 + | g12 = e12 + ... + | g1? = e1? + ... + f pm1 pm2 ... pmn | gm1 = em1 + ... + | gm? = em? + +The "match" equivalent is: + +f = \u1.\u2...\un -> + match [ (u1, [p11, ...,pm1]), ..., (un, [p1n, ...,pmn])] + [ E1, ..., Em ] + where fail = error "pattern-match for f failed\n" + E1 = if g11 then e11 else if g12 then ... else fail + ... + Em = if gm1 then em1 else if gm2 then ... else fail + +Boring, huh? + +------------------------------------------------------------------- +It is helpful to me to think about the simple/base cases for this +complicated "match". + +ALL LISTS EMPTY + + match [] [] + + corresponds to the syntactically bogus (zero equations!?) + + case () of + () -> {- nothing!! -} + _ -> fail + + +EMPTY RULE -- no more patterns + + match [] [ ([], E1), ..., ([], Em) ] + + [where, incidentally, each Ei will be of the form + (not that it has to be...) + + Ei = let x1 = e1 in + let x2 = e2 in + ... + let x? = e? in + if g1 then e'1 + else if g2 then + ... + else if g? then e'? + else fail + ] + + becomes ("E1 [] E2 [] ... [] Em" in Phil's chapter...) + + E1 + where + fail = E2 + where + ... + fail = Em-1 + where fail = Em + + with any "fail" in Em being bound from an outer scope; perhaps it's + easier to see written as: + + let fail = Em + in let fail = Em-1 + in ... + let fail = E2 in E1 +------------------------------------------------------------------- +HANDLING LAZY ("TWIDDLE") PATTERNS + +For Haskell, the "mixture rule" (p.~88) looks at a pattern-column and +splits the equations into groups, depending on whether it sees + + * all constructors, or + * all variables _OR LAZY PATTERNS_ + +The following example shows what "match" does when confronted by one +of these variables/lazy-patterns combinations. Note the use of the +binding lists. + + f v | g11 = e11 + ... + | g1? = e1? + f ~p | g21 = e21 + ... + | g2? = e2? + +is + + f = \ u1 -> + match [(u1, [ v, ~p ])] + [ if g11 then e11 else if ... else fail, -- E1 + if g21 then e21 else if ... else fail -- E2 + ] + where fail = error "no match in f\n" + +which transmogrifies into + + f = \ u1 -> + let u2 = u1 in + match [] + [ -- E1 -- + let v = u2 + in + if g11 then e11 else if ... else fail + + ,-- E2 -- + let free_var1_of_p = match [(u2, [ p ])] [ free_var1_of_p ] + ... + free_var?_of_p = match [(u2, [ p ])] [ free_var?_of_p ] + in + if g21 then e21 else if ... else fail -- E2 + + ] + where fail = error "no match in f\n" + +For more specific match-failure error messages, one could insert +"let fail = ..."'s in strategic places. + +------------------------------------------------------------------- +"match" EQUIVALENTS FOR VARIOUS HASKELL CONSTRUCTS + +* function definition -- shown above + +* pattern-matching lambda (souped up version in static semantics) + + \ p1 p2 ... pn | g1 -> e1 + | g2 -> e2 + ... + | gm -> em + + is the same as + + \ u1.\u2 ... \un -> + match [ (u1, [p1]), ..., (un, [pn])] + [ if g1 then e1 else if ... then em else fail + ] + where fail = error "no match in pattern-matching lambda at line 293\n" + +* pattern-matching (simple, non-recursive) "let" + + let p = e + in E + + corresponds to + + case e of + ~p -> E + + which has a "match" equivalent of + + match [(e, [~p])] [ E ] + + The full-blown Haskell "let" is more horrible: + + let p | g1 = e1 + ... + | gn = en + in E + + corresponds to + + case ( if g1 then e1 else... else if gn then en else error "?" ) of + ~p -> E + + thinking about which I am not able to sleep well at night. + (Won't those g's have things bound from inside p ?) + +* pattern-matching (not-quite-so simple, non-recursive) "let" + + + +* pattern binding + + p | g1 = e1 + | g2 = e2 + ... + | gm = em + + That's the same as + + p = if g1 then e1 else if ... else if gm then em else fail + where fail = "...some appropriate thing..." + + which corresponds to + + match [ (if g1 ... then em else fail, [ ~p ]) ] + [ {-nothing-} ] + where fail = "...some appropriate thing..." + +* "case" expressions (souped up version in static semantics) + + case e0 of + p1 | g11 -> e11 + ... + | g1? -> e1? + ... + pm | gm1 -> em1 + ... + | gm? -> em? + + is the same as + + match [ (e0, [p1, ..., pm]) ] + [ if g11 then e11 else if ... else fail -- E1 + , ... , + if gm1 then em1 else if ... else fail + ] + where fail = error "pattern-matching case at line xxx failed\n" + +* list comprehensions diff --git a/ghc/docs/NOTES.garbage.collection b/ghc/docs/NOTES.garbage.collection new file mode 100644 index 0000000..3260df1 --- /dev/null +++ b/ghc/docs/NOTES.garbage.collection @@ -0,0 +1,206 @@ + + GARBAGE COLLECTION + ~~~~~~~~~~~~~~~~~~ + +The following discussion outlines how the GC is organised and what C +the compiler needs to produce to use it. + +The files associated with GC are: + + StgGC.h header file -- macros and externs + StgCreate.lc GC init routines + StgOverflow.lhc Overflow routines -- interface to GC + GC2s.lhc } + GC1s.lhc } GC control routines + GCdm.lhc } for each particular GC + GCap.lhc } + GCevac.lc Evacuation code fragments (copying GC) + GCscav.lhc Scavenging code fragments (copying GC) + GCcompact.lhc Inplace Compacting GC code fragments + GCmark.lhc Marking code fragments + +Other files: + + In gctest/ + gctest.c GC Small detail test bed program + + In gcstat/ + Performance evaluation stuff + + +Basic Requirements of the C code Produced by the Haskell Compiler +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are two main aspects of the compiler generated code that +interact with GC: + +1) Compiled haskell code calls the garbage collection routine when the + heap overflows by entering the appropriate _HEAP_OVERFLOW_... routine. + + These routines isolate register usage and calls the GC control + routine that was defined at compile time. + + For a description of the heap overflow conventions see: + + ~grasp/ghc/compiler/absCSyn/RTSLabels.lhs + + + The following must be adhered to by the mutator: + + REQUIREMENT COLLECTOR + SpA and SpB point to A and B stacks all + + Hp must point to last word allocated dual,comp + All updated closures must "know" their original dual,comp + size + + HpLim must point to one beyond top of root stack appel + Updated closures in the old generation must "know" appel + their original size + + The GC Control routines have to know about the pointer stack and + Update Stack. + +2) The info tables that are pointed to by closures must have the + appropriate GC routines within them. This is achieved by using the + following C Macros to declare them: + + table_name -- the name given to the info table + entry_code -- the name of the normal evaluation + entry code required for the closure + size -- the No of free var words in the closure + ptrs -- the number of pointers in the closure + + + SPEC_INFO_TABLE(table_name,entry_code,size,ptrs); + + Declares an info table with specialiazed code fragments + These are currently available for the following closure + configurations: size, ptrs + 1,0 2,0 3,0 4,0 5,0 + 1,1 2,1 3,1 + 2,2 + 3,3 + 4,4 + 5,5 + ... + 11,11 + + GEN_INFO_TABLE(table_name,entry_code,size,ptrs); + + Declares an info table that uses generic code fragments and + places data to drive these routines in the info table. + These are available for all combinations of size,ptrs (even + those for which SPEC routines are provided). + + + STATIC_INFO_TABLE(table_name,entry_code); + + Declares an info table suitable for a static closure. + + + DATA_INFO_TABLE(table_name,entry_code); + + Declares an info table suitable for a data closure. + This closure contains no heap pointers and its size + (of data and size field) in its first word + + See NOTES.arbitary-ints + + + IND_INFO_TABLE(table_name,ind_code); + + Declares an info table suitable for an indirection. + But see below !! (ToDo) + + +Using a Particular Garbage Collection Scheme +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When deciding which collector to use there are two decision points. + +At compile time it must be decided which code fragments are going to +be attached to closures. This will limit the possible choice of GC +schemes at run time. + +To compile the GC code and compiler-produced C Code for a particular +set of code fragments an appropriate define (-D) directive is given +to the compiler. + +Possible directives are: + + Code Fragments GC Control Routines + +-DGC2s Copying Two Space Collection + +-DGC1s Marking & Compacting Inplace Compaction + +-DGCdm Copying, Marking DualMode Collection + & Compaction (+ TwoSpace and Compaction) +-DGCap Copying, Marking Appels Collector + & Compaction (+ Compaction) + +If none of these are defined the result will be No Collection Schame. +Heap will be allocated but the program will die if it is ever filled. + +Other Directives: + +-D_GC_DEBUG Provides detailed GC debugging trace output + (if showGCTrace set) + +Note that the GC code will eventually be set up already compiled for +the different schemes and all that will be required will be to link +with the appropriate object files. The compiler produced C will still +need to be compiled with the appropriate define. + + +Trace and Statistics Info +~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a couple of variables that can be set to provide info about +GC. + +showGCTrace -- Provides detailed trace of GC and closure movement + TRUE -- Summary about GC invokation and heap location + & 2 -- Detailed trace of copying AND compacting collection + & 4 -- More detail about linked location lists during compaction + & 8 -- Detalied info about marking + + The & options are only available if compiled with -D_GC_DEBUG + +showGCStats -- Provides summary statistics about GC performance + (ToDo) + +ToDo: These should eventually be able to be set by runtime flages + + +Compiler Extensions Required for Compacting Collection +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of additional requirements required of the STG +machine and the resulting C code for Inplace Compaction to work. + +The most important and awkward arises from the fact that updated nodes +will be scanned. This requires updated nodes (blackholes, indirections +or inplace updates) to know how big the original closure was (so the +location of the next closure can be determined). + +Implications (Suggestions -- Still to be done): + + Need specialized black holes info pointers which know their size. + + Code on the Update Stack needs to know the orig closure size. Either + record this size or have specialised update code fragments. + + Updated closures need to know orig size. Possible solns are: + + Create dummy garbage closures at the end to fill the hole. + + Store size of closure in free space beyond and have GC + routines which look here for the size. + + Specialised indirections that know their size. + + May be able to search beyond the end of the closure for the next + info pointer. Possibly blanking out the unused portion of the + closure. diff --git a/ghc/docs/NOTES.import b/ghc/docs/NOTES.import new file mode 100644 index 0000000..30e65c4 --- /dev/null +++ b/ghc/docs/NOTES.import @@ -0,0 +1,90 @@ + Notes on imports + ~~~~~~~~~~~~~~~~ + SLPJ 15 March 91 + + +Distinguish three kinds of things in interfaces: + + - type, data, class, instance, value decls at top level + + - the same but imported. Syntax + import B renaming C to D where + data C = ... + + - imports, which serve just to attach original names + import B(X,Y) + + +The third group are syntactically stuck at the beginning; the second two +can be intermingled. + +Pass 1 +~~~~~~ +Process each imported interface, and the implementation being compiled, +scanning *headers of* + + type, data and class decls (incl imported ones in interfaces) + +giving the following environments for each + + type/data info {(ModStr,TyConStr) -> arity} + class info {(ModStr,ClassStr)} + +These are filtered (*but not renamed*) by the imports specified in the +impl (ignore dotdot parts and parts in parens), to give a grand +environment E1 of the same shape. It gives the original names of in-scope +types and classes. + +Pass 2 +~~~~~~ +Process each imported interface and the implementation being compiled: + + - scan its imports and use them to filter and rename E1, to give + + {TyConStr -> arity} + {ClassStr} + + - scan type, data, class decls, headers of instance decls + and value type sigs in interfaces + +giving for each: + + class info (CE) {ClassStr -> (ClassId, [ClassOpStr])} + inst info (GIE) {(ClassId,TyConId) -> (Context, GlobalId)} + (info from both class and instance decls) + + type/data info (TCE) {TyConStr -> (TyConId, [ConstrStr])} + + + value info (GVE) {ValStr -> GlobalId} + (info from value sigs, and constructors from data decls) + +Filter and rename the environments gotten from each import to make a grand +environment E2. + +Pass 3 +~~~~~~ +Check E2 for class cycles, and type synonym cycles. + +Pass 4 +~~~~~~ +Process the value decls in the impl, giving {ValStr -> GlobalId}, and some +code. + +Pass 5 +~~~~~~ +Process the bodies of instance decls, to generate code for methods. + + + + + + + UNRESOLVED + ~~~~~~~~~~ +1. Who generates the interface? + +2. Where is dependency analysis done? + + + diff --git a/ghc/docs/NOTES.interface b/ghc/docs/NOTES.interface new file mode 100644 index 0000000..dfe2d61 --- /dev/null +++ b/ghc/docs/NOTES.interface @@ -0,0 +1,54 @@ + +What gets done when printing an interface +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Basically, we do three things: + +A) Create the import decls. For classes and values, this is easy. We + filter the CE and GVE for all exported objects that were not declared + in the module. For types, this is a pain because we may have something + which is exported and which refers to a type that isn't. For example, + the interface + interface C where + ... + f :: A -> B + may export B, but A may be expected to come from somewhere else when + C is imported. So, we have to go through all envs which have ranges that + may refer to a type. This means the TCE, CE (the class op types), + GIE_inst (instance types) and GVE (types in the sigs). AND we have to + filter out prelude defined types from the resulting list. + + Finally, we print the import decls, using the conventions that the renamer + expects (no explicit constructors/ class ops, etc.) + +B) Print the fixity decls for whatever constructors/ functions are exported + +C) Print the rest of the decls needed. + 1) Type decls - contents of TCE with export flags + 2) Class decls - contents of CE with export flags + 3) Instance decls - contents of GIE_inst that refer to either + an exported type or an exported class + (filter then print) + 4) Value decls - contents of GVE which are not constructors and + which have an export flag + +Issues +~~~~~~ + +Type synonyms - to expand or not? Let's not, and complain if a type sig. is + used but not defined + +Canonical form for interfaces - to get rid of perl post-processing! + +Deriving for an abstract data type - shall we worry about this now or later? + +Printing issues +~~~~~~~~~~~~~~~ + +It's convenient to make all ranges of environments know how to print themselves +(they do now) and decide whether to do so by looking at the export flag +in their Name fields. Presumably the constructors of a data type that is +exported abstractly will decide not to print themselves, so no special code +is needed. + + diff --git a/ghc/docs/NOTES.mkworld2 b/ghc/docs/NOTES.mkworld2 new file mode 100644 index 0000000..3969d82 --- /dev/null +++ b/ghc/docs/NOTES.mkworld2 @@ -0,0 +1,48 @@ +Include order: + +# platform info +# discrim on "trigger" symbols in plat-TRIGGER.jm +# then slurp in plat-.jm +# *-GEN has defaults [if any] + +plat-TRIGGER.jm +plat-.jm +plat-GEN.jm + +# site overrides + +site--.jm +site-.jm +site-GEN.jm + +# s just for a and its various s + +--.jm +-.jm + +# things that many projects are likely to use + +-GEN.jm + +# finally, the directory-specific stuff + +Jmakefile + +------------------------------------------------------------------- +must specify platform explicitly +setup "std", project "none": nothing included + +------------------------------------------------------------------- + that we have files for: + +rules: macros related to the main "make" targets + excpt suffix, everything to make "make" do something is here + org by principal make target (all, install, etc.) + +suffix: things to do w/ make suffix rules (i.e., implicit rules) + +utils: utilities that are used in the build process + (where they are & default options for them) + (proj file must say which sysutils it wants) + (the proj files say whether src with or not ==> INeedXXX) +install: where things are installed, flags for installing diff --git a/ghc/docs/NOTES.part-of-book b/ghc/docs/NOTES.part-of-book new file mode 100644 index 0000000..551dd94 --- /dev/null +++ b/ghc/docs/NOTES.part-of-book @@ -0,0 +1,73 @@ +E.g., for the typechecker sources of the compiler. + +% cd compiler/typechecker/ + +* make a Jmakefile that is NOT plugged into the overall make-world + system; it will probably look like this: + +------------------------------ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +LitDocRootTargetWithNamedOutput(root,lit,root-standalone) +------------------------------ + +* make a "root file", root.lit, to glue the modules together. + + At the beginning you'll have something like: + + \begin{onlystandalone} + \documentstyle[11pt,literate,a4wide]{article} + \begin{document} + \title{The Glasgow \Haskell{} typechecker} + \author{The GRASP team} + \date{October 1991} + \maketitle + \tableofcontents + \end{onlystandalone} + + \begin{onlypartofdoc} + \section[Typechecker]{The typechecker} + \downsection + \end{onlypartofdoc} + + At the end of the file, you'll need something like: + + \begin{onlypartofdoc} + \upsection + \end{onlypartofdoc} + + \begin{onlystandalone} + \printindex + \end{document} + \end{onlystandalone} + + In between, simply \input all the modules, possibly adding some + sectioning hierarchy: + + \section[Typechecker-core]{Typechecking the abstract syntax} + \downsection + \input{XXXXXXX.lhs} + \input{YYYYYYY.lhs} + \upsection + + \section[Typechecker-support]{Typechecker: supporting modules} + \downsection + \input{AAAAAAAAAAA.lhs} + \input{BBBBBBBBBBB.lhs} + \upsection + +* To make your Makefile, do: + + % jmkmf -P ghc + + (because of a bug, you may have to do it twice :-) + +* Then do "make depend". + +* Now you are ready for business: + + % make root.info + + or + + % make root.dvi diff --git a/ghc/docs/NOTES.rename b/ghc/docs/NOTES.rename new file mode 100644 index 0000000..cca2932 --- /dev/null +++ b/ghc/docs/NOTES.rename @@ -0,0 +1,109 @@ + + + +Questions concerning the meaning of hiding in certain contexts: + +1) Suppose we have the interface + interface A where + data T = B | C + + and the module + module H where + import A hiding T + + Should this be an error (because T isn't an abstract type in the module) + or does it just mean the same thing as would + import A hiding (T (B,C)) + or + import A hiding (T (..)) + (in other words, hide all of T) + Will require the user to be precise and flag it as an error - otherwise + the user may not know that the type is not abstract, thinking that it is. + +2) Clearly, we can't allow (assuming the interface above) + module H where + import A hiding (T (B)) + + since that means that a data type with a subset of the constructors is + exported - similarly for classes + +3) Suppose an interface exports an abstract type H. Can H be referred + to as H (..), or is that an error? Let's require precision and call it + an error. + +--------------- new design for renamer ------------------- + +Changes to abstract syntax + +1) ClsSigs becomes Sigs + +2) Instances need new syntax (bool) distinguishing between those which +come from an interface and those which come from a module. + +The renamer is factored into four passes, as follows: + +1) FLATTEN INTERFACES - + insert original names into interfaces. All of the decls imported + from the interfaces are collected and returned, in an otherwise + unchanged module. No interfaces exist after this pass. + +2) Do consistency checks (equality). Return the module including the surviving declarations. + +3) build the global name function, which will maintain two separate + namespaces. + +4) assign names to the entire module, and do dependency analysis. + +As the prelude environments will yield names, the first pass will replace +QuickStrings with constructors of the ProtoName type, defined as + +data ProtoName = Unknown QuickString + -- note that this is the name local to the module + | Imported QuickString QuickString QuickString + | Prelude Name + +The parser will initially make all QuickStrings Unknown. + +Modules must now include signatures for value decls at top level. + +The entire set of passes have the following types: + +type PrelNameFuns = (GlobalNameFun, GlobalNameFun) + +type GlobalNameFun = ProtoName -> Maybe Name + +renameModule :: PrelNameFuns -> ProtoNameModule -> RenameMonad RenamedModule + +renameModule1 :: PrelNameFuns -> ProtoNameModule -> RenameMonad ProtoNameModule + +processModImports1 :: PrelNameFuns -> ProtoNameImportDecls + -> RenameMonad (ProtoNameFixityDecls, ProtoNameTyDecls, + ProtoNameClassDecls, ProtoNameInstDecls, + ProtoNameSigDecls) + +renameModule2 :: ProtoNameModule -> RenameMonad ProtoNameModule + +renameModule3 :: PrelNameFuns -> ProtoNameModule -> GlobalNameFun + +renameModule4 :: GlobalNameFun -> ProtoNameModule -> RenameMonad RenamedModule + +renameModule :: PrelNameFuns -> ProtoNameModule -> RenameMonad RenamedModule +renameModule pnf mod + = (renameModule1 pnf mod) `thenRenameM` (\ mod_with_orig_interfaces -> + (renameModule2 mod_with_orig_interfaces) + `thenRenameM` (\ mod_minus_interfaces -> + (renameModule3 pnf mod_minus_interfaces) + `thenRenameM` (\ global_name_fun -> + (renameModule4 mod_minus_interfaces global_name_fun)))) + +Namespace confusion: According to the report (1.1), `An identifier must +not be used as the name of a type constructor and a class in the same +scope.' This is apparently the only constraint on the namespace, other +than those implied by the conventions for identifiers. So, what are the +namespaces? + +1) variables and class operations, constructors + +2) type constructors and classes (because of the statement above) + + diff --git a/ghc/docs/NOTES.saving-space b/ghc/docs/NOTES.saving-space new file mode 100644 index 0000000..cd43c37 --- /dev/null +++ b/ghc/docs/NOTES.saving-space @@ -0,0 +1,250 @@ +Ways to save code space +~~~~~~~~~~~~~~~~~~~~~~~ +SLPJ/BOS 16 Sept 94 + + + + + +Heap entry points +~~~~~~~~~~~~~~~~~ +We have lots of thunks of the form + + let + x = f p q r + in ... + +where f is know function of arity 3 (ie saturated). +At the moment we generate special code for this one closure, +which: + pushes an update frame + loads p,q,r into registers from the closure (or using + immediate loads if they are literals), + jumps to f_fast. + +Since there are quite a lot of thunks of this form, the idea is to +generate some code (and its info table) just once, *with the +definition of f*, which does exactly as described above. We can then +use this code for every thunk of (exactly) this form. Call this +the "heap entry" for f: + + slow entry: args on stack + fast entry: args in regs + heap entry: args in closure pointed to by Node + +So the thunk for x would look like this: + + ----------------- + x = | * | p | q | r | + --|-------------- + | + | common heap entry code for f + ------> push update frame + R2 := R1[2] -- Second arg + R3 := R1[3] -- Third arg + R1 := R1[1] -- First arg + goto f_fast + +The jump to f_fast can be implemented as a fall-through. (The +slow entry point can take a jump instead!) + +Of course there are also lots of thunks which *aren't* of the heap-entry +form: + x = case y of ... + x = let v = ... in ... + etc + +Things to watch out for: + +* Literal args. Consider + + x = f 2 p 4 + +We don't *have* to use the heap entry for f (we could generate special +code+info table as we do now), but we *can* use it provided we +generate a thunk with 2 and 4 stored in it as well as p: + + ----------------- + | * | 2 | p | 4 | + --|-------------- + | + | common heap entry code for f + ------> push update frame + R2 := R1[2] -- Second arg + R3 := R1[3] -- Third arg + R1 := R1[1] -- First arg + goto f_fast + +(If we have special code the thunk needs only p stored in it, because +the special code can use immediate constants for 2 and 4: + + --------- + | * | p | + --|------ + | + | special code for x + ----> push update frame + R2 := R1[1] -- Second arg + R3 := 4 -- Third arg + R1 := 2 -- First arg + goto f_fast + + +* Single-entry thunks. If x is a single-entry thunk, there's no need to +push an update frame. That suggests: + + --------------- + x = | * | 2 | p 4 | + --|------------ + | + | heap entry code for f + ----> -- NO! NO! push update frame + R2 := R1[2] -- Second arg + R3 := R1[3] -- Third arg + R1 := R1[1] -- First arg + goto f_fast + +Let's call the two variants the + standard heap entry +and no-update heap entry + +We can't fall through from the standard heap-entry code (which pushes +an update frame) to the arg-loading code, because both need an info table. +We have to take a jump. + +For non-exported functions we may be able to see that only one of the +two heap entries is required. + +* Local functions. When f is a *local* (ie not top-level) function, its +fast-entry convention is that + R1 = the function closure + R2.. = the args + +For example: + + top p q = let + f = \r -> ..r..p...q... + in + let + x = f q + in + ... + + +The shape of the heap-entry closure for f must be + + ------------- + x = | * | f | q | + --|---------- + | + -------> heap entry code + must load *f* into R1 as well as q and + the other args + + + + + +Avoiding generating entries and info tables +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At present, for every function we generate all of the following, +just in case. But they aren't always all needed, as noted below: + +[NB: all of this applies only to *functions*. Thunks always +have closure, info table, and entry code.] + + +* Fast-entry code ALWAYS NEEDED + +* Slow-entry code + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + +* The function closure + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) if the function has free vars (ie top level) + + Why case (a) here? Because if the arg-satis check fails, + UpdatePAP stuffs a pointer to the function closure in the PAP. + [Could be changed; UpdatePAP could stuff in a code ptr instead, + but doesn't seem worth it.] + + [NB: these conditions imply that we might need the closure + without the slow-entry code. Here's how. + + f x y = let g w = ...x..y..w... + in + ...(g t)... + + Here we need a closure for g which contains x and y, + but since the calls are all saturated we just jump to the + fast entry point for g, with R1 pointing to the closure for g.] + + +* Slow-entry info table + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) the function has free vars (ie top level) + + NB. (c) is only required so that the function closure has + an info table to point to, to keep the storage manager happy. + If (c) alone is true we could fake up an info table by choosing + one of a standard family of info tables, whose entry code just + bombs out. + + If (c) is retained, then we'll sometimes generate an info table + (for storage mgr purposes) without slow-entry code. Then we need + to use an error label in the info table to substitute for the absent + slow entry code. + +* Standard heap-entry code + Standard heap-entry info table + Needed iff we have any updatable thunks of the standard heap-entry shape. + +* Single-update heap-entry code + Single-update heap-entry info table + Needed iff we have any non-updatable thunks of the + standard heap-entry shape. + + +All are needed if the function is exported, just to play safe. + +Idea: generate just the stuff we need! + + + +\begin{code} +staticClosureRequired -- Assumption: it's a top-level, no-free-var binding + :: StgBinderInfo + -> [Id] -- Args + -> Bool +staticClosureRequired (StgBinderInfo arg_occ unsat_occ _ _) args + = arg_occ || -- There's an argument occurrence + unsat_occ || -- There's an unsaturated call + null args -- It's a thunk + +staticClosureRequired NoStgBinderInfo args = True + + + +slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk. + :: StgBinderInfo + -> Bool +slowFunEntryCodeRequired (StgBinderInfo arg_occ unsat_occ _ _) + = arg_occ || -- There's an argument occurrence + unsat_occ -- There's an unsaturated call +slowFunEntryCodeRequired NoStgBinderInfo = True + + +funInfoTableRequired -- Assumption: it's a function, not a thunk. + :: Bool -- Top level? + -> StgBinderInfo + -> Bool +funInfoTableRequired top_level (StgBinderInfo arg_occ unsat_occ _ _) + = not top_level || + arg_occ || -- There's an argument occurrence + unsat_occ -- There's an unsaturated call + +funInfoTableRequired top_level NoStgBinderInfo = True +\end{code} diff --git a/ghc/docs/NOTES.update-mechanism b/ghc/docs/NOTES.update-mechanism new file mode 100644 index 0000000..5072cd8 --- /dev/null +++ b/ghc/docs/NOTES.update-mechanism @@ -0,0 +1,195 @@ + The Glorious New Update Mechanism + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Simon & Jim Dec 93 + +Return convention +~~~~~~~~~~~~~~~~~ +When a constructor returns it makes sure that + + R2 contains the info pointer for the constructor + R1,R3.. contain the components (if return in regs) + R1 points to the constructor object itself (if return in heap) + +The info table for a constructor contains a pointer to the +constructor's update code. If a constructor returns to an +update frame, the update frame's code just jumps direct to the +constructor's update code, via the info pointer in R2. + +This penalises slightly the return of a new constructor, +because we have to load R2 with the info ptr. [Fact: in runs +of the compiler, 20-30% of all returns are of a new constructor; +70-80% are existing constructors.] + +Info tables +~~~~~~~~~~~ +Each dynamic-heap-allocated constructor has *two* info tables: + +* the "NewCon" info table is put into R2 when returning a new + constructor, which does not yet exist in the heap; R1 is dead! + The "NewCon" info table has no GC entries, because it's only ever used + when returning in regs, never installed in a real constructor. + + The NewCon table also needs a valid tag field (see taggery below) + +* the "ExistingCon" info table is used for all constructors allocated + in the heap. + +The update code for a constructor +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The update code for a constructor actually performs the update +right away. [At present, the update is deferred until we get +back to the case expression.] It knows how to do the update +because the update code is constructor-specific. + +Once it's done the update, it makes R1 point to the constructor object +in the heap (which'll either be freshly-allocated, if big, or the +updated thing itself), and (for non-niladic constructors) makes R2 point +to the "ExistingCon" info table for the constructor. (Of course the new +constructor will also have an ExistingCon info ptr.) For niladic +constructors, we do *not* use the "ExistingCon" info table. We continue +to overwrite updatees in-place, because this saves us an indirection +prior to garbage collection (and the extra niladic constructors disappear +during the next garbage collection anyway). + +The update code in the ExistingCon info table simply updates with an +indirection, using R1. I *think* this can be one standard piece of +code. The only doubt here concerns GC; if updating with an +indirection can cause GC (possible on GRIP? or generational GC?), +then we need to know which regs are live. We can solve this by +putting a liveness mask in the info table too. [Arguably we want +that anyway; consider returning to the bottom of a stack object.] +So a liveness mask in the info table is probably a good idea. + +Constructors which return in heap return with an ExistingCon info +ptr. They don't need a NewCon info table at all. + +Notice that this means that when we return an *existing* constructor, +to an update frame, the update is done with an indirection, rather +than [as now] copying the constructor afresh. This solves the space duplication +problem which shows up in "clausify". + +GC: R1 might be dead; R2 is a non-ptr. So this return convention +relies on using liveness masks for GC reg-liveness info, not the +old no-of-live-ptrs info. + +Taggery +~~~~~~~ + + [Current: For unvectored returns with more than one constructor, we + currently load TagReg, and scrutinise it in the case expression. + Worse, we also have to scrutinise TagReg in the update entry of the + return vector.] + +In the new world, updates are handled without any nonsense. No need +to look at any register, becase we just jump to the constructor +specific update code. + +Since we have an info ptr in R2, we can get the tag out of the info +table, thus getting rid of TagReg altogether. (This could conceivably +be a *lose* on a machine with lots of regs, because it replaces a +immediate small-const load by a memory fetch of the tag from the info +table. + +Not clear whether this is worth trying to improve. Could + + a) #define TagReg to be a register or an offset from R2 + b) issue a SET_TAG macro in the entry code for a constructor, + which usually expands to nothing + +[NB 75-95% of all returns are vectored in runs of the compiler itself.] + +The entry code for a constructor +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The real reason the registers are assigned as above is to make the +entry code for a constructor simple. When the entry code is executed, +we have a new entry convention: + + R1 points to the object + R2 is its info pointer + +(Why? because we usually enter it by indirecting through its info +table, so it seems a shame to load the info ptr from memory twice.) + +So all the entry code has to do is to return (perhaps vectored-ly). +(Maybe load TagReg, usually not --- see above.) + +NB this entry convention applies, of course, to all thunks as +well as constructors -- whenever we enter an unknown object via R1 (Node). + +Case expressions +~~~~~~~~~~~~~~~~ +Return vectors no longer need update code. + +Unvectored returns can therefore be *direct* to the code, +rather than *indirect* via a 2-entry vector. + +Penalty for this improvement: "polymorphic" return vectors, +notably that in an update frame, needs to accomodate either +a direct or a vectored return. So it has to look like: + + UpdVec: jmp UnvectoredUpd + .word UpdVec0 + .word UpdVec1 + ... + +that is, the return vector is offset by some fixed amount +from the pointer put on the stack. Or, it could be done +backwards: + + ... + .word UpdVec1 + .word UpdVec0 + UpdVec: ...code for UnvectoredUpd... + +and then vectored returns would use negative offsets. + +This grunge is necessary *only* for a fixed set of polymorphic return +vectors, part of the runtime system: + + - update frames + - restore cost centres + - seq, par + - thread base + - stack object base + +Case expressions generate either a direct return, or a vector, +but never a combination. + +Update Frames +~~~~~~~~~~~~~ + +Standard update frames are still required if we don't know the type of +the constructor being returned. However, we often do know the type. In +this case, we can generate a type-specific updating return-vector to place +in the update frame rather than the StdUpdRetVector. This saves us one +level of indirection. + +Partial applications +~~~~~~~~~~~~~~~~~~~~ +PAPs are basically handled just the same way as at present. + +Changes from now +~~~~~~~~~~~~~~~~ +* UpdReg dies. +* TagReg dies. +* RetVecReg dies. (Previously needed to do return after update.) +* Return vectors have half the number of entries. +* Unvectored returns go direct. +* Polymorphic seq/par and friends. +* No space duplication problem (cf clausify) + + +Glosses +~~~~~~~ +Tag and update code are needed only for constructor info tables. +It seems a shame to take up space in other info tables (ie 99% of them). + +Possibilities: + +- use an indirection to GC code, so the vari-sized gc stuff becomes + fixed +- put the tag/upd code ptrs before the start of the info table. (or + between the info table and code when reversing info tables...) + + +Looks tricky to me. diff --git a/ghc/docs/Prefix_Form b/ghc/docs/Prefix_Form new file mode 100644 index 0000000..43daaba --- /dev/null +++ b/ghc/docs/Prefix_Form @@ -0,0 +1,294 @@ + Haskell Prefix Form + =================== + +This defines the interface between the Haskell lexer/parser "hsp" +(written in lex/yacc/C) and the Haskell compiler proper, "hsc" +(written in Haskell). + +White space in the form of spaces, tabs and newlines may occur between +prefix items (I wouldn't recommend it [WDP]). A literal tab +terminates a string constant (and by extension also an integer +constant, character constant, identifier or infix operator). + +There is a general list form, where L indicates a Cons node and N +indicates Nil. Elements in a list may be of arbitrary type. + +KH, 22/08/91: Changed for Haskell 1.1+ -- this is where Haskell and LML + finally part company... + +JH, 09/07/92: {0,5,6,I,O,u,v,w} Used in Data Parallel Haskell variant + (Jonathan Hill, QMW) + +WDP, 02/04/93: Added full-blown pragmas. +WDP, 15/08/93: Added even more full-blown pragmas. + +`Tag' namespace already used: + +#$%()+,-.012356789:=>@ABCDEGILMNOPQRSTUWXZ_abcdefghijklmnopstuvwxyz~ + + Meta-Syntactic Items + -------------------- + +Lists (l) +--------- + +L el l List constructor el : l +N Null List [] + + +Strings (s) +----------- + +#chars String of characters before + + + + + Syntactic Items + --------------- + +Expressions or Patterns (e or p) +-------------------------------- + +M L s s b [op] [ix] [ei] + Haskell module: + (name, file, binding, fixities, imports, exports) + +4 s Integer Constant 0, 1, ... +H s Unboxed Integer constant 0#, 1#, ... /* WDP */ +F s Floating Point Constant 0.1, 0.2e-3, ... +J s Unboxed Double Constant 0.1##, 0.2e-3##, ... /* WDP */ +K s Unboxed Float Constant 0.1#, 0.2e-3#, ... /* WDP */ +C s Character Constant '...' +P s Unboxed character constant ???????? /* WDP */ +S s String Constant "..." +V s String# Constant "..."# /* WDP */ +Y s "Literal C" Constant ``printf'' /* WDP */ +I s "no rep" Integer (unfoldings) +R s s "no rep" Rational (numerator, denominator) +s s "no rep" String constant (unfoldings) + +i id Identifiers +C literal Literal constant + +a e1 e2 Function application (e1 e2) +@ e1 id e2 Infix Application e1 `op` e2 +( e id Left section (e op) +) id e Right Section (op e) + +l L [p] e Lambda Expressions \ p1 ... pn -> e +c e [pb] Case Expression case e of pb1 ... pbn +b e1 e2 e3 If expression if e1 then e2 else e3 +E b e Let Expression let b in e + +: [e] Explicit List [ e1, ..., en ] +Z e [q] List Comprehension [ e | q ] +. e1 [e2] [e3] Enumeration (e2/e3 may be []) [e1,e2..e3] + +, [e] Explicit Tuple ( e1, ..., en ) + +R e t Type Constraint e :: t + +- e Negation - e + +j id s [e] C Call/Asm (ccall/asm id/str e1 ... en) + s == "n" --> ccall, non-ptrs only + s == "p" --> ccall, ptrs allowed + s == "N" --> casm, non-ptrs only + s == "P" --> casm, ptrs allowed +k s e Set Cost Centre (scc s e) + +s id p As Pattern id @ p +~ p Irrefutable Pattern ~ p ++ p e Plus Pattern n + k + /*WDP: why a "p" on the plus pat? (KH: historical reasons) */ +_ Wildcard Pattern _ + + + +Qualifiers (q) +-------------- + +G p e Generator p <- e +g e Guard e + +Bindings (b) +------------ + +t L C [id] t [d] iprag DataType Binding data C => t = d1 | ... | dn + deriving (id1, ..., idm) +n L t1 t2 iprag Type Synonym type t1 = t2 +p L [pb] Pattern Binding pb1 ; ... ; pbn +f L [pb] Function Binding pb1 ; ... ; pbn +A b1 b2 Multiple Definitions b1 ; b2 +$ L C t b iprag Class class C => t [where b] +% L C id t b iprag Instance instance C => id t [where b] +D L [ty] Default default (ty1, ..., tyn) + +St L [id] t iprag Type Signature id1, ...., idn :: t +Ss L id [t] Pragma: value specialis'ns {-# SPECIALISE id :: t1, ... tn #-} +SS L id t Pragma: instance specialis'n {-# SPECIALISE instance id t #-} +Si L id [id] Pragma: inline -- id [howto] {-# INLINE id [id]{0,1} #-} +Su L id Pragma: magic unfolding {-# MAGIC_UNFOLDING id #-} +Sa L id Pragma: abstract synonym {-# ABSTRACT id #-} + +7 L id [ei] [rn] Import module (Interface only) import id (eis) renaming rn +B null binding + + +Fixity declarations (op) +-------------- +/* WDP: most suspicious how these don't appear in interfaces */ +/* WDP: need line numbers? */ + + s1 s2 s3 s1 is the operator name + s2 is either "infix", "infixl" or "infixr" + s3 is the precedence + +Types (t) +--------- + +T id [t] Type Constructor id t1 ... tn +: t Explicit List Type [t] +, [t] Explicit Tuple Type (t1, ..., tn) +> t1 t2 Explicit Function Type t1 -> t2 +y id Type Variable id +3 C t Type Context C => t + +2A id t "UniDict": class, type (core unfoldings only) +2B id "UniTyVarTemplate" +2C [id] t "UniForall" tv1 ... tvN => type + +2D Nothing (Maybe UniType) +2E t Just t (ditto) + +Contexts (C) +------------ + + [t] Haskell context: t1, ..., tn + + +Data Types (d) +-------------- + +1 L id [t] Data constructor id st1 ... stn + + +Pattern Bindings (pb) +--------------------- + +W L id p [ge] b Single grhs p | g1 = e1 ... where b + (L,id) = (Line,Function) + + +Guarded Expressions (ge) +------------------------ + + g e g | e (unguarded comes in with an + unsavoury (Var "_otherwise") `guard') + + +Identifiers (id) +---------------- + + s An identifier is just a string + + +Import declarations (ix) +------------------------ + +e L s id [ei] [rn] b Line, File Name, Module name, imported entities, + renamings, interface body +h L s id [ei] [rn] b Hiding clause, as above... + + +Renamings (rn) +-------------- + + id id From name, to name + + +Exported/Imported Identifers (ei) +--------------------------------- + +x id ExImport Variable +X id ExImport Constructor/Type/Class +z id ExImport Class/Type plus all ops/cons +8 id [id] ExImport Type(C1,..Cn) +9 id [id] ExImport Class(o1,..on) +m id Export Module + + +Interface pragmas (iprag) +------------------------- + + User pragmas come in as "signatures"; see Bindings. + +PN Null/empty pragma + +Pd [d] Data pragma: otherwise-hidden data constructors +Pt Type pragma: synonym is *abstract* +Pc [gprag] Class pragma: one gprag per superclass +Po gprag gprag Class op pragma: gprags for dsel & defm + OUT: Pv gprag [2prag] Value pragma: gprag + specialisations +Pis id gprag Instance pragma (simple): id is module name, gprag for dfun +Pic id gprag [1prag] Ditto (constant methods): also gprags for classops +PiS id gprag [3prag] Ditto (specialised): also (type, instance-prag) pairs + +Pg Aprag uprag Sprag Uprag + General ("gprag"): arity, update, strictness, unfolding + +PA id Arity ("Aprag"): arity +Pu id Update ("uprag"): update spec +PS id gprag Strictness ("Sprag"): strictness spec, gprag for worker +PM id id Magic unfolding ("Uprag"): var, magic-name string +PU id core Unfolding ("Uprag"): "guidance", corexpr-unfolding + +Px Unfold always (these are "guidance" ones...) +Py id id Unfold if applied to "m" ty args, "n" val args +Pz id id Unfold if applied to "m" ty args, & cons in marked val positions + (e.g., "CXXCXX" ==> in 1st & 4th arg positions) + +P1 id gprag ("1prag"): (name, gen-pragma) pair +P2 t gprag ("2prag"): (type, gen-pragma) pair +P3 t gprag [iprag] ("3prag"): (type, [(gen-pragma, instance-pragma)]) pair + + +Core syntax [in iprags] (core) +------------------------------ + +Fa +Fb + + +Used in Data Parallel Haskell variant (Jonathan Hill, QMW) +---------------------------------------------------------- + + ** Expressions ** + +5 e [parqual] Parallel ZF expression << e | [parquals] >> +6 [e] Pod Literal << e1,...,ek>> +O [e] e Processor (|e1,...,ek;e|) + + ** Types ** + +u [t] t Explicit Processor Type (|t1,..tn;t|) +v [t] Explicit Pod Type <> + + ** Parallel Qualifiers ** + +0 e e Drawn From Generator exp <<- exp +w e e Indexed From Generator exp <<= exp +I e Guard + + + Other Items + ----------- + +Line Numbers (L) +---------------- + + s Haskell line number + + +Kevin Hammond @ 22nd. August 1991 diff --git a/ghc/docs/README b/ghc/docs/README new file mode 100644 index 0000000..d9c06dd --- /dev/null +++ b/ghc/docs/README @@ -0,0 +1,71 @@ +Herein are bits of documentation for, or related to, the Glorious +Glasgow Haskell compilation system. Unless specified otherwise, they +are nestled in the ghc/docs directory of the distribution. + +== semi-proper documentation ========================================== + +install_guide/* + A step-by-step guide on how to configure, build, and install + the system. + +users_guide/* + The User's Guide for the system. Describes how to "drive" the + system, how to deal with common problems, how to use the + profiling tools, what is Known to be Broken, how to use the + Glasgow extensions, etc. + +release_notes/* + Release notes for the system. What's new in each release, and + what's coming Real Soon Now. + +io-1.3/* + The *draft* Haskell 1.3 I/O proposal at December 1994. In + HTML format. Unstructured.html gives you the whole thing in + one big wad. + +state-interface.dvi + "GHC prelude: types and operations", an addendum to the Peyton + Jones/Launchbury "state" paper, is the definitive reference + (bar the compiler source :-) of GHC's lowest-level interfaces + (primitive ops, etc.). + +add_to_compiler/paper.dvi + An overview of how to add a piece to the compiler. + +simple-monad.lhs + A *simple* introduction to the common use of monads in Haskell + programming. No fancy stuff whatsoever. By Will Partain. + +../../mkworld/docs/mkworld_guide/* + A guide to the ``make world'' configuration system ... ``for + the brave.'' The "configure" script (versions 0.22ff) make + this a little less visible than before. + +../../literate/doc/* + The documentation for the ``literate programming'' stuff, if + you're interested. + +== relevant papers and abstracts ====================================== + +Consult ghc/docs/abstracts/abstracts.tex for information about +Glasgow work related to the GHC system. Other relevant material is +listed here. All of it is available by FTP. + +Haskell report, version 1.2 (the latest) + It was in your May, 1992, SIGPLAN Notices. Not in the + distribution but in ~ftp/pub/haskell/report/ (the usual + places). + +Haskell tutorial, by Paul Hudak and Joe Fasel + Ditto. In ~ftp/pub/haskell/tutorial/; usual places. + +== notes and things =================================================== + +NOTES.* Random collections of notes on topics *. Check the + modification dates to see what's new... Don't believe + everything you read. + +MAIL* Files holding some relevant correspondence. + +README files + A few of these actually exist and tell the truth. diff --git a/ghc/docs/abstracts/README b/ghc/docs/abstracts/README new file mode 100644 index 0000000..a3c07a8 --- /dev/null +++ b/ghc/docs/abstracts/README @@ -0,0 +1,4 @@ +A straight copy of ~grasp/docs/abstracts/*.{tex,sty}. + +Will Partain +partain@dcs.glasgow.ac.uk diff --git a/ghc/docs/abstracts/abstracts.sty b/ghc/docs/abstracts/abstracts.sty new file mode 100644 index 0000000..0965be6 --- /dev/null +++ b/ghc/docs/abstracts/abstracts.sty @@ -0,0 +1,30 @@ +\newcounter{refnumber}[section] + +\renewcommand{\therefnumber}{\arabic{refnumber}} + +\newcommand{\reference}[4]{ % authors, title, details, abstract +\refstepcounter{refnumber} +\large +{\bf \therefnumber.} #1, {\em #2}, #3. +\normalsize +\begin{quote} +#4 +\end{quote} +\vspace{0.2in} +} + +\newcommand{\shortreference}[3]{ % authors, title, details +\large +$\bullet$ #1, {\em #2}, #3. +} + + +\newcommand{\GlasgowNinetyTwo}[1] + {Functional Programming, Glasgow 1992, Springer Verlag Workshops in Computing} +\newcommand{\GlasgowNinetyThree}[1] + {Glasgow Functional Programming Group Workshop, Ayr, July 1993} +\newcommand{\GlasgowNinetyOne} + {Functional Programming, Glasgow 1991, Springer Verlag Workshops in Computing} + +% \newcommand{\Haskell}[1]{{\sc Haskell}} + diff --git a/ghc/docs/abstracts/abstracts89.tex b/ghc/docs/abstracts/abstracts89.tex new file mode 100644 index 0000000..e4fe15e --- /dev/null +++ b/ghc/docs/abstracts/abstracts89.tex @@ -0,0 +1,487 @@ +\documentstyle[11pt,slpj]{article} + +\newcommand{\reference}[4]{ % authors, title, details, abstract +\large +#1, {\em #2}, #3. +\normalsize +\begin{quotation} +#4 +\end{quotation} +\vspace{0.2in} +} + +\newcommand{\Haskell}[1]{{\sc Haskell}} + +\begin{document} + +\title{Abstracts of GRIP/GRASP-related papers and reports till 1989\\ +Dept of Computing Science \\ +University of Glasgow G12 8QQ} + +\author{ +Cordelia Hall (cvh@cs.glasgow.ac.uk) \and +Kevin Hammond (kh@cs.glasgow.ac.uk) \and +Will Partain (partain@cs.glasgow.ac.uk) \and +Simon L Peyton Jones (simonpj@cs.glasgow.ac.uk) \and +Phil Wadler (wadler@cs.glasgow.ac.uk) +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP +and GRASP projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by writing to +Teresa Currie, Dept of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +teresa@uk.ac.glasgow.cs. + +Those marked ($\spadesuit$) can be obtained from the School of Information +Systems, University of East Anglia, Norwich, UK. +Those marked ($\clubsuit$) can be obtained from Chris Clack at the +Department of Computer Science, University College London, Gower St, +London WC1E 6BT, UK. +\end{abstract} + +\section{Published papers} + +\reference{Simon L Peyton Jones and Jon Salkild} +{The Spineless Tagless G-machine} +{Proc IFIP Symposium on Functional Programming Languages and Computer +Architecture, London, Sept 1989} +{ +The Spineless Tagless G-machine is an abstract machine based on graph +reduction, designed as a target for compilers for non-strict functional +languages. +As its name implies, it is a development of earlier work, especially +the G-machine and Tim. + +It has a number of unusual features: the abstract machine code is +rather higher-level than is common, allowing better code generation; +the representation of the graph eliminates most interpretive overheads; +vectored returns from data structures give fast case-analysis; +and the machine is readily extended for a parallel implementation. + +The resulting implementation runs at least 75\% faster +than the Chalmers G-machine. +} + +\reference{Simon L Peyton Jones} +{Parallel implementations of functional programming languages} +{Computer Journal 32(2), pp175-186, April 1989} +{ +It is now very nearly as easy to build a parallel computer +as to build a sequential one, and there are strong incentives to do so: +parallelism seems to offer the opportunity to improve both the +absolute performance level and the cost/performance ratio of our machines. + +One of the most attractive features of functional programming languages +is their suitability for programming such parallel computers. +This paper is devoted to a discussion of this claim. + +First of all, we discuss parallel functional programming +from the programmer's point of view. +Most parallel functional language implementations are based on graph reduction, +we proceed to a discussion of some implementation issues raised by parallel +graph reduction. +The paper concludes with a case study of a particular parallel graph reduction +machine, GRIP, and a brief survey of other similar machines. +} + +\reference{Kevin Hammond} +{Implementing Functional Languages for Parallel Machines} +{PhD thesis, University of East Anglia, 1989 ($\spadesuit$)} +{Commencing with the Standard ML language, dialects XSML and PSML are +defined, which permit parallel evaluation of functional programs. XSML +is Standard ML with a novel mechanism for handling exceptions; PSML is a +side-effect free version of XSML. A formal semantics for PSML and a +translation algorithm from this language into Dactl, a compiler target +language based on the theory of graph-rewriting, are presented. The +thesis proves that a simplified version of this translation preserves +meaning for flat domains, and that the strategy for reduction to normal +form is correct. + +The implementation of standard compilation techniques such as strictness +analysis, maximal free sub-expression elision and common sub-expresssion +elimination is considered with respect to Dactl, and problems +highlighted. Techniques are also presented for compiling +exception-handling correctly in a parallel environment, and for +compiling side-effect for a parallel machine. Metrics for performance +evaluation are presented and results obtained using the Dactl reference +interpreter are presented.} + + +\reference{Simon L Peyton Jones, Chris Clack and Jon Salkild} +{High-performance parallel graph reduction} +{Proc Parallel Architectures and Languages Europe (PARLE), LNCS 365, pp193-207, +July 1989} +{ +Parallel graph reduction is an attractive implementation for functional +programming languages because of its simplicity and inherently distributed +nature. +This paper outlines some of the issues raised by parallel compiled +graph reduction, and presents the solutions we have adopted to produce an +efficient implementation. + +We concentrate on two particular issues: +the efficient control of parallelism, resulting in an ability to alter +the granularity of parallelism +{\em dynamically}; +and the efficient use of the memory hierachy to improve locality. +} + +\reference +{Phil Trinder and Philip Wadler} +{Improving list comprehension database queries} +{{\em TENCON '89\/} (IEEE Region 10 Conference), +Bombay, India, November 1989.} +{ +The task of increasing the efficiency of database queries has recieved +considerable attention. In this paper we describe the improvement of +queries expressed as list comprehensions in a lazy functional +language. The database literature identifies four algebraic and two +implementation-based improvement strategies. For each strategy we show +an equivalent improvement for queries expressed as list +comprehensions. This means that well-developed database algorithms +that improve queries using several of these strategies can be emulated +to improve comprehension queries. We are also able to improve queries +which require greater power than that provided by the relational +algebra. Most of the improvements entail transforming a simple, +inefficient query into a more complex, but more efficient form. We +illustrate each improvement using examples drawn from the database +literature. +} + +\reference{Kevin Hammond} +{Exception Handling in a Parallel Functional Language: PSML} +{Proc TENCON '89, Bombay, India, Nov 1989} +{ +Handling exception occurrences during computation is a problem in most +functional programming languages, even when the computation is eager and +sequential. This paper presents a version of the error value method +which allows lazy computation with deterministic semantics for parallel +evaluation even in the presence of errors. The realisation of this +technique is illustrated by reference to PSML, a referentially +transparent variant of Standard ML designed for parallel evaluation. +} + +\reference +{Philip Wadler} +{Theorems for free!} +{{\em 4'th International Conference on Functional Programming +Languages and Computer Architecture}, London, September 1989.} +{ +From the type of a polymorphic function we can derive a theorem +that it satisfies. Every function of the same type satisfies the same +theorem. This provides a free source of useful theorems, +courtesy of Reynolds' abstraction theorem for the polymorphic lambda +calculus. +} + +\reference +{Philip Wadler and Stephen Blott} +{How to make {\em ad-hoc\/} polymorphism less {\em ad hoc}} +{{\em 16'th ACM Symposium on Principles of Programming Languages}, +Austin, Texas, January 1989.} +{ +This paper presents {\em type classes}, a new approach to {\em +ad-hoc\/} polymorphism. Type classes permit overloading of arithmetic +operators such as multiplication, and generalise the ``eqtype variables'' +of Standard ML. +Type classes extend the Hindley\X Milner polymorphic type system, and +provide a new approach to issues that arise in object-oriented +programming, bounded type quantification, and abstract data types. +This paper provides an informal introduction to type classes, and +defines them formally by means of type inference rules. +} + +\reference{Kevin Hammond} +{Implementing Type Classes for Haskell} +{Proc Glasgow Workshop on Functional Programming, Fraserburgh, Aug 1989} +{ +This paper describes the implementation of the type class mechanism for +the functional language Haskell, which has been undertaken at Glasgow +University. A simple introduction to type classes discusses the methods +used to select operators and dictionaries in the Glasgow Haskell +compiler. A solution to the problem of selecting super-class +dictionaries, not considered by the original paper on type class, is +also presented. The modifications which must be made to the standard +Hindley/Milner type-checking algorithm to permit the translation of +operators are described, and a revised definition of algorithm W is +provided. Finally, a set of performance figures compares the run-time +efficiency of Haskell and LML programs, indicating the overhead inherent +in the original, naive method of operator selection, and the improvement +which may be obtained through simple optimisations. +} + +\reference{Simon L Peyton Jones} +{FLIC - a functional language intermediate code} +{SIGPLAN Notices 23(8) 1988, revised 1989} +{ +FLIC is a Functional Language Intermediate Code, intended to +provide a common intermediate language between diverse +implementations of functional languages, including parallel +ones. +This paper gives a formal definition of FLIC's syntax and +semantics, in the hope that its existence may encourage greater +exchange of programs and benchmarks between research groups. +} + +\reference{Simon L Peyton Jones, Chris Clack, Jon Salkild, Mark Hardie} +{Functional programming on the GRIP multiprocessor} +{Proc IEE Seminar on Digital Parallel Processors, Lisbon, Portugal, 1988} +{ +Most MIMD computer architectures can be classified as +tightly-coupled or loosely-coupled, +depending on the relative latencies seen by a processor accessing different +parts of its address space. + +By adding microprogrammable functionality to the memory units, we have +developed a MIMD computer architecture which explores the middle region +of this spectrum. +This has resulted in an unusual and flexible bus-based multiprocessor, +which we are using as a base for our research in parallel functional programming +languages. + +In this paper we introduce parallel functional programming, and describe +the architecture of the GRIP multiprocessor. +} + +\reference{Geoffrey Burn, Simon L Peyton Jones, and John Robson} +{The spineless G-machine} +{Proc ACM Conference on Lisp and Functional Programming, Snowbird, pp244-258, +August 1988} +{ +Recent developments in functional language implementations have +resulted in the G-machine, a programmed graph-reduction machine. +Taking this as a basis, we introduce an optimised method of +performing graph reduction, which does not need to build the +spine of the expression being reduced. +This Spineless G-machine only updates shared expressions, and +then only when they have been reduced to weak head normal form. +It is thus more efficient than the standard method of performing +graph reduction. + +We begin by outlining the philosophy and key features of the +Spineless G-machine, and comparing it with the standard +G-machine. +Simulation results for the two machines are then presented and +discussed. + +The Spineless G-machine is also compared with Tim, giving a +series of transformations by which they can be interconverted. +These open up a wide design space for abstract graph reduction +machines, which was previously unknown. + +A full specification of the machine is given in the appendix, +together with compilation rules for a simple functional language. +} + +\reference{Chris Hankin, Geoffrey Burn, and Simon L Peyton Jones} +{A safe approach to parallel combinator reduction} +{Theoretical Computer Science 56, pp17-36, North Holland, 1988} +{ +In this paper we present the results of two pieces of work which, when +combined, allow us to take a program text of a functional langauge and +produce a parallel implementation of that program. +We present the techniques for discovering sources of parallelism in +a program at compile time, and then show how this parallelism is +naturally mapped onto a parallel combinator set that we will define. + +To discover sources of parallelism in a program, we use +{\em abstract interpretation} a compile-time technique which is used +to gain information about a program which may then be used to optimise +the program's execution. +A particular use of abstract interpretation is in +{\em strictness analysis} +of functional program. +In a language that has lazy semantics, the main potential for parallelism +arises in the evaluation of arguments of strict operators. + +Having identified the sources of parallelism at compile time, it is +necessary to communicate these to the run-time system. +In the second part of the paper we introduce an extended set of combinators, +including some parallel combinators, to achieve this purpose. +} + +\reference{Simon L Peyton Jones} +{GRIP - a parallel processor for functional languages} +{Electronics and Power, pp633-636, Oct 1987; +also in ICL Technical Journal 5(3), May 1987} +{ +A brief 4-page article about the GRIP architecture. +} + +\reference{Simon L Peyton Jones, Chris Clack, Jon Salkild, and Mark Hardie} +{GRIP - a high-performance architecture for parallel graph reduction} +{Proc IFIP conference on Functional Programming Languages and +Computer Architecture, Portland, +ed Kahn, Springer Verlag LNCS 274, pp98-112, Sept 1987} +{ +GRIP is a high-performance parallel machine designed to execute +functional programs using supercombinator graph reduction. +It uses a high-bandwidth bus to provide access to a +large, distributed shared memory, using intelligent memory units and +packet-switching protocols to increase the number of processors +which the bus can support. +GRIP is also being programmed to support parallel Prolog and +DACTL. + +We outline GRIP's architecture and firmware, discuss the major design +issues, and describe the current state of the project and +our plans for the future. +} + +\reference{Simon L Peyton Jones and Chris Clack} +{Finding fixpoints in abstract interpretation} +{in Abstract Interpretation of Declarative Languages, +ed Hankin \& Abramsky, Ellis Horwood, pp246-265, 1987.} +{ +Abstract interpretation is normally used as the basis for +a static, compile-time analysis of a program. +For example, strictness analysis attempts to establish which +functions in the program are strict (we will use strictness +analysis as a running example). + +Using abstract interpretation in this way requires the +compile-time evaluation of expressions in the abstract domain. +It is obviously desirable that this evaluation should +always terminate, since otherwise the compiler would risk +non-termination. +In the case of non-recursive functions there is no problem, and +termination is guaranteed. +Recursive functions, however, present more of a problem, and it +is the purpose of this paper to explain the problem and to +offer some practical solutions. +} + +\reference{Chris Clack and Simon L Peyton Jones} +{The four-stroke reduction engine} +{Proc ACM Conference on Lisp and Functional Programming, +Boston, pp220-232, Aug 1986} +{ +Functional languages are widely claimed to be amenable to concurrent +execution by multiple processors. This paper presents an algorithm for +the parallel graph reduction of a functional program. +The algorithm supports transparent management of parallel +tasks with no explicit +communication between processors. +} + +\reference{Simon L Peyton Jones} +{Functional programming languages as a software engineering tool} +{in Software Engineering - the critical decade D Ince, +Peter Peregrinus, pp124-151, 1986} +{ +It is the purpose of this paper to suggest that functional +languages are an appropriate tool for supporting the activity +of programming in the large, and to present a justification of +this claim. +} + +\reference{Simon L Peyton Jones} +{Using Futurebus in a fifth generation computer architecture} +{Microprocessors and Microsystems 10(2), March 1986} +{ +Despite the bandwidth limitations of a bus, we present a design +for a parallel computer (GRIP) based on Futurebus, which limits bus +bandwidth requirements by using intelligent memories. + +Such a machine offers higher performance than a uniprocessor +and lower cost than a more extensible multiprocessor, as well +as serving as a vehicle for research in parallel architectures. +} + + +\section{Internal reports} + +\reference{Kevin Hammond and John Glauert} +{Implementing Pattern-Matching Functional Languages using Dactl} +{University of Glasgow, 1989} +{ +This paper describes the implementation of a family of pattern-matching +functional languages in the parallel graph-rewriting language Dactl. +Attention is focussed on the direct implementation of the +pattern-matching constructs in the context of various reduction +strategies: eager, lazy, and lazy with strictness analysis. Two new +reduction strategies combining lazy evaluation with a technique for +compiling non-overlapping patterns are also illustrated. The latter +strategies provide improved termination properties compared with +conventional functional language implementations for non-overlapping +patterns. The implementations described here cover all pattern-matching +constructs found in Standard ML, including named patterns and deep +patterns. The use of Dactl renders explicit the complexities of +pattern-matching which are obscured by implementation in a conventional +intermediate language or abstract machine. +} + +\reference{Simon L Peyton Jones} +{A practical technique for designing asynchronous finite-state machines} +{Proc Glasgow Workshop on Functional Programming, Fraserburgh,Aug 1989} +{ +The literature on asynchronous logic design is mostly of a fairly theoretical +nature. We present a practical technique for generating asynchronous finite-state +machines from a description of their states and transitions. The technique +has been used successfully to design a number of state machines in +the GRIP mulitprocessor. +} + +\reference{Kevin Hammond} +{A Proposal for an Implementation of Full Dactl on a Meiko Transputer Rack} +{SYS-C89-02, University of East Anglia, 1989} +{ +The design of an abstract machine instruction set for Dactl is +described. The instruction set is sufficient to encapsulate all Dactl +constructs; it will also permit parallel execution where applicable. +The paper considers the difficulties involved in the implementation of +this abstract instruction set on the UEA Meiko M40 transputer rack, +using a ZAPP-style kernel. Part of the code for a simulation of this +instruction set is included as an appendix to the report. +} + +\reference{Chris Clack} +{Tuning the four-stroke reduction engine} +{University College London, January 1989 ($\clubsuit$)} +{ +This paper analyses the current implementation of the four-stroke reduction +engine (a virtual machine for parallel graph reduction). +The current implementation is shown to be inefficient, and a number of +enhancements are suggested. +This paper proposes that major performance benefits will accrue from +increasing the intelligence of the memory units and giving them a more +important role in the four-stroke cycle. +} + +\reference{Chris Clack} +{Performance cost accounting for GRIP} +{University College London, January 1989 ($\clubsuit$)} +{ +This paper presents a general model for efficiency anakysis of shared-memory +parallel graph reduction architectures. +The efficiency of the GRIP implementation of the four-stroke reduction engine +is subsequently analysed by approtioning costs to the various components +of the general model. + +In particular, attention is focussed on the two aspects of execution +profiling, and analysis of resource utilsation. +} + +\reference{Chris Clack} +{Diagnosis and cure for dislocated spines} +{University College London, June 1988 ($\clubsuit$)} +{ +Locality of reference is a key issue for parallel machines, and especially +for parallel implementations of graph reduction. +If locality can be achieved then communications costs fall, +and we are better able to exploit distributed architectures. +This paper analyses a particular implementation of graph reduction -- +the four-stroke reduction engine -- and introduces the concept of +spine-locality as a basis for graph building and task-scheduling strategies +that enhance locality. +} + +\end{document} diff --git a/ghc/docs/abstracts/abstracts90.tex b/ghc/docs/abstracts/abstracts90.tex new file mode 100644 index 0000000..4bf6c65 --- /dev/null +++ b/ghc/docs/abstracts/abstracts90.tex @@ -0,0 +1,153 @@ +\documentstyle[11pt,slpj,abstracts]{article} + +\begin{document} + +\title{Abstracts of GRIP/GRASP-related papers and reports, 1990 +} + +\author{The GRASP team \\ Department of Computing Science \\ +University of Glasgow G12 8QQ +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP +and GRASP projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by FTP. Connect to {\tt ftp.dcs.glasgow.ac.uk}, +and look in {\tt pub/glasgow-fp/papers}, {\tt pub/glasgow-fp/drafts}, {\tt pub/glasgow-fp/tech\_reports}, +or {\tt pub/glasgow-fp/grasp-and-aqua-docs}. + +They can also be obtained by writing to +Alexa Stewart, Department of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +alexa@dcs.glasgow.ac.uk. +\end{abstract} + +\section{Published papers} + +\reference +{Philip Wadler} +{Comprehending monads} +{{\em ACM Conference on Lisp and Functional Programming}, +Nice, France, pp.\ 61--78, June 1990.} +{ +Category theorists invented {\em monads\/} in the 1960's +to concisely express certain aspects of universal algebra. +Functional programmers invented {\em list comprehensions\/} +in the 1970's to concisely express certain programs involving lists. +This paper shows how list comprehensions may be generalised +to an arbitrary monad, and how the resulting programming feature +can concisely express in a pure functional language some +programs that manipulate state, +handle exceptions, parse text, or invoke continuations. +A new solution to the old problem +of destructive array update is also presented. +No knowledge of category theory is assumed. +} + +\reference +{Philip Wadler} +{Linear types can change the world!} +{{\em IFIP TC 2 Working Conference on Programming +Concepts and Methods}, Sea of Galilee, Israel, April 1990.} +{ +The linear logic of J.-Y.~Girard suggests a new type +system for functional languages, one which supports operations +that ``change the world''. +Values belonging to a linear type must be used exactly once: +like the world, they cannot be duplicated or destroyed. +Such values require no reference counting or garbage collection, +and safely admit destructive array update. +Linear types extend Schmidt's notion of single threading; +provide an alternative to Hudak and Bloss' update analysis; +and offer a practical complement to Lafont and Holmstr\"om's elegant +linear languages. +} + +\reference{K Hammond and SL Peyton Jones} +{Some early experiments on the GRIP parallel reducer} +{Proc Nijmegen Workshop on Parallel Implementations of Functional Languages, TR 90-16, Dept +of Informatics, University of Nijmegen, ed Plasmeijer, 1990, pp51-72} +{ +GRIP is a multiprocessor designed to execute functional programs in +parallel using graph reduction. We have implemented a compiler for +GRIP, based on the Spineless Tagless G-machine +and can now run parallel functional programs with substantial absolute +speedup over the same program running on a uniprocessor Sun. + +Parallel functional programming shifts some of the burden of resource +allocation from the programmer to the system. Examples of such +decisions include: when to create a new concurrent activity (or {\em +thread}), when to execute such threads, where to execute them, and so +on. + +It is clearly desirable that the system should take such decisions, +{\em provided it does +a good enough job}. For example, a paged virtual memory system +almost always does an adequate job, and a programmer very seldom +has to intefere with it. +The big question for parallel functional programming is whether good +resource-allocation strategies exist, and how well they perform under a +variety of conditions. + +Now that we have an operational system, we are starting to carry out +experiments to develop resource-allocation strategies, and measure +their effectiveness. This paper reports on some very preliminary +results. They mainly concern the question of when, or even whether, +to create a new thread. This is an aspect which has so far received +little attention --- existing work has focused mainly +on load sharing rather than on thread creation. +} + + +\section{Technical reports} + +\reference +{Simon L Peyton Jones and Philip Wadler} +{A static semantics for \Haskell{}} +{Dept of Computing Science, University of Glasgow} +{ +This paper gives a static semantics for a large subset of \Haskell{}, including +giving a translation into a language without overloading. +It is our intention to cover the complete language in due course. + +One innovative aspect is the use of ideas from the second-order lambda +calculus to record type information in the program. + +The paper is long (40 pages) and is more of a reference document than +a narrative one. +} + +\reference +{Philip Wadler} +{A simple type inference algorithm} +{Dept of Computing Science, University of Glasgow} +{ +This program is intended as a showcase for Haskell's +literate programming facility and for the monadic style +of programming. It implements Hindley-Milner type inference. +Monads are used for parsing and to simplify ``plumbing'' in the type +checker. The monads for parsing, exceptions, and state as well +as the routines for unparsing are designed to be of general utility. +} + +\reference{The Grasp team} +{The Glasgow Haskell I/O system} +{Dept of Computing Science, University of Glasgow, Nov 1991} +{ +Most input/output systems for non-strict functional languages +feature a rather large ``operating system +The Glasgow Haskell system implements input and output +very largely within Haskell itself, without the conventional +enclosing ``printing mechanism''. This paper explains how the +IO system works in some detail. +} + +\end{document} + + diff --git a/ghc/docs/abstracts/abstracts91.tex b/ghc/docs/abstracts/abstracts91.tex new file mode 100644 index 0000000..913007e --- /dev/null +++ b/ghc/docs/abstracts/abstracts91.tex @@ -0,0 +1,232 @@ +\documentstyle[11pt,slpj,abstracts]{article} + +\begin{document} + +\title{Abstracts of GRIP/GRASP-related papers and reports, 1991 +} + +\author{The GRASP team \\ Department of Computing Science \\ +University of Glasgow G12 8QQ +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP +and GRASP projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by FTP. Connect to {\tt ftp.dcs.glasgow.ac.uk}, +and look in {\tt pub/glasgow-fp/papers}, {\tt pub/glasgow-fp/drafts}, {\tt pub/glasgow-fp/tech\_reports}, +or {\tt pub/glasgow-fp/grasp-and-aqua-docs}. + +They can also be obtained by writing to +Alexa Stewart, Department of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +alexa@dcs.glasgow.ac.uk. +\end{abstract} + +\section{Published papers} + +\reference +{Simon L Peyton Jones and David Lester} +{A modular fully-lazy lambda lifter in \Haskell{}} +{{\em Software Practice and Experience}, 21(5) (May 1991)} +{An important step in many compilers for functional languages is +{\em lambda lifting}. In his thesis, Hughes showed that by doing lambda +lifting in a particular way, a useful property called {\em full laziness} +can be preserved; +full laziness has been seen as intertwined with +lambda lifting ever since. + +We show that, on the contrary, full laziness can be regarded as a completely +separate process to lambda lifting, thus making it easy to use different +lambda lifters following a full-laziness transformation, or to use +the full-laziness transformation in compilers which do not require lambda +lifting. + +On the way, we present the complete code for our modular fully-lazy +lambda lifter, written in the \Haskell{} functional programming language. +} + +\reference{Simon L Peyton Jones and Mark Hardie} +{A Futurebus interface from off-the-shelf parts} +{IEEE Micro, Feb 1991} +{ +As part of the GRIP project we have designed a Futurebus interface using +off-the-shelf parts. +We describe our implementation, which is unusual in its use of fully +asynchronous finite-state machines. +Based on this experience we draw some lessons for future designs. +} + +\reference{Simon L Peyton Jones and John Launchbury} +{Unboxed values as first class citizens} +{Functional Programming Languages and Computer Architecture (FPCA), Boston, +ed Hughes, Springer LNCS 523, Sept 1991, pp636--666} +{The code compiled from a non-strict functional program usually +manipulates heap-allocated {\em boxed} numbers. +Compilers for such languages often go to considerable trouble to +optimise operations on boxed numbers into simpler operations +on their unboxed forms. These optimisations are usually handled +in an {\em ad hoc} manner in +the code generator, because earlier phases of the compiler have +no way to talk about unboxed values. + +We present a new approach, which makes unboxed values into (nearly) first-class +citizens. The language, including its type system, is extended to +handle unboxed values. The optimisation of boxing and unboxing operations +can now be reinterpreted as a set of correctness-preserving program +transformations. Indeed the particular transformations +required are ones which a compiler would want to implement anyway. +The compiler becomes both simpler and more modular. + +Two other benefits accrue. +Firstly, the results of strictness analysis can be exploited within +the same uniform transformational framework. +Secondly, new algebraic data types with +unboxed components can be declared. Values of these types can be +manipulated much more efficiently than the corresponding boxed versions. + +Both a static and a dynamic semantics are given for the augmented language. +The denotational dynamic semantics is notable for its use of +{\em unpointed domains}. +} + +\reference{Philip Wadler} +{Is there a use for linear logic?} +{ACM/IFIP Symposium on Partial Evaluation +and Semantics Based Program Manipulation (PEPM), Yale +University, June 1991} +{ +Past attempts to apply Girard's linear logic have either had a clear +relation to the theory (Lafont, Holmstr\"om, Abramsky) or a clear +practical value (Guzm\'an and Hudak, Wadler), but not both. This paper +defines a sequence of languages based on linear logic that span the gap +between theory and practice. Type reconstruction in a linear type +system can derive information about sharing. An approach to linear type +reconstruction based on {\em use types\/} is presented. Applications +to the {\em array update\/} problem are considered. +} + +\reference{Simon L Peyton Jones} +{The Spineless Tagless G-machine: a second attempt} +{Proc Workshop on Parallel Implementations of Functional Languages, +University of Southampton, ed Glaser \& Hartel, June 1991} +{The Spineless Tagless G-machine is an abstract machine designed +to support functional languages. This presentation of the machine +falls into two parts. Firstly, we present the {\em STG language}, +an austere but recognisably-functional language, which as well as +a {\em denotational} meaning has a well-defined {\em operational} semantics. +The STG language is the ``abstract machine code'' for the Spineless +Tagless G-machine, but it is sufficiently abstract that it can readily be +compiled into G-machine Gcode or TIM code instead. + +Secondly, we discuss the mapping of the STG language onto stock hardware. +The success of an abstract machine model depends largely on how efficient +this mapping can be made, though this topic is often relegated to a short +section. Instead, we give a detailed discussion of the design issues and +the choices we have made. Our principal target is the C language, treating +the C compiler as a portable assembler. + +A revised version is in preparation for the Journal of Functional Programming. +} + +\reference{Gert Akerholt, Kevin Hammond, Simon Peyton Jones and Phil Trinder} +{A parallel functional database on GRIP} +{\GlasgowNinetyOne{}, pp1-24} +{ +GRIP is a shared-memory multiprocessor designed for efficient parallel +evaluation of functional languages, using compiled graph reduction. +In this paper, we consider the feasibility of implementing a database +manager on GRIP, and present results obtained from a pilot +implementation. A database implemented in a pure functional language +must be modified {\em non-destructively}, i.e.\ the original database +must be preserved and a new copy constructed. The naive +implementation provides evidence for the feasibility of a pure +functional database in the form of modest real-time speed-ups, and +acceptable real-time performance. This performance can be tentatively +compared with results for existing machines running a more +sophisticated database benchmark. +The functional database is also used to investigate the GRIP +architecture, compared with an idealised machine. The particular +features investigated are the thread-creation costs and caching of +GRIP's distributed memory. +} + +\reference{PM Sansom} +{Combining single-space and two-space compacting garbage collectors} +{\GlasgowNinetyOne{}, pp312-324} +{The garbage collector presented in this paper makes use of +two well known compaction garbage collection algorithms with very +different performance characteristics: Cheney's two-space copying +collector and Jon\-ker's single-space sliding compaction collector. We +propose a scheme which allows either collector to be used. The +run-time memory requirements of the program being executed are used to +determine the most appropriate collector. This enables us to achieve a +fast collector for heap requirements less than half of the heap memory +but allows the heap utilization to increase beyond this threshold. +Using these ideas we develop a particularly attractive extension to +Appel's generational collector. +} + +\reference{PM Sansom} +{Dual-mode garbage collection} +{Proc Workshop on the Parallel Implementation of Functional Languages, Southampton, +ed Glaser \& Hartel, pp283-310} +{ +The garbage collector presented in this paper makes use of two well +known compaction garbage collection algorithms with very different +performance characteristics: Cheney's two-space copying collector and +Jonker's sliding compaction collector. We propose a scheme which +allows either collector to be used. The run-time memory requirements +of the program being executed are used to determine the most +appropriate collector. This enables us to achieve a fast collector for +heap requirements less than half of the heap memory but allows the +heap utilization to increase beyond this threshold. Using these ideas +we develop a particularly attractive extension to Appel's generational +collector. + +We also describe a particularly fast implementation of the garbage +collector which avoids interpreting the structure and current state of +closures by attaching specific code to heap objects. This code {\em +knows} the structure and current state of the object and performs the +appropriate actions without having to test any flag or arity fields. +The result is an implementation of these collection schemes which does +not require any additional storage to be associated with the heap +objects. + +This paper is an earlier, and fuller, version of ``Combining +single-space and two-space compacting garbage collectors'' above. +} + +\reference{K Hammond} +{Efficient type inference using monads} +{\GlasgowNinetyOne{}, pp146-157} +{{\em Efficient} type inference algorithms are based on +graph-rewriting techniques. Consequently, at first sight they seem +unsuitable for functional language implementation. In fact, most +compilers written in functional languages use substitution-based +algorithms, at a considerable cost in performance. In this paper, we +show how monads may be used to transform a substutition-based inference +algorithm into one using a graph representation. The resulting +algorithm is faster than the corresponding substitution-based one.} + + +\section{Technical reports} + +\reference{The Grasp team} +{The Glasgow Haskell I/O system} +{Dept of Computing Science, University of Glasgow, Nov 1991} +{ +Most input/output systems for non-strict functional languages +feature a rather large ``operating system +The Glasgow Haskell system implements input and output +very largely within Haskell itself, without the conventional +enclosing ``printing mechanism''. This paper explains how the +IO system works in some detail. +} + +\end{document} diff --git a/ghc/docs/abstracts/abstracts92.tex b/ghc/docs/abstracts/abstracts92.tex new file mode 100644 index 0000000..6c25d66 --- /dev/null +++ b/ghc/docs/abstracts/abstracts92.tex @@ -0,0 +1,292 @@ +\documentstyle[11pt,slpj,abstracts]{article} +\begin{document} + +% ====================================================== + +\title{Abstracts of GRIP/GRASP-related papers and reports, 1992 +} + +\author{The GRASP team \\ Department of Computing Science \\ +University of Glasgow G12 8QQ +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP +and GRASP projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by FTP. Connect to {\tt ftp.dcs.glasgow.ac.uk}, +and look in {\tt pub/glasgow-fp/papers}, {\tt pub/glasgow-fp/drafts}, {\tt pub/glasgow-fp/tech\_reports}, +or {\tt pub/glasgow-fp/grasp-and-aqua-docs}. + +They can also be obtained by writing to +Alexa Stewart, Department of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +alexa@dcs.glasgow.ac.uk. +\end{abstract} + +\section{Book} + +\reference{Simon Peyton Jones and David Lester} +{Implementing functional languages} +{Prentice Hall, 1992} +{ +This book gives a practical approach to understanding implementations +of non-strict functional languages using lazy graph reduction. + +An unusual feature of the book is that the text of each chapter is +itself a directly-executable Miranda(TM) program, constituting a +minimal but complete compiler and interpreter for a particular +abstract machine. The complete source code for the book, and a +Tutor's Guide containing solutions to the exercises, is available in +machine-readable form by network file transfer (FTP). + +Written to allow the reader to modify, extend and experiment with the +implementations provided in the text, this book will help to make a +course on functional-langauge implementation "come alive". + +{\bf Contents}. The Core Language. Template instantiation. The G-machine. +The Three Instruction Machine. A parallel G-machine. Lambda lifting +and full laziness. Appendices. Bibliography. Index. +} + + +\section{Published papers} + +\reference{Simon L Peyton Jones} +{Implementing lazy functional languages on stock hardware: +the Spineless Tagless G-machine} +{Journal of Functional Programming 2(2) (Apr 1992)} +{The Spineless Tagless G-machine is an abstract machine designed +to support non-strict higher-order +functional languages. This presentation of the machine +falls into three parts. Firstly, we give a general discussion of +the design issues involved in implementing non-strict functional +languages. + +Next, we present the {\em STG language}, +an austere but recognisably-functional language, which as well as +a {\em denotational} meaning has a well-defined {\em operational} semantics. +The STG language is the ``abstract machine code'' for the Spineless +Tagless G-machine. + +Lastly, we discuss the mapping of the STG language onto stock hardware. +The success of an abstract machine model depends largely on how efficient +this mapping can be made, though this topic is often relegated to a short +section. Instead, we give a detailed discussion of the design issues and +the choices we have made. Our principal target is the C language, treating +the C compiler as a portable assembler. + +This paper used to be called ``The Spineless Tagless G-machine: a second +attempt'', but has been retitled and substantially expanded with new +material which tries to set the machine in the context of compiler +technology for other languages. The paper is very long (65 pages) and +has an index. +} + +\reference{Philip Wadler} +{The essence of functional programming} +{Invited talk, 19'th Annual Symposium on Principles of +Programming Languages, Santa Fe, New Mexico, Jan 1992} +{ +This paper explores the use monads to structure functional programs. +No prior knowledge of monads or category theory is required. + +Monads increase the ease with which programs may be modified. They can +mimic the effect of impure features such as exceptions, state, and +continuations; and also provide effects not easily achieved with such +features. The types of a program reflect which effects occur. + +The first section is an extended example of the use of monads. A +simple interpreter is modified to support various extra features: error +messages, state, output, and non-deterministic choice. The second +section describes the relation between monads and continuation-passing +style. The third section sketches how monads are used in a compiler +for Haskell that is written in Haskell. +} + +\reference{A Santos and SL Peyton Jones} +{On program transformation and the Glasgow Haskell compiler} +{\GlasgowNinetyTwo{}, pp240-251} +{We describe a series of program transformations that are implemented +in the Glasgow Haskell Compiler. They are semantics preserving +transformations and suitable for automatic application by a compier. +We describe the transformations, how they interact, and their impact +on the time/space behaviour of some programs.} + +\reference{P Sansom and SL Peyton Jones} +{Profiling lazy functional languages} +{\GlasgowNinetyTwo{}, pp227-239} +{Profiling tools, which measure and display the dynamic space +and time behaviour of programs, are essential for identifying +execution bottlenecks. A variety of such tools exist for conventional +languages, but almost none for non-strict functional languages. There +is a good reason for this: lazy evaluation means that the program is +executed in an order which is not immediately apparent from the source +code, so it is difficult to relate dynamically-gathered statistics +back to the original source. + +We present a new technique which solves this problem. The framework is +general enough to profile both space and time behaviour. Better still, +it is cheap to implement, and we describe how to do so in the +context of the Spineless Tagless G-machine. +} + +\reference{CV Hall, K Hammond, WD Partain, SL Peyton Jones, and PL Wadler} +{The Glasgow Haskell Compiler: a retrospective} +{\GlasgowNinetyTwo{}, pp62-71} +{We've spent much of our time over the last +two years implementing a new compiler for the functional language Haskell +In this effort, we've been joined by Andy Gill, who has implemented a +strictness analyser, Andre Santos, who has contributed a `simplifier', and +Patrick Sansom, who wrote garbage collectors for our runtime system. + +This paper describes some of the things we have learned, what we might +do differently, and where we go from here. +} + +\reference{D King and PL Wadler} +{Combining monads} +{\GlasgowNinetyTwo{}, pp134-143} +{Monads provide a way of structuring functional programs. +Most real applications require a combination of primitive monads. +Here we describe how some monads may be combined with others to +yield a {\em combined monad}.} + +\reference{J Launchbury, A Gill, RJM Hughes, S Marlow, SL Peyton Jones, and PL Wadler} +{Avoiding unnecessary updates} +{\GlasgowNinetyTwo{}, pp144-153} +{Graph reduction underlies most implementations of lazy functional +languages, allowing separate computations to share results when +sub-terms are evaluated. Once a term is evaluated, the node of the +graph representing the computation is {\em updated} with the value of +the term. However, in many cases, no other computation requires this +value, so the update is unnecessary. In this paper we take some steps +towards an analysis for determining when these updates may be omitted. +} + +\reference{S Marlow and PL Wadler} +{Deforestation for higher-order functions} +{\GlasgowNinetyTwo{}, pp154-165} +{Deforestation is an automatic transformation scheme for functional +programs which attempts to remove unnecessary intermediate data +structures. The algorithm presented here is a variant of the original, +adapted for a higher order language. A detailed description of how +this may be implemented in an optimising compiler is also given. +} + +\reference{WD Partain} +{The nofib benchmark suite of Haskell programs} +{\GlasgowNinetyTwo{}, pp195-202} +{This position paper describes the need for, make-up of, and +``rules of the game'' for a benchmark suite of Haskell programs. (It +does not include results from running the suite.) Those of us working +on the Glasgow Haskell compiler hope this suite will encourage sound, +quantitative assessment of lazy functional programming systems. This +version of this paper reflects the state of play at the initial +pre-release of the suite. +} + +\reference{PL Wadler} +{Monads for functional programming} +{Proceedings of the Marktoberdorf Summer School on Programming Calculi, +ed M Broy, July-August 1992, Springer Verlag} +{The use of monads to structure functional programs is +described. Monads provide a convenient framework for simulating +effects found in other languages, such as global state, exception +handling, output, or non-determinism. Three case studies are looked at +in detail: how monads ease the modification of a simple evaluator; +how monads act as the basis of a datatype of arrays subject to in-place +update; and how monads can be used to build parsers. +} + +\reference{K Hammond, P Trinder, P Sansom and D McNally} +{Improving persistent data manipulation for functional languages} +{\GlasgowNinetyTwo{}, pp72-85} +{Although there is a great deal of academic interest in +functional languages, there are very few large-scale functional +applications. The poor interface to the file system seems to be a +major factor preventing functional languages being used for +large-scale programming tasks. The interfaces provided by some +widely-used languages are described and some problems encountered with +using these interfaces to access persistent data are discussed. Three +means of improving the persistent data manipulation facilities of +functional languages are considered: an improved interface to the file +system, including a good binary file implementation; an interface to a +database; and the provision of orthogonal persistence. Concrete +examples are given using the functional programming language, Haskell. +} + +\reference{Kevin Hammond and Simon Peyton Jones} +{Profiling scheduling strategies on the GRIP parallel reducer} +{Proc 1992 Workshop on Parallel Implementations of Functional Languages, Aachen, +ed Kuchen, Sept 1992} +{It is widely claimed that functional languages are particularly +suitable for programming parallel computers. A claimed advantage is +that the programmer is not burdened with details of task creation, +placement, scheduling, and synchronisation, these decisions being +taken by the system instead. + +Leaving aside the question of whether a pure functional language is +expressive enough to encompass all the parallel algorithms we might +wish to program, there remains the question of how effectively the +compiler and run-time system map the program onto a real parallel +system, a task usually carried out mostly by the programmer. This is +the question we address in our paper. + +We first introduce the system architecture of GRIP, a shared-memory +parallel machine supporting an implementation of the functional +language Haskell. GRIP executes functional programs in parallel using +compiled supercombinator graph reduction, a form of +declarative rule system. + +We then to describe several strategies for run-time resource +control which we have tried, presenting comprehensive measurements of +their effectiveness. We are particularly concerned with strategies +controlling task creation, in order to improve task granularity and +minimise communication overheads. This is, so far as we know, one of +the first attempts to make a systematic study of task-control +strategies in a high-performance parallel functional-language system. +GRIP's high absolute performance render these results credible for +real applications. +} + +\section{Technical reports} + +\reference{CV Hall, K Hammond, SL Peyton Jones, PL Wadler} +{Type classes in Haskell} +{Department of Computing Science, University of Glasgow} +{This paper defines a set of type inference rules for resolving +overloading introduced by type classes. Programs including type +classes are transformed into ones which may be typed by the +Hindley-Milner inference rules. In contrast to an other work on type +classes, the rules presented here relate directly to user programs. An +innovative aspect of this work is the use of second-order lambda +calculus to record type information in the program. +} + +\shortreference{CV Hall} +{A transformed life: introducing optimised lists automatically} +{submitted to FPCA 93} +{} + +\shortreference{K Hammond} +{The Spineless Tagless G-machine --- NOT!} +{submitted to FPCA 93} + +\shortreference{CV Hall} +{An optimists view of Life} +{submitted to Journal of Functional Programming, 1993} +{} +% ~cvh/Public/Papers/An_Optimists_View.dvi + +\end{document} + + + + + diff --git a/ghc/docs/abstracts/abstracts93.tex b/ghc/docs/abstracts/abstracts93.tex new file mode 100644 index 0000000..fa15beb --- /dev/null +++ b/ghc/docs/abstracts/abstracts93.tex @@ -0,0 +1,326 @@ +\documentstyle[11pt,slpj,abstracts]{article} + +\begin{document} + +% ====================================================== + +\title{Abstracts of GRIP/GRASP/AQUA-related papers and reports, 1993 +} + +\author{The AQUA team \\ Department of Computing Science \\ +University of Glasgow G12 8QQ +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP, GRASP and AQUA projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by FTP. Connect to {\tt ftp.dcs.glasgow.ac.uk}, +and look in {\tt pub/glasgow-fp/papers}, {\tt pub/glasgow-fp/drafts}, {\tt pub/glasgow-fp/tech\_reports}, +or {\tt pub/glasgow-fp/grasp-and-aqua-docs}. + +They can also be obtained by writing to +Alexa Stewart, Department of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +alexa@dcs.glasgow.ac.uk. +\end{abstract} + +\section{Published papers} + +\reference{CV Hall} +{Using overloading to express distinctions} +{Information Processing Letters (to appear)} +{ +Evaluators, also called ``interpreters'', play a variety of roles +in the study of programming languages. Given this, it's surprising +that we don't have a better framework for developing evaluators and +specifying their relationship to each other. This paper +shows that type classes in Haskell provide an excellent +framework for exploring relationships between evaluators, using +abstract interpretation as a motivating example. +} + +\reference{A Gill, J Launchbury and SL Peyton Jones} +{A short cut to deforestation} +{ACM Conference on Functional Programming and Computer Architecture, Copenhagen, pp223-232} +{Lists are often used as ``glue'' to connect +separate parts of a program together. +We propose an automatic technique for +improving the efficiency of such programs, +by removing many of these intermediate lists, +based on a single, simple, local transformation. +We have implemented the method in the Glasgow Haskell compiler. +} + +\reference{P Sansom and SL Peyton Jones} +{Generational garbage collection for Haskell} +{ACM Conference on Functional Programming and Computer Architecture, Copenhagen, pp106-116} +{This paper examines the use of generational garbage collection +techniques for a lazy implementation of a non-strict functional +language. Detailed measurements which demonstrate that a generational +garbage collector can substantially out-perform non-generational +collectors, despite the frequency of write operations in the +underlying implementation, are presented. + +Our measurements are taken from a state-of-the-art compiled +implementation for Haskell, running substantial benchmark programs. +We make measurements of dynamic properties (such as object lifetimes) +which affect generational collectors, study their interaction with a +simple generational scheme, make direct performance comparisons with +simpler collectors, and quantify the interaction with a paging system. + +The generational collector is demonstrably superior. At least for our +benchmarks, it reduces the net storage management overhead, and it +allows larger programs to be run on a given machine before thrashing +ensues.} + +\reference{J Launchbury} +{Lazy imperative programming} +{Proc ACM Sigplan Workshop on State in Programming Languages, Copenhagen, June 1993 (available as +YALEU/DCS/RR-968, Yale University), pp46-56} +{ +In this paper we argue for the importance of lazy state, that is, +sequences of imperative (destructive) actions in which the actions are +delayed until their results are required. This enables state-based +computations to take advantage of the control power of lazy evaluation. +We provide some examples of its use, and describe an implementation +within Glasgow Haskell. +} + +\reference{G Akerholt, K Hammond, P Trinder and SL Peyton Jones} +{Processing transactions on GRIP, a parallel graph reducer} +{Proc Parallel Architectures and Languages Europe (PARLE), Munich, June 1993, pp634-647} +{ +The GRIP architecture allows efficient execution of functional +programs on a multi-processor built from standard hardware components. +State-of-the-art compilation techniques are combined with +sophisticated runtime resource-control to give good parallel +performance. This paper reports the results of running GRIP on an +application which is apparently unsuited to the basic functional +model: a database transaction manager incorporating updates as well as +lookup transactions. The results obtained show good relative speedups +for GRIP, with real performance advantages over the same application +executing on sequential machines. +} + +\reference{SL Peyton Jones and PL Wadler} +{Imperative functional programming} +{ACM conference on Principles of Programming Languages, Charleston, Jan 1993} +{We present a new model, based on monads, for performing input/output +in a non-strict, purely functional language. It +is composable, extensible, efficient, requires no extensions +to the type system, and extends smoothly to incorporate mixed-language +working and in-place array updates. +} + +\reference{J Launchbury} +{An operational semantics for lazy evaluation} +{ACM conference on Principles of Programming Languages, Charleston, Jan 1993} +{We define an operational semantics for lazy evaluation which provides +an accurate model for sharing. The only computational structure +we introduce is a set of bindings which corresponds closely to a +heap. The semantics is set at a considerably higher level of abstraction +than operational semantics for particular abstract machines, so is +more suitable for a variety of proofs. Furthermore, because a heap +is explicitly modelled, the semantics provides a suitable framework +for studies about space behaviour of terms under lazy evaluation. +} + +\reference{SL Peyton Jones, CV Hall, K Hammond, WD Partain, and PL Wadler} +{The Glasgow Haskell compiler: a technical overview} +{JFIT Technical Conference, Keele, March 1993} +{We give an overview of the Glasgow Haskell compiler, +focusing especially on way in which we have been able +to exploit the rich theory of functional languages to give +very practical improvements in the compiler. + +The compiler is portable, modular, generates good code, and is +freely available. +} + +\reference{PL Wadler} +{A syntax for linear logic} +{Mathematical Foundations of +Programming Language Semantics, New Orleans, April 1993} +{There is a standard syntax for Girard's linear logic, due +to Abramsky, and a standard semantics, due to Seely. Alas, the +former is incoherent with the latter: different derivations of +the same syntax may be assigned different semantics. This paper +reviews the standard syntax and semantics, and discusses the problem +that arises and a standard approach to its solution. A new solution +is proposed, based on ideas taken from Girard's Logic of Unity. +The new syntax is based on pattern matching, allowing for concise +expression of programs.} + +\reference{SL Peyton Jones, J Hughes, J Launchbury} +{How to give a good research talk} +{SIGPLAN Notices 28(11), Nov 1993, 9-12} +{ +Giving a good research talk is not easy. We try to identify some things +which we have found helpful, in the hope that they may be useful to you. +} + + +\section{Workshop papers and technical reports} + +The 1993 Glasgow Functional Programming Workshop papers exist in +the draft proceedings at the moment. They are being refereed, and will +be published by Springer Verlag in due course. + +\reference{DJ King and J Launchbury} +{Lazy Depth-First Search and Linear Graph Algorithms in Haskell} +{\GlasgowNinetyThree{}} +{ +Depth-first search is the key to a wide variety of graph algorithms. +In this paper we explore the implementation of depth first search in a +lazy functional language. For the first time in such languages we +obtain a linear-time implementation. But we go further. Unlike +traditional imperative presentations, algorithms are constructed from +individual components, which may be reused to create new +algorithms. Furthermore, the style of program is quite amenable to +formal proof, which we exemplify through a calculational-style proof +of a strongly-connected components algorithm. + +{\em This paper has been submitted to Lisp \& Functional Programming 1994.} +} + +\reference{K Hammond, GL Burn and DB Howe} +{Spiking your caches} +{\GlasgowNinetyThree{}} +{ +Despite recent advances, predicting the performance of functional +programs on real machines remains something of a black art. This +paper reports on one particularly unexpected set of results where +small variations in the size of a dynamic heap occasionally gave rise +to 50\% differences in CPU performance. These performance {\em +spikes} can be traced to the cache architecture of the machine being +benchmarked, the widely-used Sun Sparcstation~1. A major contribution +of our work is the provision of a tool which allows cache conflicts +to be located by the type of access (heap, stack etc.). This can +be used to improve the functional language implementation, or to +study the memory access patterns of a particular program. +} + +\reference{S Marlow} +{Update avoidance analysis} +{\GlasgowNinetyThree{}} +{ +A requirement of lazy evaluation is that the value of any +subexpression in the program is calculated no more than once. This is +achieved by updating an expression with its value, once computed. The +problem is that updating is a costly operation, and experimentation +has shown that it is only necessary in about 30\% of cases (that is, +70\% of expressions represent values that are only ever required once +during execution). The aim of the analysis presented in this paper is +to discover expressions that do not need to be updated, and thus +reduce the execution time of the program. The analysis has been +implemented in the Glasgow Haskell Compiler, and results are given. + +FTP: @pub/glasgow-fp/authors/Simon_Marlow/update-avoidance.ps.gz@ +} + +\reference{SL Peyton Jones and WD Partain} +{Measuring the effectiveness of a simple strictness analyser} +{\GlasgowNinetyThree{}} +{ +A lot has been written about strictness analysis for non-strict +functional programs, usually in the hope that the results of the +analysis can be used to reduce runtime. On the other hand, few papers +present measurements of how well it works in practice. Usually, all +that is presented are the run-times of a variety of (usually small) +programs, with and without strictness analysis enabled. The goal of +this paper is to provide detailed quantitative insight about the +effectiveness of a simple strictness analyser, in the context of a +state-of-the art compiler running serious application programs. +} + +\reference{J Mattson} +{Local speculative evaluation for distributed graph reduction} +{\GlasgowNinetyThree{}} +{ +Speculative evaluation attempts to increase parallelism by +performing potentially useful computations before they are known to be +necessary. Speculative computations may be coded explicitly in a +program, or they may be scheduled implicitly by the reduction system +as idle processors become available. A general approach to both kinds +of speculation incurs a great deal of overhead which may outweigh the +benefits of speculative evaluation for fine-grain speculative tasks. + +Suppose that implicit speculative computations are restricted to +execution on the local processor, with the hope of performing +potentially useful work while the local mandatory tasks are all +blocked. This restriction greatly simplifies the problems of +speculative task management, and it opens the door for fine-grain +speculative tasks. More complex mechanisms for distributing +and managing coarse-grain speculative tasks can later be added on top of +the basic foundation provided for local speculative evaluation. +} + +\reference{PM Sansom} +{Time profiling a lazy functional compiler} +{\GlasgowNinetyThree{}} +{ +Recent years has seen the development of profiling tools for lazy +functional language implementations. This paper presents the results +of using a time profiler to profile the Glasgow Haskell compiler. +} + +\reference{D King and J Launchbury} +{Functional graph algorithms with depth-first search} +{\GlasgowNinetyThree{}} +{Performing a depth-first search of a graph is one of the fundamental +approaches for solving a variety of graph algorithms. Implementing +depth-first search efficiently in a pure functional language has only +become possible with the advent of imperative functional programming. +In this paper we mix the techniques of pure functional programming in +the same cauldron as depth-first search, to yield a more lucid +approach to viewing a variety of graph algorithms. This claim will be +illustrated with several examples.} + +\reference{A Santos and SL Peyton Jones} +{Tuning a compiler's allocation policy} +{\GlasgowNinetyThree{}} +{There are many different costs involved in the allocation of +closures during the execution of functional programs. Even more so +for closures that are not in normal form, as they have to be +allocated and then possibley entered and updated. We compare several +different policies for closure allocation, trying to minimise these +costs. The issues of laziness and full laziness are discussed. +} + +\reference{CV Hall} +{A framework for optimising abstract data types} +{\GlasgowNinetyThree{}} +{Two trends have been developing in functional programming language +research. First, compilers are supporting optimisations of data +types, such as unboxed types and parallel bags. Second, functional +programmers are increasingly writing code in a style that treats +data types as if they were abstract. Abstract data types offer +opportunities for optimisation because the representation of the +type can be optimised without affecting the program, allowing the +programmer to use operations on it and improve performance. At the +same time, the original type is often required by some part of the +program, and the programmer is left to figure out which to use +where. + +This paper presents a general framework in which good functional +style automatically supports the efficient implementation of data +types. It has been implemented in the Glasgow Haskell compiler +specifically to introduce an optimised list representation, and +this has been shown to cut execution time in half on a Sun +SPARCstation-1 for a substantial program. Recent tests show that +it improves performance by more than a factor of 4 on the GRIP +parallel processor for short tests, however more experiments will +be necessary before we can assert that this speedup holds in +general. +} +\end{document} + + + + + diff --git a/ghc/docs/abstracts/abstracts94.tex b/ghc/docs/abstracts/abstracts94.tex new file mode 100644 index 0000000..7ee257d --- /dev/null +++ b/ghc/docs/abstracts/abstracts94.tex @@ -0,0 +1,187 @@ +\documentstyle[11pt,slpj,abstracts]{article} + +\begin{document} + +% ====================================================== + +\title{Abstracts of GRIP/GRASP/AQUA-related papers and reports, 1994 +} + +\author{The AQUA team \\ Department of Computing Science \\ +University of Glasgow G12 8QQ +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP, GRASP and AQUA projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by FTP. Connect to {\tt ftp.dcs.glasgow.ac.uk}, +and look in {\tt pub/glasgow-fp/papers}, {\tt pub/glasgow-fp/drafts}, {\tt pub/glasgow-fp/tech\_reports}, +or {\tt pub/glasgow-fp/grasp-and-aqua-docs}. + +Another useful place to look is on the Functional Programming Group WWW page: +{\tt ftp://ftp.dcs.glasgow.ac.uk/pub/glasgow-fp/glasgow-fp.html}. + +They can also be obtained by writing to +Helen McNee, Department of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +helen@dcs.glasgow.ac.uk. +\end{abstract} + +\section{Published papers} + +\reference{J Launchbury and SL Peyton Jones} +{State in Haskell} +{To appear in Lisp and Symbolic Computation (50 pages)} +{ +Some algorithms make critical internal use of updatable state, even +though their external specification is purely functional. Based on +earlier work on monads, we present a way of securely encapsulating +stateful computations that manipulate multiple, named, mutable +objects, in the context of a non-strict, purely-functional language. +The security of the encapsulation is assured by the type system, using +parametricity. The same framework is also used to handle input/output +operations (state changes on the external world) and calls to C. + +FTP: {\tt pub/glasgow-fp/drafts/state-lasc.ps.Z} +} + +\reference{P Sansom and SL Peyton Jones} +{Time and space profiling for non-strict higher-order functional languages} +{To appear in POPL 95} +{ +We present the first profiler for a compiled, non-strict, higher-order, +purely functional language capable of measuring {\em time} +as well as {\em space} usage. Our profiler is implemented +in a production-quality optimising compiler for Haskell, +has low overheads, and can successfully profile large applications. + +A unique feature of our approach is that we give a formal +specification of the attribution of execution costs to cost centres. +This specification enables us to discuss our design decisions in a +precise framework. Since it is not obvious how to map this +specification onto a particular implementation, we also present an +implementation-oriented operational semantics, and prove it equivalent +to the specification. +} + + +% pub/glasgow-fp/authors/Philip_Wadler/monads-for-fp.dvi + +\reference{Philip Wadler} +{Monads for functional programming} +{in M. Broy (editor), +{\em Program Design Calculi}, proceedings of the International +Summer School directed by F. L. Bauer, M. Broy, E. W. Dijkstra, D. +Gries, and C. A. R. Hoare. Springer Verlag, NATO ASI series, Series +F: Computer and System Sciences, Volume 118, 1994} +{ +The use of monads to structure functional programs is +described. Monads provide a convenient framework for simulating +effects found in other languages, such as global state, exception +handling, output, or non-determinism. Three case studies are looked at +in detail: how monads ease the modification of a simple evaluator; +how monads act as the basis of a datatype of arrays subject to in-place +update; and how monads can be used to build parsers. +} + +% pub/glasgow-fp/authors/Philip_Wadler/taste-of-linear-logic.dvi +\reference{Philip Wadler} +{A taste of linear logic} +{{\em Mathematical Foundations of Computer Science}, +Gdansk, Poland, August 1993, Springer Verlag, LNCS 711} +{This tutorial paper provides an introduction to intuitionistic logic +and linear logic, and shows how they correspond to type systems for +functional languages via the notion of `Propositions as Types'. The +presentation of linear logic is simplified by basing it on the Logic +of Unity. An application to the array update problem is briefly +discussed. +} + +% It's in +% /local/grasp/docs/short-static-semantics/new-paper/kevins-latest-version + +\reference{Cordelia Hall, Kevin Hammond, Simon Peyton Jones and Philip Wadler} +{Type classes in Haskell} +{European Symposium on Programming, 1994} +{ +This paper defines a set of type inference rules for resolving +overloading introduced by type classes. Programs including type +classes are transformed into ones which may be typed by the +Hindley-Milner inference rules. In contrast to other work on type +classes, the rules presented here relate directly to user programs. +An innovative aspect of this work is the use of second-order lambda +calculus to record type information in the program. +} + +\reference{PL Wadler} +{Monads and composable continuations} +{Lisp and Symbolic Computation 7(1)} +{Moggi's use of monads to factor semantics is used to model the +composable continuations of Danvy and Filinski. This yields some +insights into the type systems proposed by Murthy and by Danvy and +Filinski. Interestingly, modelling some aspects of composable +continuations requires a structure that is almost, but not quite, a +monad. +} + +\reference{J Launchbury and SL Peyton Jones} +{Lazy Functional State Threads} +{Programming Languages Design and Implementation, Orlando, June 1994} +{ +Some algorithms make critical internal use of updatable state, even +though their external specification is purely functional. Based on +earlier work on monads, we present a way of securely encapsulating +such stateful computations, in the context of a non-strict, +purely-functional language. + +There are two main new developments in this paper. First, we show how +to use the type system to securely encapsulate stateful computations, +including ones which manipulate multiple, named, mutable objects. +Second, we give a formal semantics for our system. + +FTP: {\tt pub/glasgow-fp/papers/state.ps.Z} +} + +\reference{K Hammond, JS Mattson Jr. and SL Peyton Jones} +{Automatic spark strategies and granularity for a parallel functional language reducer} +{CONPAR, Sept 1994} +{ +This paper considers the issue of dynamic thread control in the context +of a parallel Haskell implementation on the GRIP multiprocessor. +For the first time we report the effect of our thread control strategies +on thread granularity, as measured by dynamic heap allocation. This +gives us a concrete means of measuring the effectiveness of these strategies, +other than wall-clock timings which are notoriously uninformative. + +FTP: {\tt pub/glasgow-fp/papers/spark-strategies-and-granularity.ps.Z} +} + +\reference{K Hammond} +{Parallel Functional Programming: an Introduction} +{PASCO '94, Sept. 1994 (Invited Paper)} + +This paper introduces the general area of parallel functional +programming, surveying the current state of research and suggesting +areas which could profitably be explored in the future. No new +results are presented. The paper contains 97 references selected from +the 500 or so publications in this field. + +FTP: {\tt pub/glasgow-fp/papers/parallel-introduction.ps.Z} + +% \section{Workshop papers and technical reports} + +% The 1994 Glasgow Functional Programming Workshop papers exist in +% the draft proceedings at the moment. They are being refereed, and will +% be published by Springer Verlag in due course. + +\end{document} + + + + + diff --git a/ghc/docs/abstracts/before90.tex b/ghc/docs/abstracts/before90.tex new file mode 100644 index 0000000..ae3d95d --- /dev/null +++ b/ghc/docs/abstracts/before90.tex @@ -0,0 +1,471 @@ +\documentstyle[11pt,slpj]{article} + +\newcommand{\reference}[4]{ % authors, title, details, abstract +\large +#1, {\em #2}, #3. +\normalsize +\begin{quotation} +#4 +\end{quotation} +\vspace{0.2in} +} + +\newcommand{\Haskell}[1]{{\sc Haskell}} + +\begin{document} + +\title{Abstracts of GRIP/GRASP-related papers and reports before 1990\\ +Dept of Computing Science \\ +University of Glasgow G12 8QQ} + +\author{ +Cordelia Hall (cvh@cs.glasgow.ac.uk) \and +Kevin Hammond (kh@cs.glasgow.ac.uk) \and +Will Partain (partain@cs.glasgow.ac.uk) \and +Simon L Peyton Jones (simonpj@cs.glasgow.ac.uk) \and +Phil Wadler (wadler@cs.glasgow.ac.uk) +} + +\maketitle + +\begin{abstract} +We present a list of papers and reports related to the GRIP +and GRASP projects, +covering {\em the design, compilation technology, +and parallel implementations of functional programming languages, especially +\Haskell{}}. + +Most of them can be obtained by writing to +Teresa Currie, Dept of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +teresa@uk.ac.glasgow.cs. + +Those marked ($\spadesuit$) can be obtained from the School of Information +Systems, University of East Anglia, Norwich, UK. +\end{abstract} + +\section{Published papers} +%Nov +\reference{Cordelia Hall and David Wise} +{Generating Function Versions with Rational Strictness Patterns} +{Science of Computer Programming 12 (1989)} +{Expression evaluation in lazy applicative languages is usually implemented +by an expensive mechanism requiring time and space which may be wasted +if the expression eventually needs the values anyway. Strictness analysis, +which has been successfully applied to flat domains and higher order functions, +is used here to annotate programs in a first order language containing +lazy list constructors so that they retain their original behavior, but +run more efficiently. In practice, the strictness in fields within these +constructors often follows regular patterns that can be finitely +represented, especially in programs that manipulate such useful structures +as finite or infinite trees. The approach presented here typically generates +efficient, mutually recursive function versions for these programs. +Weak and strong safety are defined and discussed, and the compiler +is shown to be weakly safe. Termination is guaranteed by several factors, +including a finite resource which controls the increase in code size, +and a regularity constraint placed upon the strictness patterns +propagated during compilation.} + +\reference{Kevin Hammond} +{Exception Handling in a Parallel Functional Language: PSML} +{Proc TENCON '89, Bombay, India, Nov 1989} +{ +Handling exception occurrences during computation is a problem in most +functional programming languages, even when the computation is eager and +sequential. This paper presents a version of the error value method +which allows lazy computation with deterministic semantics for parallel +evaluation even in the presence of errors. The realisation of this +technique is illustrated by reference to PSML, a referentially +transparent variant of Standard ML designed for parallel evaluation. +} + +\reference +{Phil Trinder and Philip Wadler} +{Improving list comprehension database queries} +{{\em TENCON '89\/} (IEEE Region 10 Conference), +Bombay, India, November 1989.} +{ +The task of increasing the efficiency of database queries has recieved +considerable attention. In this paper we describe the improvement of +queries expressed as list comprehensions in a lazy functional +language. The database literature identifies four algebraic and two +implementation-based improvement strategies. For each strategy we show +an equivalent improvement for queries expressed as list +comprehensions. This means that well-developed database algorithms +that improve queries using several of these strategies can be emulated +to improve comprehension queries. We are also able to improve queries +which require greater power than that provided by the relational +algebra. Most of the improvements entail transforming a simple, +inefficient query into a more complex, but more efficient form. We +illustrate each improvement using examples drawn from the database +literature. +} + +%Sept + + +\reference{Simon L Peyton Jones and Jon Salkild} +{The Spineless Tagless G-machine} +{Proc IFIP Symposium on Functional Programming Languages and Computer +Architecture, London, Sept 1989} +{ +The Spineless Tagless G-machine is an abstract machine based on graph +reduction, designed as a target for compilers for non-strict functional +languages. +As its name implies, it is a development of earlier work, especially +the G-machine and Tim. + +It has a number of unusual features: the abstract machine code is +rather higher-level than is common, allowing better code generation; +the representation of the graph eliminates most interpretive overheads; +vectored returns from data structures give fast case-analysis; +and the machine is readily extended for a parallel implementation. + +The resulting implementation runs at least 75\% faster +than the Chalmers G-machine. +} + +\reference +{Philip Wadler} +{Theorems for free!} +{{\em 4'th International Conference on Functional Programming +Languages and Computer Architecture}, London, September 1989.} +{ +From the type of a polymorphic function we can derive a theorem +that it satisfies. Every function of the same type satisfies the same +theorem. This provides a free source of useful theorems, +courtesy of Reynolds' abstraction theorem for the polymorphic lambda +calculus. +} + +%Aug + +\reference{Kevin Hammond} +{Implementing Type Classes for Haskell} +{Proc Glasgow Workshop on Functional Programming, Fraserburgh, Aug 1989} +{ +This paper describes the implementation of the type class mechanism for +the functional language Haskell, which has been undertaken at Glasgow +University. A simple introduction to type classes discusses the methods +used to select operators and dictionaries in the Glasgow Haskell +compiler. A solution to the problem of selecting super-class +dictionaries, not considered by the original paper on type class, is +also presented. The modifications which must be made to the standard +Hindley/Milner type-checking algorithm to permit the translation of +operators are described, and a revised definition of algorithm W is +provided. Finally, a set of performance figures compares the run-time +efficiency of Haskell and LML programs, indicating the overhead inherent +in the original, naive method of operator selection, and the improvement +which may be obtained through simple optimisations. +} + +\reference{Simon L Peyton Jones} +{FLIC - a functional language intermediate code} +{SIGPLAN Notices 23(8) 1988, revised 1989} +{ +FLIC is a Functional Language Intermediate Code, intended to +provide a common intermediate language between diverse +implementations of functional languages, including parallel +ones. +This paper gives a formal definition of FLIC's syntax and +semantics, in the hope that its existence may encourage greater +exchange of programs and benchmarks between research groups. +} + +%July +\reference{Simon L Peyton Jones, Chris Clack and Jon Salkild} +{High-performance parallel graph reduction} +{Proc Parallel Architectures and Languages Europe (PARLE), LNCS 365, pp193-207, +July 1989} +{ +Parallel graph reduction is an attractive implementation for functional +programming languages because of its simplicity and inherently distributed +nature. +This paper outlines some of the issues raised by parallel compiled +graph reduction, and presents the solutions we have adopted to produce an +efficient implementation. + +We concentrate on two particular issues: +the efficient control of parallelism, resulting in an ability to alter +the granularity of parallelism +{\em dynamically}; +and the efficient use of the memory hierachy to improve locality. +} +%April + +\reference{Simon L Peyton Jones} +{Parallel implementations of functional programming languages} +{Computer Journal 32(2), pp175-186, April 1989} +{ +It is now very nearly as easy to build a parallel computer +as to build a sequential one, and there are strong incentives to do so: +parallelism seems to offer the opportunity to improve both the +absolute performance level and the cost/performance ratio of our machines. + +One of the most attractive features of functional programming languages +is their suitability for programming such parallel computers. +This paper is devoted to a discussion of this claim. + +First of all, we discuss parallel functional programming +from the programmer's point of view. +Most parallel functional language implementations are based on graph reduction, +we proceed to a discussion of some implementation issues raised by parallel +graph reduction. +The paper concludes with a case study of a particular parallel graph reduction +machine, GRIP, and a brief survey of other similar machines. +} +%Jan +\reference +{Philip Wadler and Stephen Blott} +{How to make {\em ad-hoc\/} polymorphism less {\em ad hoc}} +{{\em 16'th ACM Symposium on Principles of Programming Languages}, +Austin, Texas, January 1989.} +{ +This paper presents {\em type classes}, a new approach to {\em +ad-hoc\/} polymorphism. Type classes permit overloading of arithmetic +operators such as multiplication, and generalise the ``eqtype variables'' +of Standard ML. +Type classes extend the Hindley\X Milner polymorphic type system, and +provide a new approach to issues that arise in object-oriented +programming, bounded type quantification, and abstract data types. +This paper provides an informal introduction to type classes, and +defines them formally by means of type inference rules. +} +%88 + +\reference{Chris Hankin, Geoffrey Burn, and Simon L Peyton Jones} +{A safe approach to parallel combinator reduction} +{Theoretical Computer Science 56, pp17-36, North Holland, 1988} +{ +In this paper we present the results of two pieces of work which, when +combined, allow us to take a program text of a functional langauge and +produce a parallel implementation of that program. +We present the techniques for discovering sources of parallelism in +a program at compile time, and then show how this parallelism is +naturally mapped onto a parallel combinator set that we will define. + +To discover sources of parallelism in a program, we use +{\em abstract interpretation} a compile-time technique which is used +to gain information about a program which may then be used to optimise +the program's execution. +A particular use of abstract interpretation is in +{\em strictness analysis} +of functional program. +In a language that has lazy semantics, the main potential for parallelism +arises in the evaluation of arguments of strict operators. + +Having identified the sources of parallelism at compile time, it is +necessary to communicate these to the run-time system. +In the second part of the paper we introduce an extended set of combinators, +including some parallel combinators, to achieve this purpose. +} + + +\reference{John T. O'Donnell and Cordelia Hall} +{Debugging in Applicative Languages} +{Lisp and Symbolic Computation, 1988} +{Applicative programming languages have several properties that appear +to make debugging difficult. First, the absence of assignment +statements complicates the notion of changing a program while +debugging. Second, the absence of imperative input and output +makes it harder to obtain information about what the program is doing. +Third, the presence of lazy evaluation prevents the user from +knowing much about the order in which events occur. Some solutions to +these problems involve nonapplicative extensions to the language. +Fortunately, the same features of applicative languages that cause +problems for traditional debugging also support an idiomatic +applicative style of programming, and effective debugging techniques +can be implemented using that style. This paper shows how to implement +tracing and interactive debugging tools in a purely applicative +style. This approach is more flexible, extensive and portable +than debugging tools that require modification to the language +implementation.} + +\reference{Simon L Peyton Jones, Chris Clack, Jon Salkild, Mark Hardie} +{Functional programming on the GRIP multiprocessor} +{Proc IEE Seminar on Digital Parallel Processors, Lisbon, Portugal, 1988} +{ +Most MIMD computer architectures can be classified as +tightly-coupled or loosely-coupled, +depending on the relative latencies seen by a processor accessing different +parts of its address space. + +By adding microprogrammable functionality to the memory units, we have +developed a MIMD computer architecture which explores the middle region +of this spectrum. +This has resulted in an unusual and flexible bus-based multiprocessor, +which we are using as a base for our research in parallel functional programming +languages. + +In this paper we introduce parallel functional programming, and describe +the architecture of the GRIP multiprocessor. +} + +\reference{Geoffrey Burn, Simon L Peyton Jones, and John Robson} +{The spineless G-machine} +{Proc ACM Conference on Lisp and Functional Programming, Snowbird, pp244-258, +August 1988} +{ +Recent developments in functional language implementations have +resulted in the G-machine, a programmed graph-reduction machine. +Taking this as a basis, we introduce an optimised method of +performing graph reduction, which does not need to build the +spine of the expression being reduced. +This Spineless G-machine only updates shared expressions, and +then only when they have been reduced to weak head normal form. +It is thus more efficient than the standard method of performing +graph reduction. + +We begin by outlining the philosophy and key features of the +Spineless G-machine, and comparing it with the standard +G-machine. +Simulation results for the two machines are then presented and +discussed. + +The Spineless G-machine is also compared with Tim, giving a +series of transformations by which they can be interconverted. +These open up a wide design space for abstract graph reduction +machines, which was previously unknown. + +A full specification of the machine is given in the appendix, +together with compilation rules for a simple functional language. +} +%87 + +\reference{Simon L Peyton Jones and Chris Clack} +{Finding fixpoints in abstract interpretation} +{in Abstract Interpretation of Declarative Languages, +ed Hankin \& Abramsky, Ellis Horwood, pp246-265, 1987.} +{ +Abstract interpretation is normally used as the basis for +a static, compile-time analysis of a program. +For example, strictness analysis attempts to establish which +functions in the program are strict (we will use strictness +analysis as a running example). + +Using abstract interpretation in this way requires the +compile-time evaluation of expressions in the abstract domain. +It is obviously desirable that this evaluation should +always terminate, since otherwise the compiler would risk +non-termination. +In the case of non-recursive functions there is no problem, and +termination is guaranteed. +Recursive functions, however, present more of a problem, and it +is the purpose of this paper to explain the problem and to +offer some practical solutions. +} + +\reference{Simon L Peyton Jones} +{GRIP - a parallel processor for functional languages} +{Electronics and Power, pp633-636, Oct 1987; +also in ICL Technical Journal 5(3), May 1987} +{ +A brief 4-page article about the GRIP architecture. +} + +\reference{Simon L Peyton Jones, Chris Clack, Jon Salkild, and Mark Hardie} +{GRIP - a high-performance architecture for parallel graph reduction} +{Proc IFIP conference on Functional Programming Languages and +Computer Architecture, Portland, +ed Kahn, Springer Verlag LNCS 274, pp98-112, Sept 1987} +{ +GRIP is a high-performance parallel machine designed to execute +functional programs using supercombinator graph reduction. +It uses a high-bandwidth bus to provide access to a +large, distributed shared memory, using intelligent memory units and +packet-switching protocols to increase the number of processors +which the bus can support. +GRIP is also being programmed to support parallel Prolog and +DACTL. + +We outline GRIP's architecture and firmware, discuss the major design +issues, and describe the current state of the project and +our plans for the future. +} +%86 +\reference{Chris Clack and Simon L Peyton Jones} +{The four-stroke reduction engine} +{Proc ACM Conference on Lisp and Functional Programming, +Boston, pp220-232, Aug 1986} +{ +Functional languages are widely claimed to be amenable to concurrent +execution by multiple processors. This paper presents an algorithm for +the parallel graph reduction of a functional program. +The algorithm supports transparent management of parallel +tasks with no explicit +communication between processors. +} + +\reference{Simon L Peyton Jones} +{Functional programming languages as a software engineering tool} +{in Software Engineering - the critical decade D Ince, +Peter Peregrinus, pp124-151, 1986} +{ +It is the purpose of this paper to suggest that functional +languages are an appropriate tool for supporting the activity +of programming in the large, and to present a justification of +this claim. +} + +\reference{Simon L Peyton Jones} +{Using Futurebus in a fifth generation computer architecture} +{Microprocessors and Microsystems 10(2), March 1986} +{ +Despite the bandwidth limitations of a bus, we present a design +for a parallel computer (GRIP) based on Futurebus, which limits bus +bandwidth requirements by using intelligent memories. + +Such a machine offers higher performance than a uniprocessor +and lower cost than a more extensible multiprocessor, as well +as serving as a vehicle for research in parallel architectures. +} + +\section{Internal reports} + + +\reference{Kevin Hammond} +{A Proposal for an Implementation of Full Dactl on a Meiko Transputer Rack} +{SYS-C89-02, University of East Anglia, 1989} +{ +The design of an abstract machine instruction set for Dactl is +described. The instruction set is sufficient to encapsulate all Dactl +constructs; it will also permit parallel execution where applicable. +The paper considers the difficulties involved in the implementation of +this abstract instruction set on the UEA Meiko M40 transputer rack, +using a ZAPP-style kernel. Part of the code for a simulation of this +instruction set is included as an appendix to the report. +} + + +\reference{Kevin Hammond and John Glauert} +{Implementing Pattern-Matching Functional Languages using Dactl} +{University of Glasgow, 1989} +{ +This paper describes the implementation of a family of pattern-matching +functional languages in the parallel graph-rewriting language Dactl. +Attention is focussed on the direct implementation of the +pattern-matching constructs in the context of various reduction +strategies: eager, lazy, and lazy with strictness analysis. Two new +reduction strategies combining lazy evaluation with a technique for +compiling non-overlapping patterns are also illustrated. The latter +strategies provide improved termination properties compared with +conventional functional language implementations for non-overlapping +patterns. The implementations described here cover all pattern-matching +constructs found in Standard ML, including named patterns and deep +patterns. The use of Dactl renders explicit the complexities of +pattern-matching which are obscured by implementation in a conventional +intermediate language or abstract machine. +} + +\reference{Simon L Peyton Jones} +{A practical technique for designing asynchronous finite-state machines} +{Proc Glasgow Workshop on Functional Programming, Fraserburgh,Aug 1989} +{ +The literature on asynchronous logic design is mostly of a fairly theoretical +nature. We present a practical technique for generating asynchronous finite-state +machines from a description of their states and transitions. The technique +has been used successfully to design a number of state machines in +the GRIP mulitprocessor. +} + +\end{document} diff --git a/ghc/docs/abstracts/reports.tex b/ghc/docs/abstracts/reports.tex new file mode 100644 index 0000000..fc8a332 --- /dev/null +++ b/ghc/docs/abstracts/reports.tex @@ -0,0 +1,111 @@ +\documentstyle[11pt,slpj]{article} + +\newcommand{\reference}[4]{ % authors, title, details, abstract +\large +#1, {\em #2}, #3. +\normalsize +\begin{quotation} +#4 +\end{quotation} +\vspace{0.2in} +} + +\newcommand{\Haskell}[1]{{\sc Haskell}} + +\begin{document} + +\title{Abstracts of GRIP/GRASP-related design documents and manuals \\ +Dept of Computing Science \\ +University of Glasgow G12 8QQ} + +\author{ +Cordelia Hall (cvh@cs.glasgow.ac.uk) \and +Kevin Hammond (kh@cs.glasgow.ac.uk) \and +Will Partain (partain@cs.glasgow.ac.uk) \and +Simon L Peyton Jones (simonpj@cs.glasgow.ac.uk) \and +Phil Wadler (wadler@cs.glasgow.ac.uk) +} + +\maketitle + +\begin{abstract} +This list covers internal design documents and manuals for the GRIP +and GRASP projects. +They are mainly intended for internal consumption, or for brave friends. + +Reports and papers designed for more general consumption are given in +a separate list. + +They of them can be obtained by writing to +Teresa Currie, Dept of Computing Science, +University of Glasgow G12 8QQ, UK. Her electronic mail address is +teresa@uk.ac.glasgow.cs. +\end{abstract} + + +\section{Manuals, design documents and guides} + +\reference{Kevin Hammond and Simon L Peyton Jones} +{Mail server guide} +{Nov 1990} +{ +A guide to the GRIP Mail Server +} + +\reference{Kevin Hammond, Simon L Peyton Jones and Jon Salkild} +{GLOS 2.0 - The GRIP Lightweight Operating System} +{University College London, January 1989} +{ +GLOS is a lightweight multitasking non-preemptive operating +for the GRIP multiprocessor. +This paper describes the operating system from the programmer's point of +view. +} + +\reference{Simon L Peyton Jones and Jon Salkild} +{GRIP system user manual} +{University College London, January 1989} +{ +This document describes how to configure, boot and run the GRIP system, +using the sys2 system mangement program. +} + +\reference{Simon L Peyton Jones} +{The BIP front panel user manual} +{University College London, January 1989} +{ +This document describes {bsim} the program which runs on the GRIP host +Unix machine, and provides a front-panel interface to the BIP. +It assumes familiarity with the BIP architecture. +} + +\reference{Chris Clack} +{The GRIP Intelligent Memory Unit microprogrammer's guide} +{University College London, January 1989} +{ +This paper encapsulates the spectrum of knowledge required to microprogram +the GRIP Intelligent Memory Units (IMUs). It gives a detailed +description of the IMU hardware and its microassembler, together with +the library of predefined microcode macros. +An overview of the the Bus Interface +Processor (BIP) hardware and its interface protocols is also provided. +} + +\reference{Chris Clack} +{Diagnostic control and simulation of GRIP Intelligent Memory Units - the +msH user guide} +{University College London, January 1989} +{ +Software has been written to facilitate interaction with the diagnostic +hardware embedded in each GRIP Intelligent Memory Unit (IMU). +The msS program precisely emulates an IMU, and can be used to help +debug IMU microcode in the absence of real hardware. +The msH program interfaces directly to the actual hardware. +Both msS and msH are driven by the same interactive front panel, which +both acts a command interpreter and manages the display screen. + +The paper is mainly concerned with a description of the front-panel and +how to use it, but also gives a brief overview of the IMU architecture. +} + +\end{document} diff --git a/ghc/docs/abstracts/slpj.sty b/ghc/docs/abstracts/slpj.sty new file mode 100644 index 0000000..9027eab --- /dev/null +++ b/ghc/docs/abstracts/slpj.sty @@ -0,0 +1,41 @@ +% Style file for Simon's documents + +\batchmode +\sloppy + +%**************************************************************** +%* * +%* Page and paragraph format * +%* * +%**************************************************************** + +% Margins and page layout + +\input{a4wide.sty} + +%\setlength{\topmargin}{-1cm} +%\setlength{\oddsidemargin}{-0.5cm} +%\setlength{\evensidemargin}{-0.5cm} +%\setlength{\headheight}{0cm} +%\setlength{\headsep}{0cm} +%\setlength{\textwidth}{17cm} +%\setlength{\textheight}{23.5cm} + +\setlength{\marginparwidth}{1.5cm} + +% Block paragraphs + +\setlength{\parskip}{0.25cm} +\setlength{\parsep}{0.25cm} +\setlength{\topsep}{0cm} % Reduces space before and after verbatim, + % which is implemented using trivlist +\setlength{\parindent}{0cm} + +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + + +\input{useful.sty} + + + diff --git a/ghc/docs/abstracts/useful.sty b/ghc/docs/abstracts/useful.sty new file mode 100644 index 0000000..bc901a3 --- /dev/null +++ b/ghc/docs/abstracts/useful.sty @@ -0,0 +1,186 @@ +%**************************************************************** +%* * +%* GENERALLY USEFUL MACROS * +%* * +%**************************************************************** + + +%**************************************************************** +%* * +%* Some standard abbreviations * +%* * +%**************************************************************** + +% Haskell name +\newcommand{\Haskell}[1]{Haskell} + +% \ba \ea: Abbreviations for begin and end array +% +\newcommand{\ba}{\begin{array}} +\newcommand{\ea}{\end{array}} + + +%**************************************************************** +%* * +%* Keeping text together * +%* * +%**************************************************************** + +% Use \begin{together} (or \bt) +% \end{together} (or \et) +% +% to keep a paragraph together on a single page. + +\newenvironment{together}% + {\begin{flushleft}\begin{minipage}{\textwidth}}% + {\end{minipage}\end{flushleft}} + +\newcommand{\bt}{\begin{together}} +\newcommand{\et}{\end{together}} + + +%**************************************************************** +%* * +%* ToDo macro (cf showtodo.sty) * +%* * +%**************************************************************** + +\newcommand{\ToDo}[1]{} + + +%**************************************************************** +%* * +%* Making boxes round things * +%* * +%**************************************************************** + +% \outline{text} typesets text in a centred framed box of the width +% of the page. +% +\newcommand{\outline}[1]{ + \begin{center} + \fbox{ + \begin{minipage}{\linewidth} + #1 + \end{minipage} + } + \end{center} +} + +%**************************************************************** +%* * +%* Math codes * +%* * +%**************************************************************** + +% The mathcodes for the letters A, ..., Z, a, ..., z are changed to +% generate text italic rather than math italic by default. This makes +% multi-letter identifiers look better. The mathcode for character c +% is set to "7000 (variable family) + "400 (text italic) + c. +% + + +% Old Latex +% +%\def\@setmcodes#1#2#3{{\count0=#1 \count1=#3 +% \loop \global\mathcode\count0=\count1 \ifnum \count0<#2 +% \advance\count0 by1 \advance\count1 by1 \repeat}} +% +%\@setmcodes{`A}{`Z}{"7441} +%\@setmcodes{`a}{`z}{"7461} + + +% Should work with Latex 3.0 +% +%{\catcode`\= 11 +% \gdef\mathrm{\use@mathgroup \=cmr \z@} +% %\gdef\mit{\use@mathgroup \=cmm \@ne} +% \gdef\mit{\use@mathgroup \=cmt \@ne} +% \gdef\cal{\use@mathgroup \=cmsy \tw@} +% } + +\@ifundefined{selectfont} + {} + {\newmathalphabet{\textit} + \addtoversion{normal}{\textit}{cmr}{m}{it} + \addtoversion{bold}{\textit}{cmr}{bx}{it} + \everymath{\textit} + \everydisplay{\textit} + } + +%**************************************************************** +%* * +%* Definitions for macros used in figures * +%* These are produced by fig2dev, so we need defns for them * +%* * +%**************************************************************** + +% These ones work for 11-pt typesetting + +\@ifundefined{selectfont} %DL is MS scheme present? +{}{ +\def\fiverm{\rm\tiny} % Five pt +\def\sevrm{\rm\scriptsize} % Seven pt + +\def\nintt{\tt\footnotesize} +\def\ninrm{\rm\footnotesize} + +\def\tenrm{\rm\small} % Ten pt +\def\tentt{\tt\small} % Ten pt + +\def\elvrm{\rm\normalsize} % Eleven pt +\def\elvit{\em\normalsize} + +\def\twlbf{\bf\large} % Twelve pt +\def\twlit{\em\large} +\def\twltt{\tt\large} +\def\twlrm{\rm\large} +\def\twfvtt{\tt\large} + +\def\frtnrm{\rm\Large} % Fourteen pt +\def\frtnbf{\bf\Large} +\def\frtnit{\em\Large} +\def\frtntt{\tt\Large} + +\def\svtnsf{\sf\huge} % Seventeen pt + + +% cant remember why I need these +\def\egt{\size{8}{9} } +\def\elv{\size{11}{12} } +\def\five{\size{5}{7} } +\def\fiv{\size{5}{6} } +\def\frtn{\size{14}{15} } +\def\nin{\size{9}{10} } +\def\sev{\size{7}{8} } +\def\six{\size{6}{7} } +\def\svtn{\size{17}{18} } +\def\ten{\size{10}{11} } +\def\twfv{\size{25}{27} } +\def\twl{\size{12}{14} } +\def\twty{\size{20}{22} } +} + +%**************************************************************** +%* * +%* Useful symbols * +%* * +%**************************************************************** + + +% Semantic brackets +% +% \leftsembrac [[ left semantic bracket +% \rightsembrac ]] right semantic bracket +% \sembrac{x} [[x]] enclose arg in semantic brackets +% \semfun{E}{x} E[[x]] make E curly +% +\newcommand{\leftsembrac}{[\![} +\newcommand{\rightsembrac}{]\!]} +\newcommand{\sembrac}[1]{\leftsembracb#1\rightsembrac} +\newcommand{\semfun}[2]{{\cal #1}\db{#2}\,} + +% \plusplus ++ run together +% +\def\plusplus{\mathrel{+\!\!\!+}} + diff --git a/ghc/docs/add_to_compiler/Jmakefile b/ghc/docs/add_to_compiler/Jmakefile new file mode 100644 index 0000000..ec85333 --- /dev/null +++ b/ghc/docs/add_to_compiler/Jmakefile @@ -0,0 +1,22 @@ +/* this is a standalone Jmakefile; NOT part of ghc "make world" */ + +DocProcessingSuffixRules() + +SRCS_VERB = \ + paper.verb \ + state-of-play.verb \ + overview.verb \ + overview-fig.verb \ + front-end.verb \ + back-end.verb \ + core-syntax.verb \ + core-summary-fig.verb \ + stg-summary-fig.verb \ + howto-add.verb +SRCS_TEX = $(SRCS_VERB:.verb=.tex) + +docs:: paper.dvi + +paper.dvi: $(SRCS_TEX) + +ExtraStuffToClean( $(SRCS_TEX) ) diff --git a/ghc/docs/add_to_compiler/back-end.verb b/ghc/docs/add_to_compiler/back-end.verb new file mode 100644 index 0000000..2e61e5a --- /dev/null +++ b/ghc/docs/add_to_compiler/back-end.verb @@ -0,0 +1,41 @@ +%************************************************************************ +%* * +\subsection{The back end of the compiler} +\label{sec:back-end} +%* * +%************************************************************************ + +The back end of the compiler begins once the typechecker's +output has been desugared into the so-called Core syntax. Core syntax +is discussed in Section~\ref{sec:core-syntax}. + +We intend the back end to be a sequence of highly effective +CoreSyntax-to-CoreSyntax and STGsyntax-to-STGsyntax transformation +passes, making it possible for the +CoreSyntax$\Rightarrow$StgSyntax$\Rightarrow$Abstract~C (and on to +machine code) denouement to produce really good code. + +{\em It is with these transformation passes that we are hoping for +your enthusiastic help!} There are also some examples in the +GHC distribution, written by people other than the original compiler +authors---so it can be done... + +We already have a pretty good {\em simplifier}\srcloc{simplCore/} to +do local transformations, written mainly by Andr\'e Santos. Among +other things, it unfolds basic arithmetic operations and constants, +exposing the underlying unboxed values. Those interested in the +merits of these transformations should consult Peyton Jones and +Launchbury's paper, ``Unboxed values as first class citizens in a +non-strict functional language'' \cite{peyton-jones91b}. + +The reader interested in the final code-generation parts of the +compiler, from Core syntax to STG syntax\srcloc{stgSyn/CoreToStg.lhs} +to Abstract~C,\srcloc{codeGen/} should consult Peyton Jones's recent +paper, ``Implementing lazy functional languages on stock hardware: the +Spineless Tagless G-machine'' \cite{peyton-jones92a}. + +Further note: We have found that the STG +syntax\srcloc{stgSyn/StgSyn.lhs} is the better medium for a few +transformations.\srcloc{stgSyn/SimplStg.lhs} This is fine---STG syntax +is a just-as-manipulable functional language as Core syntax, even if +it's a bit messier. diff --git a/ghc/docs/add_to_compiler/core-summary-fig.verb b/ghc/docs/add_to_compiler/core-summary-fig.verb new file mode 100644 index 0000000..7e339ea --- /dev/null +++ b/ghc/docs/add_to_compiler/core-summary-fig.verb @@ -0,0 +1,45 @@ +\begin{figure} \fbox{ +$\begin{array}{lrcll} +%\\ +%\mbox{Program} & program & \rightarrow & binds & \\ +%\\ +\mbox{Bindings} & binds & \rightarrow & bind_1@;@ \ldots @;@~bind_n & n \geq 1 \\ + & bind & \rightarrow & @nonrec@~ var ~@=@~ expr \\ + && | & @rec@~ var_1 ~@=@~ expr_1 @;@ \ldots @;@~ var_n ~@=@~ expr_n & n \geq 1 \\ +\\ +\mbox{Expression} & expr + & \rightarrow & expr_1 ~ expr_2 & \mbox{Application} \\ + && | & expr ~ type & \mbox{Type application} \\ + && | & @\@~ var~ @->@ ~ expr & \mbox{Lambda abstraction} \\ + && | & @/\@~ tyvar~ @->@ ~ expr & \mbox{Type abstraction} \\ + && | & @case@ ~expr~ @of@ ~ alts & \mbox{Case expression} \\ + && | & @let@~ bind ~@in@~ expr & \mbox{Local definition(s)} \\ + && | & con~expr_1 \ldots expr_n & \mbox{Saturated constructor} \\ + && | & prim~expr_1 \ldots expr_n & \mbox{Saturated primitive} \\ + && | & var & \mbox{Variable} \\ + && | & literal & \\ +\\ +\mbox{Alternatives} & alts & \rightarrow + & calt_1@;@ \ldots @;@~calt_n@; default ->@~ expr + & n \geq 0~\mbox{(Boxed)} \\ + && | & lalt_1@;@ \ldots @;@~lalt_n@;@~var ~@->@~ expr + & n \geq 0~\mbox{(Unboxed)} \\ +\\ +\mbox{Constructor alt} + & calt & \rightarrow & con~var_1 \ldots var_n~@->@~expr & n \geq 0 \\ +\mbox{Literal alt} + & lalt & \rightarrow & literal~@->@~expr & \\ +\\ +\mbox{Literals} & literal + & \rightarrow & integer & \mbox{machine-level numbers} \\ + && | & \ldots & \\ +\\ +\mbox{Primitives} & prim + & \rightarrow & @+@ ~|~ @-@ ~|~ @*@ ~|~ @/@ & \mbox{machine-level ops} \\ + && | & \ldots & \\ +\\ +\end{array}$ +} +\caption{Abstract syntax of the Core language} +\label{fig:core-syntax} +\end{figure} diff --git a/ghc/docs/add_to_compiler/core-syntax.verb b/ghc/docs/add_to_compiler/core-syntax.verb new file mode 100644 index 0000000..11b80d0 --- /dev/null +++ b/ghc/docs/add_to_compiler/core-syntax.verb @@ -0,0 +1,142 @@ +%************************************************************************ +%* * +\section{Core syntax, and transformations on it} +\label{sec:core-syntax} +%* * +%************************************************************************ + +The @CoreSyntax@ datatype is intended to be the {\em lingua franca} of +the back end of the compiler; a summary is shown in +Figure~\ref{fig:core-syntax}. +\input{core-summary-fig} +As you can see, the Core syntax is a simple +functional language. + +\subsection{Second-order polymorphic lambda calculus} +\label{sec:second-order} + +Core syntax is essentially the second-order polymorphic lambda +calculus. This is reflected in the fact that Core expressions can be +{\em type applications} or {\em type abstractions} (the types in +question are represented as @UniTypes@, of course).\footnote{An +interesting point: there are Core-syntax programs that cannot be +written in Haskell! Core syntax +is the {\em more expressive} language. One could imagine writing a +front end (parser, etc.) for a richer programming language and still +being able to use this compiler's back-end machinery without change.} + +Having explicit type application and abstraction (NB: added by +the typechecker during translation) gives us a uniform, +well-understood, non-{\em ad hoc} way to express the types of +Core expressions. Given that variables (i.e., @Ids@) and other +basic entities have their types memoised in them, it is then easy to +work out the type of {\em any Core expression}. For example, in the +expression\ToDo{example here} +\begin{verbatim} +... ... +\end{verbatim} +@a@ is a type variable, @()@ is a type application, and, assuming +the type of @??@ is $some\ math\ mode\ here...$, then the type of the +expression is @...@. + +The truly great thing about using the second-order polymorphic lambda +calculus is that it is {\em easy to preserve types +in the face of transformation passes}, however drastic their mangling +of the original program. + +\ToDo{example here} + +\subsection{Parameterised and annotated Core syntax} +\label{sec:parameterised-core} + +As we saw with the ``abstract syntax'' (in +Section~\ref{sec:AbsSyntax}), the Core syntax is also {\em +parameterised}, this time with respect to binders and bound-variables +(or ``bindees''). The definition of a Core expression +begins:\srcloc{coreSyn/CoreSyn.lhs} +\begin{tightcode} +data CoreExpr binder bindee + = CoVar bindee + | CoLit CoreLiteral + ... +type PlainCoreBinder = Id +type PlainCoreBindee = Id +type PlainCoreExpr = CoreExpr PlainCoreBinder PlainCoreBindee +\end{tightcode} +Most back-end passes use the parameterisation shown above, namely +@PlainCoreExprs@,\srcloc{coreSyn/PlainCore.lhs} parameterised on @Id@ +for both binders and bindees. + +An example of a pass that uses a different parameterisation is +occurrence analysis,\srcloc{simplCore/OccurAnal.lhs} which gathers +up info about the {\em occurrences} of bound variables. It uses: +\begin{tightcode} +data BinderInfo {\dcd\rm-- various things to record about binders...} +type TaggedBinder tag = (Id, tag) +type TaggedCoreExpr tag = CoreExpr (TaggedBinder tag) Id + +substAnalyseExpr :: PlainCoreExpr -> TaggedCoreExpr BinderInfo +\end{tightcode} +The pass's expression-mangling function then has the unsurprising type +shown above. + +Core syntax has a ``twin'' datatype that is also sometimes useful: +{\em annotated} Core syntax.\srcloc{coreSyn/AnnCoreSyn.lhs} This is a +datatype identical in form to Core syntax, but such that every +``node'' of a Core expression can be annotated with some information +of your choice. As an example, the type of a pass that attaches a +@Set@ of free variables to every subexpression in a Core expression +might be:\srcloc{coreSyn/FreeVars.lhs} +\begin{tightcode} +freeVars :: PlainCoreExpr -> AnnCoreExpr Id Id (Set Id) + {\dcd\rm-- parameterised on binders, bindees, and annotation} +\end{tightcode} + +\subsection{Unboxing and other Core syntax details} +\label{sec:unboxing} + +One facet of the Core syntax summary in Figure~\ref{fig:core-syntax} +that may have caught your eye is the separation of case-alternatives +into those for boxed entities (ordinary data constructors) and unboxed +entities (real machine-level things). The ``literals'' and +``primitives'' mentioned there are also machine-level constructs. It +is for this reason that all applications of constructors and +primitives are {\em saturated}; what use, for example, is +a machine-level addition if you do not +have two arguments to feed to it? (Most machines do not offer curried +arithmetic in their hardware.) + +The handling of unboxed values in the back end of the compiler follows +the design described in the Peyton Jones/Launchbury paper on the +subject \cite{peyton-jones91b}. You, the enthusiastic optimiser, only +need to be aware that this is the ``level of discourse.'' You will +also probably want to be sure that your optimisations can take full +advantage of the explicitness of the unboxery. + +\subsection{``Core Lint''---your dear friend} +\label{sec:core-lint} + +ToDo ToDo + +% \subsection{STG syntax} +% \label{sec:stg-syntax} +% +% As mentioned earlier, the compiler converts Core syntax into ``STG +% syntax'' (named for the Spineless Tagless G-machine) before finally +% making its move into the dark world we call ``Abstract~C''. +% +% Figure~\ref{fig:stg-syntax} shows the STG syntax, +% \input{stg-summary-fig} +% mainly so that you can compare it with Core syntax. (It is at least +% conceivable that you might to perform your optimisation pass at this +% level.) +% +% STG syntax is a truly austere functional language. In places where +% Core syntax allows "exprs", STG syntax insists on "vars"---everything +% has been flattened out. Type information (abstractions and +% applications) have been thrown overboard. Other than that, STG syntax +% is the ``same'' as Core syntax, with some extra non-essential +% annotations on bindings: update flags and free-variable information. +% +% You will want to consult the revised Spineless Tagless G-machine paper +% \cite{peyton-jones92a} if you wish to spend any time in the STG world. diff --git a/ghc/docs/add_to_compiler/front-end.verb b/ghc/docs/add_to_compiler/front-end.verb new file mode 100644 index 0000000..affd2fa --- /dev/null +++ b/ghc/docs/add_to_compiler/front-end.verb @@ -0,0 +1,304 @@ +%************************************************************************ +%* * +\subsection{The front end of the compiler} +\label{sec:front-end} +%* * +%************************************************************************ + +The previous section covered the main points about the front end of +the compiler: it is dominated by a ``renamer'' and a typechecker +working directly at the Haskell source level. In this section, we +will look at some basic datatypes used or introduced in the front +end---ones that you may see as input to your optimisation pass. + +\subsubsection{``Abstract syntax'', a source-level datatype} +\label{sec:AbsSyntax} + +As Figure~\ref{fig:overview} shows, the typechecker both reads and +writes a collection of datatypes we call ``Abstract syntax.'' +This is misleading in that what +goes into the typechecker is quite different from what comes out. + +Let's first consider this fragment of the abstract-syntax +definition,\srcloc{abstractSyn/HsExpr.lhs} for Haskell explicit-list +expressions (Haskell report, section~3.5 +\cite{hudak91a}):\nopagebreak[4] +\begin{tightcode} +data Expr var pat = + ... + | ExplicitList [Expr var pat] + | ExplicitListOut UniType [Expr var pat] + ... + +type ProtoNameExpr = Expr ProtoName ProtoNamePat +type RenamedExpr = Expr Name RenamedPat +type TypecheckedExpr = Expr Id TypecheckedPat +\end{tightcode} +an @ExplicitList@ appears only in typechecker input; an @ExplicitListOut@ +is the corresponding construct that appears +only in the output, with the inferred type information attached. + +The fragment above also shows how abstract syntax is {\em parameterised} +with respect to variables and patterns. The idea is the same for +both; let's just consider variables. + +The renamer converts @ProtoNameExprs@ (expressions with +@ProtoNames@\srcloc{basicTypes/ProtoName.lhs} as variables---little +more than just strings) into @RenamedExprs@, which have all naming sorted out +(using @Names@\srcloc{abstractSyn/Name.lhs}). A @Name@ is known to be +properly bound, isn't duplicated, etc.; it's known if it's bound to a +built-in standard-prelude entity. + +(The renamer also does dependency analysis, which is required to +maximise polymorphism in a Hindley-Milner type system.) + +The typechecker reads the @RenamedExprs@, sorts out the types, and +spits out @TypecheckedExprs@, with variables represented by +@Ids@\srcloc{basicTypes/Id.lhs}. You can find out just about anything +you want to know about a variable from its @Id@. + +To see what GHC makes of some Haskell, in a file @Foo.hs@, say: +try @ghc -noC -ddump-rn4 Foo.hs@, to see what comes out of the renamer [pass~4]; +try @ghc -noC -ddump-tc Foo.hs@, to see what comes out of the typechecker. + +\subsubsection{Basic datatypes in the compiler} + +None of the internal datatypes in the example just given are +particularly interesting except @Ids@.\srcloc{basicTypes/Id.lhs} A +program variable, which enters the typechecker as a string, emerges as +an @Id@. + +The important thing about @Id@---and the datatypes representing other +basic program entities (type variables, type constructors, classes, +etc.)---is that they often include {\em memoised} information that can +be used throughout the rest of the compiler. + +Let us take a cursory look at @Ids@, as a representative example of +these basic data types. (Don't be too scared---@Ids@ are the hairiest +entities in the whole compiler!) +Here we go: +\begin{tightcode}\codeallowbreaks{} +data Id + = Id Unique {\dcd\rm-- key for fast comparison} + UniType {\dcd\rm-- Id's type; used all the time;} + IdInfo {\dcd\rm-- non-essential info about this Id;} + PragmaInfo {\dcd\rm-- user-specified pragmas about this Id;} + IdDetails {\dcd\rm-- stuff about individual kinds of Ids.} +\end{tightcode} + +So, every @Id@ comes with: +\begin{enumerate} +\item +A @Unique@,\srcloc{basicTypes/Unique.lhs} essentially a unique +@Int@, for fast comparison; +\item +A @UniType@ (more on them below... section~\ref{sec:UniType}) giving the variable's +type---this is the most useful memoised information. +\item +A @PragmaInfo@, which is pragmatic stuff the user specified for +this @Id@; e.g., @INLINE@ it; GHC does not promise to honour these +pragma requests, but this is where it keeps track of them. +\item +An @IdInfo@ (more on {\em them} below... section~\ref{sec:IdInfo}), +which tells you all the extra things +that the compiler doesn't {\em have} to know about an @Id@, but it's jolly nice... +This corresponds pretty closely to the @GHC_PRAGMA@ cross-module info that you will +see in any interface produced using @ghc -O@. +An example of some @IdInfo@ +would be: that @Id@'s unfolding; or its arity. +\end{enumerate} + +Then the fun begins with @IdDetails@... +\begin{tightcode}\codeallowbreaks{} +data IdDetails + + {\dcd\rm---------------- Local values} + + = LocalId ShortName {\dcd\rm-- mentioned by the user} + + | SysLocalId ShortName {\dcd\rm-- made up by the compiler} + + {\dcd\rm---------------- Global values} + + | ImportedId FullName {\dcd\rm-- Id imported from an interface} + + | PreludeId FullName {\dcd\rm-- Prelude things the compiler ``knows'' about} + + | TopLevId FullName {\dcd\rm-- Top-level in the orig source pgm} + {\dcd\rm-- (not moved there by transformations).} + + {\dcd\rm---------------- Data constructors} + + | DataConId FullName + ConTag + [TyVarTemplate] ThetaType [UniType] TyCon + {\dcd\rm-- split-up type: the constructor's type is:} + {\dcd\rm-- $\forall~tyvars . theta\_ty \Rightarrow$} + {\dcd\rm-- $unitype_1 \rightarrow~ ... \rightarrow~ unitype_n \rightarrow~ tycon tyvars$} + + | TupleCon Int {\dcd\rm-- its arity} + + {\dcd\rm-- There are quite a few more flavours of {\tt IdDetails}...} +\end{tightcode} + +% A @ShortName@,\srcloc{basicTypes/NameTypes.lhs} which includes a name string +% and a source-line location for the name's binding occurrence; + +In short: everything that later parts of the compiler might want to +know about a local @Id@ is readily at hand. The same principle holds +true for imported-variable and data-constructor @Ids@ (tuples are an +important enough case to merit special pleading), as well as for other +basic program entities. Here are a few further notes about the @Id@ +fragments above: +\begin{itemize} +\item +A @FullName@\srcloc{basicTypes/NameTypes.lhs} is one that may be +globally visible, with a module-name as well; it may have been +renamed. +\item +@DataConKey@\srcloc{prelude/PrelUniqs.lhs} is a specialised +fast-comparison key for data constructors; there are several of these +kinds of things. +\item +The @UniType@ for @DataConIds@ is given in {\em two} ways: once, just as +a plain type; secondly, split up into its component parts. This is to +save frequently re-splitting such types. +\item +Similarly, a @TupleCon@ has a type attached, even though we could +construct it just from the arity. +\end{itemize} + +\subsubsection{@UniTypes@, representing types in the compiler} +\label{sec:UniType} + +Let us look further at @UniTypes@.\srcloc{uniType/} Their definition +is: +\begin{tightcode}\codeallowbreaks{} +data UniType + = UniTyVar TyVar + + | UniFun UniType {\dcd\rm-- function type} + UniType + + | UniData TyCon {\dcd\rm-- non-synonym datatype} + [UniType] + + | UniSyn TyCon {\dcd\rm-- type synonym} + [UniType] {\dcd\rm--\ \ unexpanded form} + UniType {\dcd\rm--\ \ expanded form} + + | UniDict Class {\dcd\rm-- for types with overloading} + UniType + + {\dcd\rm-- The next two are to do with universal quantification.} + | UniTyVarTemplate TyVarTemplate + + | UniForall TyVarTemplate + UniType +\end{tightcode} +When the typechecker processes a source module, it adds @UniType@ +information to all the basic entities (e.g., @Ids@), among other +places (see Section~\ref{sec:second-order} for more details). These +types are used throughout the compiler. + +The following example shows several things about @UniTypes@. +If a programmer wrote @(Eq a) => a -> [a]@, it would be represented +as:\footnote{The internal structures of @Ids@, +@Classes@, @TyVars@, and @TyCons@ are glossed over here...} +\begin{tightcode}\codeallowbreaks{} +UniForall {\dcd$\alpha$} + (UniFun (UniDict {\dcd\em Eq} (UniTyVar {\dcd$\alpha$})) + (UniFun (UniTyVarTemplate {\dcd$\alpha$}) + (UniData {\dcd\em listTyCon} + [UniTyVarTemplate {\dcd$\alpha$}]))) +\end{tightcode} +From this example we see: +\begin{itemize} +\item +The universal quantification of the type variable $\alpha$ is made explicit +(with a @UniForall@). +\item +The class assertion @(Eq a)@ is represented with a @UniDict@ whose +second component is a @UniType@---this +reflects the fact that we expect @UniType@ to be used in a stylized +way, avoiding nonsensical constructs (e.g., +@(UniDict f (UniDict g (UniDict h ...)))@). +\item +The ``double arrow'' (@=>@) of the Haskell source, indicating an +overloaded type, is represented by the usual +@UniFun@ ``single arrow'' (@->@), again in a stylized way. +This change reflects the fact that each class assertion in a +function's type is implemented by adding an extra dictionary argument. +\item +In keeping with the memoising tradition we saw with @Ids@, type +synonyms (@UniSyns@) keep both the unexpanded and expanded forms handy. +\end{itemize} + +\subsubsection{@IdInfo@: extra pragmatic info about an @Id@} +\label{sec:IdInfo} + +[New in 0.16.] All the nice-to-have-but-not-essential information +about @Ids@ is now hidden in the +@IdInfo@\srcloc{basicTypes/IdInfo.lhs} datatype. It looks something +like: +\begin{tightcode}\codeallowbreaks{} +data IdInfo + = NoIdInfo {\dcd\rm-- OK, we know nothing...} + + | MkIdInfo + ArityInfo {\dcd\rm-- its arity} + DemandInfo {\dcd\rm-- whether or not it is definitely demanded} + InliningInfo {\dcd\rm-- whether or not we should inline it} + SpecialisationInfo {\dcd\rm-- specialisations of this overloaded} + {\dcd\rm-- function which exist} + StrictnessInfo {\dcd\rm-- strictness properties, notably} + {\dcd\rm-- how to conjure up ``worker'' functions} + WrapperInfo {\dcd\rm-- ({\em informational only}) if an Id is} + {\dcd\rm-- a ``worker,'' this says what Id it's} + {\dcd\rm-- a worker for, i.e., ``who is my wrapper''} + {\dcd\rm-- (used to match up workers/wrappers)} + UnfoldingInfo {\dcd\rm-- its unfolding} + UpdateInfo {\dcd\rm-- which args should be updated} + SrcLocation {\dcd\rm-- source location of definition} +\end{tightcode} +As you can see, we may accumulate a lot of information about an Id! +(The types for all the sub-bits are given in the same place...) + +\subsubsection{Introducing dictionaries for overloading} + +The major novel feature of the Haskell language is its systematic +overloading using {\em type classes}; Wadler and Blott's paper is the +standard reference \cite{wadler89a}. + +To implement type classes, the typechecker not only checks the Haskell +source program, it also {\em translates} it---by inserting code to +pass around in {\em dictionaries}. These dictionaries +are essentially tuples of functions, from which the correct code may +be plucked at run-time to give the desired effect. Kevin Hammond +wrote and described the first working implementation of type +classes \cite{hammond89a}, and the ever-growing static-semantics paper +by Peyton Jones and Wadler is replete with the glories of dictionary +handling \cite{peyton-jones90a}. (By the way, the typechecker's +structure closely follows the static semantics paper; inquirers into +the former will become devoted students of the latter.) + +Much of the abstract-syntax datatypes are given +over to output-only translation machinery. Here are a few more +fragments of the @Expr@ type, all of which appear only in typechecker +output: +\begin{tightcode} +data Expr var pat = + ... + | DictLam [DictVar] (Expr var pat) + | DictApp (Expr var pat) [DictVar] + | Dictionary [DictVar] [Id] + | SingleDict DictVar + ... +\end{tightcode} +You needn't worry about this stuff: +After the desugarer gets through with such constructs, there's nothing +left but @Ids@, tuples, tupling functions, etc.,---that is, ``plain +simple stuff'' that should make the potential optimiser's heart throb. +Optimisation passes don't deal with dictionaries explicitly but, in +some cases, quite a bit of the code passed through to them will be for +dictionary-handling. diff --git a/ghc/docs/add_to_compiler/howto-add.verb b/ghc/docs/add_to_compiler/howto-add.verb new file mode 100644 index 0000000..c5dfcf6 --- /dev/null +++ b/ghc/docs/add_to_compiler/howto-add.verb @@ -0,0 +1,353 @@ +%************************************************************************ +%* * +\section{How to add an optimisation pass} +%* * +%************************************************************************ +\subsection{Summary of the steps required} + +Well, with all the preliminaries out of the way, here is all that it +takes to add your optimisation pass to the new glorious Glasgow +Haskell compiler: +\begin{enumerate} +\item +Select the input and output types for your pass; these will very +likely be particular parameterisations of the Core or annotated Core +data types. There is a small chance you will prefer to work at the +STG-syntax level. (If these data types are inadequate to this +purpose, {\em please} let us know!) + +\item +Depending on exactly how you want your pass to work, set up some +monad-ery, so as to avoid lots of horrible needless plumbing. The +whole compiler is written in a monadic style, and there are plenty of +examples from which you may steal. Section~\ref{sec:monadic-style} +gives further details about how you might do this. + +\item +Write your optimisation pass, and... + +{\em Do} use the existing types in the compiler, e.g., @UniType@, +and the ``approved'' interfaces to them. + +{\em Don't} rewrite lots of utility code! Scattered around in various +sometimes-obvious places, there is considerable code already written +for the mangling and massaging of expressions, types, variables, etc. + +Section~\ref{sec:reuse-code} says more about how to re-use existing +compiler bits. + +\item +Follow our naming conventions \smiley{} Seriously, it may lead to greater +acceptance of our code and yours if readers find a system written with +at least a veneer of uniformity. +\ToDo{mention Style Guide, if it ever really exists.} + +\item +To hook your pass into the compiler, either add something directly to +the @Main@ module of the compiler,\srcloc{main/Main.lhs} or into the +Core-to-Core simplification driver,\srcloc{simplCore/SimplCore.lhs} or +into the STG-to-STG driver.\srcloc{simplStg/SimplStg.lhs} + +Also add something to the compilation-system +driver\srcloc{ghc/driver/ghc.lprl} +(called @ghc@ here) so that appropriate user-provided command-line +options will be transmogrified into the correct options fed to the +@Main@ module. + +\item +Add some appropriate documentation to the user's guide, +@ghc/docs/users_guide@. + +\item +Run your optimisation on {\em real programs}, measure, and improve. +(Separate from this compiler's distribution, we provide a ``NoFib'' +suite of ``real Haskell programs'' \cite{partain92a}. We strongly +encourage their use, so you can more readily compare your work with +others'.) + +\item +Send us your contribution so we can add it to the distribution! We +will be happy to include anything semi-reasonable. +This will practically ensure fame, if +not fortune, and---with a little luck---considerable notoriety. +\end{enumerate} + +%************************************************************************ +%* * +\subsection{Using monadic code}\label{sec:monadic-style} +%* * +%************************************************************************ + +{\em Monads} are one way of structuring functional programs. Phil +Wadler is their champion, and his recent papers on the subject are a +good place to start your investigations. ``The essence of functional +programming'' even has a section about the use of monads in this +compiler \cite{wadler92a}! An earlier paper describes ``monad +comprehensions'' \cite{wadler90a}. For a smaller self-contained +example, see his ``literate typechecker'' \cite{wadler90b}. + +We use monads extensively in this compiler, mainly as a way to plumb +state around. The simplest example is a monad to plumb a +@UniqueSupply@\srcloc{basicTypes/Unique.lhs} (i.e., name supply) +through a function. + +\ToDo{Actually describe one monad thing completely.} + +We encourage you to use a monadic style, where appropriate, in +the code you add to the compiler. To this end, here is a list of +monads already in use in the compiler: +\begin{description} +\item[@UniqueSupply@ monad:] \srcloc{basicTypes/Unique.lhs} +To carry a name supply around; do a @getUnique@ when you +need one. Used in several parts of the compiler. + +\item[Typechecker monad:] \srcloc{typecheck/TcMonad.lhs} +Quite a complicated monad; carries around a substitution, some +source-location information, and a @UniqueSupply@; also plumbs +typechecker success/failure back up to the right place. + +\item[Desugarer monad:] \srcloc{deSugar/DsMonad.lhs} +Carries around a @UniqueSupply@ and source-location information (to +put in pattern-matching-failure error messages). + +\item[Code-generator monad:] \srcloc{codeGen/CgMonad.lhs} +Carries around an environment that maps variables to addressing modes +(e.g., ``in this block, @f@ is at @Node@ offset 3''); also, carries +around stack- and heap-usage information. Quite tricky plumbing, in +part so that the ``Abstract~C'' output will be produced lazily. + +\item[Monad for underlying I/O machinery:] \srcloc{ghc/lib/io/GlaIOMonad.lhs} +This is the basis of our I/O implementation. See the paper about it +\cite{peyton-jones92b}. +\end{description} + +%************************************************************************ +%* * +\subsection{Adding a new @PrimitiveOp@}\label{sec:add-primop} +%* * +%************************************************************************ + +You may find yourself wanting to add a new +@PrimitiveOp@\srcloc{prelude/PrimOps.lhs} to the compiler's +repertoire: these are the lowest-level operations that cannot be +expressed in Haskell---in our case, things written in C. + +What you would need to do to add a new op: +\begin{itemize} +\item +Add it to the @PrimitiveOp@ datatype in @prelude/PrimOps.lhs@; it's +just an enumeration type. +\item +Most importantly, add an entry in the @primOpInfo@ function for your +new primitive. +\item +If you want your primitive to be visible to some other part of the +compiler, export it via the @AbsPrel@\srcloc{prelude/AbsPrel.lhs} +interface (and import it from there). +\item +If you want your primitive to be visible to the user (modulo some +``show-me-nonstd-names'' compiler flag...), add your primitive to one +or more of the appropriate lists in @buildinNameFuns@, in +@prelude/AbsPrel.lhs@. +\item +If your primitive can be implemented with just a C macro, add it to +@ghc/imports/StgMacros.lh@. If it needs a C function, put that in +@ghc/runtime/prims/@, somewhere appropriate; you might need to put a +declaration of some kind in a C header file in @ghc/imports/@. +\item +If these steps are not enough, please get in touch. +\end{itemize} + +%************************************************************************ +%* * +\section{How to add a new ``PrimOp'' (primitive operation)} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\section{How to add a new ``user pragma''} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\section{GHC utilities and re-usable code}\label{sec:reuse-code} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection{Reuse existing utilities} +%* * +%************************************************************************ + +Besides the utility functions provided in Haskell's standard prelude, +we have several modules of generally-useful utilities in \mbox{\tt utils/} +(no need to re-invent them!): +\begin{description} +\item[@Maybe@ and @MaybeErr@:] +Two very widely used types (and some operations on them): +\begin{verbatim} +data Maybe a = Nothing | Just a +data MaybeErr a b = Succeeded a | Failed b +\end{verbatim} + +\item[@Set@:] +A simple implementation of sets (an abstract type). The things you +want to have @Sets@ of must be in class @Ord@. + +\item[@ListSetOps@:] +A module providing operations on lists that have @Set@-sounding names; +e.g., @unionLists@. + +\item[@Digraph@:] +A few functions to do with directed graphs, notably finding +strongly-connected components (and cycles). + +\item[@Util@:] +General grab-bag of utility functions not provided by the standard +prelude. +\end{description} + +Much of the compiler is structured around major datatypes, e.g., +@UniType@ or @Id@. These datatypes (often ``abstract''---you can't +see their actual constructors) are packaged with many useful +operations on them. So, again, look around a little for these +functions before rolling your own. Section~\ref{sec:reuse-datatypes} +goes into this matter in more detail. + +%************************************************************************ +%* * +\subsection{Use pretty-printing and forcing machinery} +%* * +%************************************************************************ + +All of the non-trivial datatypes in the compiler are in class +@Outputable@, meaning you can pretty-print them (method: @ppr@) or +force them (method: @frc@). + +Pretty-printing is by far the more common operation. @ppr@ takes a +``style'' as its first argument; it can be one of @PprForUser@, +@PprDebug@, or @PprShowAll@, which---in turn---are intended to show +more and more detail. For example, @ppr PprForUser@ on a @UniType@ +should print a type that would be recognisable to a Haskell user; +@ppr PprDebug@ prints a type in the way an implementer would normally +want to see it (e.g., with all the ``for all...''s), and +@ppr PprShowAll@ prints everything you could ever want to know about that +type. + +@ppr@ produces a @Pretty@, which should eventually wend its way to +@main@. @main@ can then peruse the program's command-line options to +decide on a @PprStyle@ and column width in which to print. In +particular, it's bad form to @ppShow@ the @Pretty@ into a @String@ +deep in the bowels of the compiler, where the user cannot control the +printing. + +If you introduce non-trivial datatypes, please make them instances of +class @Outputable@. + +%************************************************************************ +%* * +\subsection{Use existing data types appropriately}\label{sec:reuse-datatypes} +%* * +%************************************************************************ + +The compiler uses many datatypes. Believe it or not, these have +carefully structured interfaces to the ``outside world''! Unfortunately, +the current Haskell module system does not let us enforce proper +access to these datatypes to the extent we would prefer. Here is a +list of datatypes (and their operations) you should feel free to use, +as well as how to access them. + +The first major group of datatypes are the ``syntax datatypes,'' the +various ways in which the program text is represented as it makes its +way through the compiler. These are notable in that you are allowed +to see/make-use-of all of their constructors: +\begin{description} +\item[Prefix form:]\srcloc{reader/PrefixSyn.lhs} You shouldn't need +this. + +\item[Abstract Haskell syntax:]\srcloc{abstractSyn/AbsSyn.lhs} Access +via the @AbsSyn@ interface. An example of what you should {\em not} +do is import the @AbsSynFuns@ (or @HsBinds@ or ...) interface +directly. @AbsSyn@ tells you what you're supposed to see. + +\item[Core syntax:]\srcloc{coreSyn/*Core.lhs} Core syntax is +parameterised, and you should access it {\em via one of the +parameterisations}. The most common is @PlainCore@; another is +@TaggedCore@. Don't use @CoreSyn@, though. + +\item[STG syntax:]\srcloc{stgSyn/StgSyn.lhs} Access via the @StgSyn@ interface. + +\item[Abstract~C syntax:]\srcloc{absCSyn/AbsCSyn.lhs} Access via the +@AbsCSyn@ interface. +\end{description} + +The second major group of datatypes are the ``basic entity'' +datatypes; these are notable in that you don't need to know their +representation to use them. Several have already been mentioned: +\begin{description} +\item[UniTypes:]\srcloc{uniType/AbsUniType.lhs} This is a gigantic +interface onto the world of @UniTypes@; accessible via the +@AbsUniType@ interface. You should import operations on all the {\em +pieces} of @UniTypes@ (@TyVars@, @TyVarTemplates@, @TyCons@, +@Classes@, and @ClassOps@) from here as well---everything for the +``type world.'' + +{\em Please don't grab type-related functions from internal modules, +behind @AbsUniType@'s back!} (Otherwise, we won't discover the +shortcomings of the interface...) + +\item[Identifiers:]\srcloc{basicTypes/Id.lhs} Interface: @Id@. + +\item[``Core'' literals:]\srcloc{basicTypes/CoreLit.lhs} These are +the unboxed literals used in Core syntax onwards. Interface: @CoreLit@. + +\item[Environments:]\srcloc{envs/GenericEnv.lhs} +A generic environment datatype, plus a generally useful set of +operations, is provided via the @GenericEnv@ interface. We encourage +you to use this, rather than roll your own; then your code will +benefit when we speed up the generic code. All of the typechecker's +environment stuff (of which there is plenty) is built on @GenericEnv@, +so there are plenty of examples to follow. + +\item[@Uniques@:]\srcloc{basicTypes/Unique.lhs} Essentially @Ints@. +When you need something unique for fast comparisons. Interface: +@Unique@. This interface also provides a simple @UniqueSupply@ monad; +often just the thing... + +\item[Wired-in standard prelude knowledge:]\srcloc{prelude/} The +compiler has to know a lot about the standard prelude. What it knows +is in the @compiler/prelude@ directory; all the rest of the compiler +gets its prelude knowledge through the @AbsPrel@ interface. + +The prelude stuff can get hairy. There is a separate document about +it. Check the @ghc/docs/README@ list for a pointer to it... +\end{description} + +The above list isn't exhaustive. By all means, ask if you think +``Surely a function like {\em this} is in here somewhere...'' + + +%************************************************************************ +%* * +\section{Cross-module pragmatic info: the mysteries revealed} +%* * +%************************************************************************ + +ToDo: mention wired-in info. + +%************************************************************************ +%* * +\section{GHC hacking tips and ``good practice''} +%* * +%************************************************************************ + +ASSERT + +%************************************************************************ +%* * +\section{Glasgow pragmatics: build trees, etc.} +%* * +%************************************************************************ diff --git a/ghc/docs/add_to_compiler/overview-fig.fig b/ghc/docs/add_to_compiler/overview-fig.fig new file mode 100644 index 0000000..a68a0da --- /dev/null +++ b/ghc/docs/add_to_compiler/overview-fig.fig @@ -0,0 +1,136 @@ +#FIG 2.1 +80 2 +6 264 49 379 119 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 312 69 376 69 376 101 312 101 312 69 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 272 93 328 117 344 117 344 101 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 344 69 344 53 328 53 268 73 9999 9999 +-6 +6 269 149 384 219 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 317 169 381 169 381 201 317 201 317 169 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 277 193 333 217 349 217 349 201 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 349 169 349 153 333 153 273 173 9999 9999 +-6 +1 1 0 1 -1 0 0 0 0.000 1 0.000 82 324 49 17 82 324 129 340 +1 1 0 1 -1 0 0 0 0.000 1 0.000 80 36 49 17 80 36 128 52 +1 1 0 1 -1 0 0 0 0.000 1 0.000 82 228 49 17 82 228 129 244 +1 1 0 1 -1 0 0 0 0.000 1 0.000 82 419 49 17 82 419 129 435 +1 1 0 1 -1 0 0 0 0.000 1 0.000 79 133 49 17 79 133 127 149 +1 1 0 1 -1 0 0 0 0.000 1 0.000 235 180 49 17 235 180 283 196 +1 1 0 1 -1 0 0 0 0.000 1 0.000 232 372 49 17 232 372 280 388 +1 1 0 1 -1 0 0 0 0.000 1 0.000 233 276 49 17 233 276 281 292 +1 1 0 1 -1 0 0 0 0.000 1 0.000 232 85 49 17 232 85 280 101 +1 1 0 1 -1 0 0 0 0.000 1 0.000 233 467 49 17 233 467 281 483 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 292 81 308 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 244 81 260 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 33 260 129 260 129 292 33 292 33 260 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 33 164 129 164 129 196 33 196 33 164 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 101 81 117 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 53 81 69 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 148 81 164 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 196 81 212 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 33 69 129 69 129 101 33 101 33 69 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 33 356 129 356 129 388 33 388 33 356 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 33 451 129 451 129 483 33 483 33 451 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 388 81 403 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 435 81 451 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 340 81 356 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 81 483 81 499 161 499 161 49 212 49 212 69 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 185 308 280 308 280 340 185 340 185 308 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 37 232 69 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 101 232 117 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 185 117 280 117 280 148 185 148 185 117 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 185 403 280 403 280 435 185 435 185 403 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 196 232 212 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 244 232 260 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 292 232 308 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 340 232 356 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 388 232 403 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 435 232 451 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 232 148 232 164 9999 9999 +2 1 0 1 -1 0 0 0 0.000 0 1 0 + 0 0 1.000 4.000 8.000 + 272 284 312 308 9999 9999 +2 2 0 1 -1 0 0 0 0.000 0 0 0 + 189 212 284 212 284 244 189 244 189 212 9999 9999 +2 4 0 3 -1 0 0 0 0.000 7 0 0 + 13 13 13 515 400 515 400 13 13 13 9999 9999 +4 0 0 10 0 -1 0 0.000 4 10 45 61 328 AbsSyntax +4 0 0 10 0 -1 0 0.000 4 7 60 53 41 Haskell source +4 0 0 10 0 -1 0 0.000 4 10 45 61 232 AbsSyntax +4 0 0 10 0 -1 0 0.000 4 10 50 57 376 Typechecker +4 0 0 10 0 -1 0 0.000 4 10 45 61 423 AbsSyntax +4 0 0 10 0 -1 0 0.000 4 10 42 57 471 Desugarer +4 0 0 10 0 -1 0 0.000 4 7 43 61 137 Prefix form +4 0 0 10 0 -1 0 0.000 4 7 29 69 184 Reader +4 0 0 10 0 -1 0 0.000 4 7 36 65 280 Renamer +4 0 0 10 0 -1 0 0.000 4 7 38 216 232 CodeGen +4 0 0 10 0 -1 0 0.000 4 8 43 308 328 generators +4 0 0 10 0 -1 0 0.000 4 7 44 308 320 Other code +4 0 0 10 0 -1 0 0.000 4 10 43 212 137 CoreToStg +4 0 0 10 0 -1 0 0.000 4 10 47 212 89 CoreSyntax +4 0 0 10 0 -1 0 0.000 4 10 41 212 184 StgSyntax +4 0 0 10 0 -1 0 0.000 4 7 44 208 280 Abstract C +4 0 0 10 0 -1 0 0.000 4 7 30 216 328 Flatten +4 0 0 10 0 -1 0 0.000 4 7 6 228 376 C +4 0 0 10 0 -1 0 0.000 4 10 42 212 423 C compiler +4 0 0 10 0 -1 0 0.000 4 7 48 212 471 Native code +4 0 0 10 0 -1 0 0.000 4 10 32 328 89 Simplify +4 0 0 10 0 -1 0 0.000 4 7 65 201 33 Other front ends +4 0 0 10 0 -1 0 0.000 4 10 65 42 89 Lex/Yacc parser +4 0 0 10 0 -1 0 0.000 4 10 32 333 189 Simplify diff --git a/ghc/docs/add_to_compiler/overview.verb b/ghc/docs/add_to_compiler/overview.verb new file mode 100644 index 0000000..32e0c4a --- /dev/null +++ b/ghc/docs/add_to_compiler/overview.verb @@ -0,0 +1,70 @@ +%************************************************************************ +%* * +\section{Overview of the Glasgow Haskell compiler} +%* * +%************************************************************************ + +Figure~\ref{fig:overview} shows a schematic overview of the Glasgow +Haskell compiler (GHC), including all the major datatypes and most +existing passes. +\begin{figure} +\centering +\input{overview-fig} +%\psfig{figure=closure.ps} +\caption{Compiler overview} +\label{fig:overview} +\end{figure} +The compiler is itself written in Haskell. As of now, the compiler is +made up of about 200?~modules, with roughly 40,000?~lines of +Haskell code, excluding comments and blank lines. + +The compiler divides unsurprisingly into a {\em front end} and a {\em +back end}, corresponding to the left and right columns of +Figure~\ref{fig:overview}, respectively. + +The front end, discussed further in Section~\ref{sec:front-end}, is +the part that may report errors back to the user. The two main pieces +are a {\em renamer},\srcloc{renamer/} which handles naming issues, +including support of the Haskell module system, and the {\em +typechecker}.\srcloc{typecheck/} + +The front end operates on a collection of data types that we call +``abstract syntax.''\srcloc{abstractSyn/} These types +match the Haskell language, construct for construct. For example, +if you write @... [ x | x <- [1..n] ] ...@, the typechecker +will actually see something like: +\begin{verbatim} +ListComp + (Var x) + (GeneratorQual (VarPatIn x) + (ArithSeq (FromTo (Lit (IntLit 1)) (Var n)))) +\end{verbatim} +So, the renamer and typechecker work on unrestructured Haskell source +rather than its desugared equivalent. The compiler should be {\em +quicker} to find errors (because the source is much smaller and time +hasn't been taken desugaring), and it should report errors more +lucidly, in terms of the original program text. + +A conventional desugaring pass\srcloc{deSugar/} (basically Wadler's +Chapter~5 of Peyton Jones's 1987 implementation book +\cite{peyton-jones87b}) converts the typechecker's abstract-syntax output +(with types attached) into the ``CoreSyntax''\srcloc{coreSyn/} data +type. This data type is little more than the second-order polymorphic +lambda calculus and is intended to be the {\em lingua franca} of the +compiler's back end, including almost all of the optimisation passes. +Core syntax is explained at length in Section~\ref{sec:core-syntax}. + +The back end of the compiler, discussed further in +Section~\ref{sec:back-end}, takes a successfully-typechecked module +and produces executable code for it. The back end consists of zero or +more Core-to-Core transformation passes, followed by conversion to STG +syntax\srcloc{stgSyn/} (a very low-level functional language, named +after the intended Spineless Tagless G-machine\footnote{Oops! Make +that ``shared term graph'' language! (Who's fooling who here, +Simon?)} target architecture), then some STG-to-STG transformations, +and finally out of the functional world\srcloc{codeGen/} into +``Abstract~C,''\srcloc{absCSyn/} a datatype intended as an adequate +launching pad into both portable C and into get-your-hands-{\em +really}-dirty native-code generation for a particular instruction-set +architecture. We can generate C, or native-code for SPARCs and DEC +Alphas. diff --git a/ghc/docs/add_to_compiler/paper.bbl b/ghc/docs/add_to_compiler/paper.bbl new file mode 100644 index 0000000..7f2437a --- /dev/null +++ b/ghc/docs/add_to_compiler/paper.bbl @@ -0,0 +1,72 @@ +\begin{thebibliography}{10} + +\bibitem{hudak91a} +Report on the programming language {Haskell}, a non-strict purely functional + language ({Version} 1.1), August, 1991. +\newblock Computing Science Department, Glasgow University, forthcoming. + +\bibitem{hammond89a} +Kevin Hammond. +\newblock Implementing type classes for {Haskell}. +\newblock In {\em Proceedings of the Glasgow Workshop on Functional + Programming}, page ????, Fraserburgh, Scotland, August, 1989. + +\bibitem{partain92a} +Will Partain. +\newblock The {\tt nofib} benchmark suite of {Haskell} programs, 1992. + +\bibitem{peyton-jones87b} +Simon~L. {Peyton Jones}. +\newblock {\em The Implementation of Functional Programming Languages}. +\newblock Prentice-Hall, 1987. + +\bibitem{peyton-jones92a} +Simon~L. {Peyton Jones}. +\newblock Implementing lazy functional languages on stock hardware: the + {Spineless Tagless G-machine}. +\newblock {\em Journal of Functional Programming}, 1992. +\newblock To appear. + +\bibitem{peyton-jones91b} +Simon~L. {Peyton Jones} and John Launchbury. +\newblock Unboxed values as first class citizens in a non-strict functional + language. +\newblock In John Hughes, editor, {\em Functional Programming Languages and + Computer Architecture (FPCA)}, volume 523 of {\em Lecture Notes in Computer + Science}, pages 636--666, Cambridge, MA, August 26--30, 1991. + Springer-Verlag. + +\bibitem{peyton-jones90a} +Simon~L. {Peyton Jones} and Philip Wadler. +\newblock A static semantics for {Haskell}, 1990. +\newblock Dept.~of Computing Science, University of Glasgow. + +\bibitem{peyton-jones92b} +Simon~L. {Peyton Jones} and Philip Wadler. +\newblock Imperative functional programming (extended abstract), 1992. +\newblock To be in POPL~'93. + +\bibitem{wadler90a} +Philip Wadler. +\newblock Comprehending monads. +\newblock In {\em Proceedings of the 1990 ACM Conference on {LISP} and + Functional Programming}, pages 61--78, Nice, France, June 27--29, 1990. + +\bibitem{wadler90b} +Philip Wadler. +\newblock A simple type inference algorithm, 1990. +\newblock Dept.~of Computing Science, University of Glasgow. + +\bibitem{wadler92a} +Philip Wadler. +\newblock The essence of functional programming. +\newblock In {\em 19th ACM Symposium on Principles of Programming Languages + (POPL)}, page ?????, Santa Fe, NM, January ????, 1992. + +\bibitem{wadler89a} +Philip~L. Wadler and Stephen Blott. +\newblock How to make {\em ad-hoc\/} polymorphism less {\em ad hoc\/}. +\newblock In {\em 16th ACM Symposium on Principles of Programming Languages + (POPL)}, pages 60--76, Austin, TX, January 11--13, 1989. + +\end{thebibliography} diff --git a/ghc/docs/add_to_compiler/paper.verb b/ghc/docs/add_to_compiler/paper.verb new file mode 100644 index 0000000..39a82c6 --- /dev/null +++ b/ghc/docs/add_to_compiler/paper.verb @@ -0,0 +1,77 @@ +\documentstyle[11pt,../grasp,code]{article} +%\documentstyle[12pt,springer-wcs,oldfontnames,code]{article} +\setlength{\marginparwidth}{1.5cm} +\setlength{\parskip}{0.25cm} +\setlength{\parindent}{0cm} +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} +% +\newcommand{\freevars}[1]{fvs(#1)} +% +% to avoid src-location marginpars, comment in/out the out/in defns. +%\newcommand{\srcloc}[1]{} +%\newcommand{\onlyIfSrcLocs}[1]{} +% +\newcommand{\onlyIfSrcLocs}[1]{#1} +% +\begin{document} +\title{How to Add an Optimisation Pass\\ +to the Glasgow Haskell compiler\\ +(two months before version~0.23)} +\author{Will Partain, acting as AQUA Project scribe\\ +e-mail contact: partain@@dcs.glasgow.ac.uk} +\renewcommand{\today}{October, 1994} +\maketitle +% temporarily.... +\tableofcontents +%\clearpage +\begin{abstract} +A major purpose of the new Glasgow Haskell compiler (written in +Haskell) is to be freely available in source form so that others can +use it as ``root stock'' onto which they may graft their own wonderful +bits. This document is a field guide for the aspiring +better-compiler grower, particularly one who wishes to add an +optimisation pass. +\end{abstract} + +\onlyIfSrcLocs{Throughout this paper, pointers to the relevant +source-code are given in the margins. This code is in the {\tt +ghc/compiler/} part of the distribution; names ending in {\tt /} are +directories. We assume you already know Haskell.} + +% \input{state-of-play} + +\input{overview} + +\input{front-end} +\input{back-end} + +\input{core-syntax} + +\input{howto-add} + +%************************************************************************ +%* * +\section{For further information} +%* * +%************************************************************************ + +Besides the documents listed in the References below, there are +several internal compiler documents that come with the GHC +distribution.\srcloc{ghc/docs/README} + +If you are hacking GHC, you should be on the @glasgow-haskell-users@ +mailing list. Send mail to +@glasgow-haskell-users-request@@dcs.glasgow.ac.uk@ to subscribe. +You may wish to subscribe to our ``bugs channel'' ( +@glasgow-haskell-bugs-request@@dcs.glasgow.ac.uk@) as well, if you +are a glutton for punishment. + +Further suggestions as to how we can make your job easier will be most +appreciated. + +\bibliographystyle{wpplain} % wpplain, wplong, wpannote, ... +\bibliography{wp_abbrevs,comp} + +%\printindex +\end{document} diff --git a/ghc/docs/add_to_compiler/slides-root.tex b/ghc/docs/add_to_compiler/slides-root.tex new file mode 100644 index 0000000..163cc3d --- /dev/null +++ b/ghc/docs/add_to_compiler/slides-root.tex @@ -0,0 +1,8 @@ +\documentstyle{slides} +\pagestyle{empty} +%\onlyslides{1-99} +%\onlynotes{1-99} +\begin{document} +\blackandwhite{slides} +%\input{slides} +\end{document} diff --git a/ghc/docs/add_to_compiler/slides.tex b/ghc/docs/add_to_compiler/slides.tex new file mode 100644 index 0000000..947adcb --- /dev/null +++ b/ghc/docs/add_to_compiler/slides.tex @@ -0,0 +1,86 @@ +%01 title +\begin{slide}{} +\begin{center} +{\Large +How To Add\\ +An Optimisation Pass To\\ +The Glasgow Haskell Compiler\\[40pt] +} +{\large +Will Partain\\ +(GRASP Project scribe) +} +\end{center} +\end{slide} + +%02 hello, world +\begin{slide}{} +{\Large The state of play} + +\begin{verbatim} +sun3% time gcc -c hello.c +0.240u 0.520s 0:01.00 76.0% 0+51k 0+9io 0pf+0w + +sun3% time nlmlc -c hello.m +3.320u 1.740s 0:05.65 89.5% 0+240k 1+21io 1pf+0w + +sun3% time nhc -c hello.hs +26.680u 2.860s 0:32.00 92.3% 0+950k 2+31io 18pf+0w + +sun3% time do100x # C +6.980u 7.880s 0:14.93 99.5% 0+50k 0+0io 0pf+0w + +sun3% time do100x # LML +7.880u 10.500s 0:18.50 99.3% 0+57k 1+0io 1pf+0w + +sun3% time do100x # haskell +7.760u 10.440s 0:18.48 98.4% 0+56k 1+0io 1pf+0w +\end{verbatim} +\end{slide} +%% % time hello100 > /dev/null +%% 0.060u 0.100s 0:00.16 100.0% 0+51k 0+0io 0pf+0w + +%03 analyses +\begin{slide}{} +{\Large Analyses (FPCA~'89, PLDI~'91)} + +binding-time analysis\\ +closure analysis\\ +complexity analysis\\ +demand analysis\\ +facet analysis\\ +interference analysis\\ +lifetime analysis\\ +liveness analysis\\ +path analysis\\ +polymorphic-instance analysis\\ +stacklessness anaysis\\ +strictness analysis\\ +time analysis\\ +update analysis +\end{slide} + +\begin{note} +Contrast with conventional-compiler concerns: + +use of runtime feedback\\ +matching w/ low-level hardware concerns\\ +work very hard for their extra information +\end{note} + +\begin{slide}{} +{\Large Optimisations in use: LML} + +\begin{itemize} +\item +constant folding, arithmetic simplification +\item +many local transformations (case of case...) +\item +inlining, $\beta$-reduction +\item +strictness analysis +\item +G-code and m-code optimisation +\end{itemize} +\end{slide} diff --git a/ghc/docs/add_to_compiler/state-of-play.NOTES b/ghc/docs/add_to_compiler/state-of-play.NOTES new file mode 100644 index 0000000..cdfa7d8 --- /dev/null +++ b/ghc/docs/add_to_compiler/state-of-play.NOTES @@ -0,0 +1,73 @@ +analyses: + strictness & binding-time analysis (\cite{launchbury91a}) + polymorphic-instance analysis (pldi 91; referred \cite{launchbury91a}, p 86 top left) + facet analysis (part of [higher-order offline] parameterized partial evaluation) + (pldi 91: \cite{consel91a}) + binding-time analysis (fpca89; \cite{mogensen91}) + strictness analysis (\cite{wadler87a}) + update analysis (fpca; \cite{bloss89b}) + path analysis (fpca; \cite{bloss89b}) + interference, closure, and lifetime analysis (fpca; \cite{sestoft89a}) + stacklessness anaysis (fpca; \cite{lester89b}) + liveness analysis (AHU, reffed by lester89b) + complexity analysis (fpca, \cite{rosendahl89a}) + demand analysis + time analysis + +type systems: + refinement types (pldi 91; \cite{freeman91a}) + soft typing (pldi 91; \cite{cartwright91a}) + +other: + +done in LML compiler: + llift lambda lifter + /Bconv + simpl + /asimpl arithmetic simplifications + /casetr case of case ... (& a couple of others ?) + /mlet mlet (inlining) ? + /simpl constant folding, casefold, Esimpl, simpl, + force arity, movelam + strict very simple strictness analysis + transform + /case caseelim + /casep condjoin + /constr constrtr + /lettrans let transformations + unrec + Gopt G-code optimiser + mopt m-code optimiser + +done in yale compiler: + (in flic) + optimization : \beta-redn (constant propagation & inlining) + constant folding + dead code elim + strictness analysis + +the competition: + + (mips compiler) + compiles to "ucode" (symbolic assembler) + optimisations on both ucode and binary assembler + -O2 global ucode optimizer + -O3 global register alloc + -feedback file + -cord procedure re-arranger ; reduce cache conflicts + pixie adds things to binary for profiling + pixstats generate exec stats from a pixified pgm + prof analyse profile data (pc-sampling, basic-blk counting) + + data dependence analysis (pldi 91; \cite{maydan91a}) + (nice table of stats-- pldi 91; \cite{goff91a}, p 25) + + tiling for better cache hits (pldi 91: \cite{wolf91a}) + + using real or estimated runtime profiles (pldi 91: \cite{wall91a}) + + procedure merging w/ instruction caches (pldi 91: \cite{mcfarling91a}) + + fortran @ 10 Gflops (pldi 91: \cite{bromley91a}) + + global instr scheduling for superscalar machines (pldi 91: \cite{bernstein91a}) diff --git a/ghc/docs/add_to_compiler/state-of-play.verb b/ghc/docs/add_to_compiler/state-of-play.verb new file mode 100644 index 0000000..301b252 --- /dev/null +++ b/ghc/docs/add_to_compiler/state-of-play.verb @@ -0,0 +1,14 @@ +%************************************************************************ +%* * +\section{The state of play} +%* * +%************************************************************************ + +\ToDo{This section will describe the state of play: where +functional-language compilers are; compared to their imperative +cousins.} + +%The burden of proof remains with us functional programmers. We +%encourage you to help solve this problem by contributing compiler +%passes that optimise real programs written in a standard non-toy +%language effectively. diff --git a/ghc/docs/add_to_compiler/stg-summary-fig.verb b/ghc/docs/add_to_compiler/stg-summary-fig.verb new file mode 100644 index 0000000..99dad9c --- /dev/null +++ b/ghc/docs/add_to_compiler/stg-summary-fig.verb @@ -0,0 +1,55 @@ +\begin{figure} \fbox{ +$\begin{array}{lrcll} +%\mbox{Program} & prog & \rightarrow & binds & \\ +%\\ +\mbox{Bindings} & binds & \rightarrow + & bind_1 @;@ \ldots @;@~ bind_n & n \geq 1 \\ +& bind & \rightarrow & var ~@=@~ vars_f ~@\@ upd~ vars_a ~@->@~expr + & \mbox{Closure} \\ + &&&& (vars_f = \freevars{expr} \setminus vars_a) \\ +\\ +\mbox{Update flag} & upd & \rightarrow & @u@ & \mbox{Updatable} \\ + && | & @n@ & \mbox{Not updatable} \\ +\\ +\mbox{Expression} & expr + & \rightarrow & @let@~binds~@in@~ expr + & \mbox{Local definition} \\ + && | & @letrec@~binds~@in@~expr + & \mbox{Local recursive definition} \\ + && | & @case@~expr~@of@~alts + & \mbox{Case expression} \\ + && | & var~vars & \mbox{Application}\\ + && | & con~vars + & \mbox{Saturated constructor} \\ + && | & prim~vars + & \mbox{Saturated primitive} \\ + && | & literal & \\ +\\ + +\mbox{Alternatives} & alts & \rightarrow + & calt_1@;@ \ldots @;@~calt_n@; default ->@~ expr + & n \geq 0~\mbox{(Boxed)} \\ + && | & lalt_1@;@ \ldots @;@~lalt_n@;@~var ~@->@~ expr + & n \geq 0~\mbox{(Unboxed)} \\ +\\ +\mbox{Constructor alt} + & calt & \rightarrow & con~vars~@->@~expr & \\ +\mbox{Literal alt} + & lalt & \rightarrow & literal~@->@~expr & \\ +\\ +\mbox{Literals} & literal + & \rightarrow & integer & \\ + && | & \ldots & \\ +\\ +\mbox{Primitives} & prim + & \rightarrow & @+@ ~|~ @-@ ~|~ @*@ ~|~ @/@ \\ + && | & \ldots & \\ +\\ +\mbox{Variable lists} & vars & \rightarrow & + @[@var_1@,@ \ldots @,@~var_n@]@ & n \geq 0 \\ +\\ +\end{array}$ +} +\caption{Syntax of the STG language} +\label{fig:stg-syntax} +\end{figure} diff --git a/ghc/docs/grasp.sty b/ghc/docs/grasp.sty new file mode 100644 index 0000000..920783a --- /dev/null +++ b/ghc/docs/grasp.sty @@ -0,0 +1,177 @@ +% GRASP style file + +% +% Apart from settings of page size and margins, and +% setting appropriate math-mode italics, +% the following macros are provided: +% +% \ToDo{x} Highlighted note for something left to do +% \srcloc{x} Marginal note of source file x. x is set in +% typewriter font +% \smiley Well, you need one of these sometimes :-) + +%**************************************************************** +%* * +%* Page and paragraph format * +%* * +%**************************************************************** + +% Margins and page layout + +\sloppy % Reduce complaints + +\setlength{\marginparwidth}{1.5cm} + +% Block paragraphs + +\setlength{\parskip}{0.25cm} +\setlength{\parsep}{0.25cm} +\setlength{\topsep}{0cm} % Reduces space before and after verbatim, + % which is implemented using trivlist +\setlength{\parindent}{0cm} + +\renewcommand{\textfraction}{0.2} +\renewcommand{\floatpagefraction}{0.7} + + + +%**************************************************************** +%* * +%* ToDo * +%* * +%**************************************************************** + +\newcommand{\ToDo}[1]{$\spadesuit$~{\bf ToDo:} {\em #1} $\spadesuit$} + + +%**************************************************************** +%* * +%* srcloc * +%* * +%**************************************************************** + +\newcommand{\srcloc}[1]{\marginpar{\footnotesize\tt #1}} +% +% to avoid src-location marginpars, put this in your doc's pre-amble. +%\renewcommand{\srcloc}[1]{} + + +%**************************************************************** +%* * +%* smiley * +%* * +%**************************************************************** + +\newcommand{\smiley}{% +\hbox{$\bigcirc\mskip-13.3mu{}^{..} +\mskip-11mu\scriptscriptstyle\smile\ $}} + +%%\setbox0=\hbox{$\bigcirc$} +%%\dimen0=\wd0 +%%\newbox\smileybox +%%\setbox\smileybox=\hbox{\box0 \kern-.5\dimen0 +%% \lower .25ex\hbox to 0pt{\hss\vpt$\smile$\hss}% +%% \raise .25ex\hbox to 0pt{\hss\$\cdot\kern 0.1em\cdot$\hss}} +%%\wd\smileybox=\dimen0 +%%\def\smiley{\copybox\smileybox} +%% +%%Of course, you can substitute \frown for \smile :-) (but you may need +%%to adjust the spacing) :-( +%%-- +%%Andrew Innes (aci10@eng.cam.ac.uk) +%%Engineering Dept. +%%Cambridge University + + +%**************************************************************** +%* * +%* Math codes * +%* * +%**************************************************************** + +% The mathcodes for the letters A, ..., Z, a, ..., z are changed to +% generate text italic rather than math italic by default. This makes +% multi-letter identifiers look better. The mathcode for character c +% is set to "7000 (variable family) + "400 (text italic) + c. +% + + +% LaTeX with New Font Selection Scheme (NFSS) + +\@ifundefined{selectfont} + {} + {\newmathalphabet{\textit} + \addtoversion{normal}{\textit}{cmr}{m}{it} + \addtoversion{bold}{\textit}{cmr}{bx}{it} + \everymath{\textit} + \everydisplay{\textit} + } + +% LaTeX without NFSS +% +%\def\@setmcodes#1#2#3{{\count0=#1 \count1=#3 +% \loop \global\mathcode\count0=\count1 \ifnum \count0<#2 +% \advance\count0 by1 \advance\count1 by1 \repeat}} +% +%\@setmcodes{`A}{`Z}{"7441} +%\@setmcodes{`a}{`z}{"7461} + + +%**************************************************************** +%* * +%* Definitions for macros used in figures * +%* These are produced by fig2dev, so we need defns for them * +%* * +%**************************************************************** + +% These ones work for 11-pt typesetting + +\@ifundefined{selectfont} %DL is MS scheme present? +{}{ +\def\fiverm{\rm\tiny} % Five pt +\def\sevrm{\rm\scriptsize} % Seven pt + +\def\nintt{\tt\footnotesize} +\def\ninrm{\rm\footnotesize} + +\def\tenrm{\rm\small} % Ten pt +\def\tentt{\tt\small} % Ten pt + +\def\elvrm{\rm\normalsize} % Eleven pt +\def\elvit{\em\normalsize} + +\def\twlbf{\bf\large} % Twelve pt +\def\twlit{\em\large} +\def\twltt{\tt\large} +\def\twlrm{\rm\large} +\def\twfvtt{\tt\large} + +\def\frtnrm{\rm\Large} % Fourteen pt +\def\frtnbf{\bf\Large} +\def\frtnit{\em\Large} +\def\frtntt{\tt\Large} + +\def\svtnsf{\sf\huge} % Seventeen pt + + +% cant remember why I need these +\def\egt{\size{8}{9} } +\def\elv{\size{11}{12} } +\def\five{\size{5}{7} } +\def\fiv{\size{5}{6} } +\def\frtn{\size{14}{15} } +\def\nin{\size{9}{10} } +\def\sev{\size{7}{8} } +\def\six{\size{6}{7} } +\def\svtn{\size{17}{18} } +\def\ten{\size{10}{11} } +\def\twfv{\size{25}{27} } +\def\twl{\size{12}{14} } +\def\twty{\size{20}{22} } +} + + + + + + diff --git a/ghc/docs/install_guide/Jmakefile b/ghc/docs/install_guide/Jmakefile new file mode 100644 index 0000000..29b42b4 --- /dev/null +++ b/ghc/docs/install_guide/Jmakefile @@ -0,0 +1,7 @@ +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) + +LiterateSuffixRules() +DocProcessingSuffixRules() + +LitDocRootTarget(installing,lit) diff --git a/ghc/docs/install_guide/installing.lit b/ghc/docs/install_guide/installing.lit new file mode 100644 index 0000000..13df5b5 --- /dev/null +++ b/ghc/docs/install_guide/installing.lit @@ -0,0 +1,2133 @@ +% +% $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/docs/install_guide/Attic/installing.lit,v 1.1 1996/01/08 20:25:19 partain Exp $ +% +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Installing the Glasgow Functional Programming Tools\\ +Version~0.26} +\author{The AQUA Team (scribe: Will Partain)\\ +Department of Computing Science\\ +University of Glasgow\\ +Glasgow, Scotland\\ +G12 8QQ\\ +\\ +Email: glasgow-haskell-\{request,bugs\}\@dcs.glasgow.ac.uk} +\maketitle +\begin{rawlatex} +\tableofcontents +\end{rawlatex} +\clearpage +\end{onlystandalone} + +%************************************************************************ +%* * +\section[install-intro]{Introduction} +%* * +%************************************************************************ + +For most people, it should be easy to install one or more of the +Glasgow functional-programming tools (the `Glasgow tools'), most often +just the Glasgow Haskell compiler (GHC). This document will guide you +through the installation process, and point out the known pitfalls. + +Note: As of version~0.26, this document describes how to build {\em +all} of the Glasgow tools, not just the Haskell compiler. The +\tr{configure} script, etc., has changed to cope with this wider +mandate; something to bear in mind... + +%************************************************************************ +%* * +\subsection[install-strategy]{What to install? Starting from what?} +%* * +%************************************************************************ + +Building the Glasgow tools {\em can} be complicated, mostly because +there are so many permutations of what/why/how, e.g., ``Build Happy +with HBC, everything else with GHC, leave out profiling, and test it +all on the `real' NoFib programs.'' Yeeps! + +Happily, such complications don't apply to most people. A few common +``strategies'' serve most purposes. Pick one and proceed +as suggested: +\begin{description} +\item[Install from binary ``bundles'':] You have one of the supported +platforms (e.g., Sun4 or DEC Alpha), and you just want a Haskell +compiler, and you don't want to do anything fancy... This choice +is for you. Proceed to +\sectionref{installing-bin-distrib}. HIGHLY RECOMMENDED! + +\item[Build some Glasgow tools using GHC itself:] You have a supported +platform, but (a)~you like the warm fuzzy feeling of compiling things +yourself; (b)~you want to build something ``extra''---e.g., a set of +libraries with strictness-analysis turned off; or (c)~you want to hack +on GHC yourself. + +In this case, you should install a binary distribution +(as described in \sectionref{installing-bin-distrib}), +then build GHC with it (as described in \sectionref{building-GHC}). + +\item[Build GHC from intermediate C \tr{.hc} files:] You cannot get a +pre-built GHC, so you have no choice but to ``bootstrap'' up from the +intermediate C (\tr{.hc}) files that we provide. +Building GHC on an unsupported platform falls into this category. +Please see \sectionref{booting-from-C}. + +Once you have built GHC, you can build the other Glasgow tools with +it. + +\item[Build GHC with another Haskell compiler (e.g., HBC):] Not +recommended, but see \sectionref{building-with-HBC}. +\end{description} + +%************************************************************************ +%* * +\subsection[port-info]{What machines the Glasgow tools, version~0.26, run on} +\index{ports, GHC} +\index{GHC ports} +\index{supported platforms} +\index{platforms, supported} +%* * +%************************************************************************ + +The main question is whether or not the Haskell compiler (GHC) runs on +your machine. + +Bear in mind that certain ``bundles'', e.g. parallel Haskell, may not +work on all machines for which basic Haskell compiling is supported. + +Some libraries may only work on a limited number of platforms; for +example, a sockets library is of no use unless the operating system +supports the underlying BSDisms. + +%************************************************************************ +%* * +\subsubsection{What machines the Haskell compiler (GHC) runs on} +%* * +%************************************************************************ +\index{fully-supported platforms} +\index{native-code generator} +\index{registerised ports} +\index{unregisterised ports} + +The GHC hierarchy of Porting Goodness: (a)~Best is a native-code +generator; (b)~next best is a ``registerised'' +port; (c)~the bare minimum is an ``unregisterised'' port. +``Unregisterised'' Haskell programs are much bigger and slower, +but the port is much easier to get going. + +With GHC~0.26, we add ``registerised'' support for some HP-PA, iX86, +and MIPS platforms. + +We use Sun4s running SunOS~4.1.3 and DEC~Alphas running OSF/1~V2.0, +so those are the ``fully-supported'' platforms, unsurprisingly. Both +have native-code generators, for quicker compilations. + +Here's everything that's known about GHC ports, as of 0.26. We +identify platforms by their ``canonical GNU-style'' names. We +identify + +Note that some ports are fussy about which GCC version you use; or +require GAS; or ... + +\begin{description} +%------------------------------------------------------------------- +\item[\tr{alpha-dec-osf1}:] +\index{alpha-dec-osf1: fully supported} +(We have OSF/1 V2.0.) Fully supported, including native-code generator. +We recommend GCC 2.6.x or later. + +%------------------------------------------------------------------- +\item[\tr{sparc-sun-sunos4}:] +\index{sparc-sun-sunos4: fully supported} +Fully supported, including native-code generator. + +%------------------------------------------------------------------- +\item[\tr{sparc-sun-solaris2}:] +\index{sparc-sun-solaris2: fully supported} +Fully supported, including native-code generator. A couple of quirks, +though: (a)~the profiling libraries are bizarrely huge; (b)~the +default \tr{xargs} program is atrociously bad for building GHC +libraries (see \sectionref{Pre-supposed} for details). + +%------------------------------------------------------------------- +\item[HP-PA box running HP/UX 9.x:] +\index{hppa1.1-hp-hpux: registerised port} +GHC~0.26 works registerised. No native-code generator. +For GCC, you're best off with one of the Utah releases of +GCC~2.6.3 (`u3' or later), from \tr{jaguar.cs.utah.edu}. +We don't know if straight GCC 2.7.x works or not. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{hppa1.1-hp-hpux: concurrent---no} +\index{hppa1.1-hp-hpux: parallel---no} + +%------------------------------------------------------------------- +\item[\tr{i386-*-linuxaout} (PCs running Linux---\tr{a.out} format):] +\index{i386-*-linuxaout: registerised port} +GHC~0.26 works registerised (no native-code generator). +You {\em must} have GCC 2.7.x or later. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{i386-*-linuxaout: concurrent---no} +\index{i386-*-linuxaout: parallel---no} +\index{i386-*-linuxaout: profiling---maybe} +Profiling might work, but it is untested. + +%------------------------------------------------------------------- +\item[\tr{mips-sgi-irix5}:] +\index{mips-sgi-irix5: registerised port} +GHC~0.26 works registerised (no native-code generator). +I suspect any GCC~2.6.x (or later) is OK. The GCC that I used +was built with \tr{--with-gnu-as}. + +Concurrent/Parallel Haskell probably don't work (yet). +Profiling might work, but it is untested. +\index{mips-sgi-irix5: concurrent---no} +\index{mips-sgi-irix5: parallel---no} +\index{mips-sgi-irix5: profiling---maybe} + +%------------------------------------------------------------------- +\item[\tr{m68k-apple-macos7} (Mac, using MPW):] +\index{m68k-apple-macos7: historically ported} +Once upon a time, David Wright in Tasmania has actually +gotten GHC to run on a Macintosh. Ditto James Thomson here at Glasgow. +You may be able to get Thomson's from here. (Not sure that it will +excite you to death, but...) + +No particularly recent GHC is known to work on a Mac. + +%------------------------------------------------------------------- +\item[\tr{m68k-next-nextstep3}:] +\index{m68k-next-nextstep3: historically ported} +Carsten Schultz succeeded with a ``registerised'' port of GHC~0.19. +There's probably a little bit-rot since then, but otherwise it should +still be fine. Had a report that things were basically OK at 0.22. + +Concurrent/Parallel Haskell probably won't work (yet). +\index{m68k-next-nextstep3: concurrent---no} +\index{m68k-next-nextstep3: parallel---no} + +%------------------------------------------------------------------- +\item[\tr{m68k-sun-sunos4} (Sun3):] +\index{m68k-sun-sunos4: registerised port} +GHC~0.26 works registerised. No native-code generator. + +Concurrent/Parallel Haskell probably don't work (yet). +\index{m68k-sun-sunos4: concurrent---no} +\index{m68k-sun-sunos4: parallel---no} +\end{description} + +%************************************************************************ +%* * +\subsubsection{What machines the other tools run on} +%* * +%************************************************************************ + +Unless you hear otherwise, the other tools work if GHC works. + +Haggis requires Concurrent Haskell to work. +\index{Haggis, Concurrent Haskell} + +%************************************************************************ +%* * +\subsection{Things to check before you start typing} +%* * +%************************************************************************ + +\begin{enumerate} +\item +\index{disk space needed} +Disk space needed: About 30MB (five hamburgers' worth) of disk space +for the most basic binary distribution of GHC; more for some +platforms, e.g., Alphas. An extra ``bundle'' (e.g., concurrent +Haskell libraries) might take you to 8--10 hamburgers. + +You'll need over 100MB (say, 20 hamburgers' worth) if you need to +build the basic stuff from scratch. + +I don't yet know the disk requirements for the non-GHC tools. + +All of the above are {\em estimates} of disk-space needs. + +\item +Use an appropriate machine, compilers, and things. + +SPARC boxes and DEC Alphas running OSF/1 are fully supported. +\Sectionref{port-info} gives the full run-down on ports or lack +thereof. + +\item +Be sure that the ``pre-supposed'' utilities are installed. + +For GHC, you must have \tr{perl} to get anywhere at all. If you're +going for Parallel Haskell, you'll need PVM, version 3. You will +probably need a reasonably up-to-date GCC (GNU C compiler), +too---\sectionref{port-info} lists any specific requirements in this +regard. + +If you are going to be making documents [unlikely], you'll need +\tr{makeindex} as well, and maybe \tr{tgrind} [unlikely]. If you edit +the one or two \tr{flex} files in GHC, you'll need \tr{flex}, too +[unlikely]. + +If you end up yacc'ing the Haskell parser [unlikely], Sun's standard +\tr{/bin/yacc} won't cut it. Either the unbundled \tr{/usr/lang/yacc} +or \tr{bison} will do fine. Berkeley yacc (\tr{byacc}) won't do. + +\item +If you have any problem when building or installing the Glasgow tools, +please check the ``known pitfalls'' (\sectionref{build-pitfalls}). If +you feel there is still some shortcoming in our procedure or +instructions, please report it. + +For GHC, please see the bug-reporting section of the User's guide +(separate document), to maximise the usefulness of your report. + +If in doubt, please send a message to +\tr{glasgow-haskell-bugs@dcs.glasgow.ac.uk}. +\end{enumerate} + +%************************************************************************ +%* * +\section[installing-bin-distrib]{Installing from binary distributions (the most common case)} +\index{binary installations} +\index{installation, of binaries} +%* * +%************************************************************************ + +Installing from binary distributions is easiest, and recommended! + +%************************************************************************ +%* * +\subsection[GHC-bin-distrib]{GHC from binary distributions} +\index{GHC installation, from binaries} +\index{installation, GHC from binaries} +%* * +%************************************************************************ + +(Why binaries? Because GHC is a Haskell compiler written in Haskell, +so you've got to ``bootstrap'' it, somehow. We provide +machine-generated C-files-from-Haskell for this purpose, but it's +really quite a pain to use them. If you must build GHC from its +sources, using a binary-distributed GHC to do so is a sensible way to +proceed.) + +Binary distributions come in ``bundles,''\index{bundles of binary stuff} +one bundle per \tr{.tar.gz} file. + +A basic GHC ``bundle'' gives you the compiler and the standard, +sequential libraries. The files are called +\tr{ghc-0.26-.tar.gz}, where \tr{} is one of: +alpha-dec-osf2, hppa1.1-hp-hpux9, i386-unknown-linuxaout, +% i386-unknown-solaris2, +m68k-sun-sunos4, mips-sgi-irix5, +sparc-sun-sunos4, sparc-sun-solaris2. + +There are plenty of ``non-basic'' GHC bundles. The files for them are +called \tr{ghc-0.26--.tar.gz}, where the +\tr{} is as above, and \tr{} is one of these: +\begin{description} +\item[\tr{prof}:] Profiling with cost-centres. You probably want this. + +\item[\tr{conc}:] Concurrent Haskell features. You may want this. + +\item[\tr{par}:] Parallel Haskell features (sits on top of PVM). +You'll want this if you're into that kind of thing. + +\item[\tr{gran}:] The ``GranSim'' parallel-Haskell simulator +(hmm... mainly for implementors). + +\item[\tr{ticky}:] ``Ticky-ticky'' profiling; very detailed +information about ``what happened when I ran this program''---really +for implementors. + +\item[\tr{prof-conc}:] Cost-centre profiling for Concurrent Haskell. + +\item[\tr{prof-ticky}:] Ticky-ticky profiling for Concurrent Haskell. +\end{description} + +One likely scenario is that you will grab {\em three} binary +bundles---basic, profiling, and concurrent. Once you have them, +unpack them all together in the same place, thusly: + +\begin{verbatim} +cd /put/them/in/here +gunzip < ghc-0.26-sparc-sun-sunos4.tar.gz | tar xf - +gunzip < ghc-0.26-prof-sparc-sun-sunos4.tar.gz | tar xf - +gunzip < ghc-0.26-conc-sparc-sun-sunos4.tar.gz | tar xf - +\end{verbatim} + +If you unpacked the files in a way that does {\em not} preserve +modification times (e.g., used the \tr{m} option to \tr{tar}---why on +earth you might do this, I cannot imagine), then please unpack them +again :-) The timestamps on the files are (regrettably) important. + +%To check that you have all the pre-supposed utilities, please see +%\sectionref{Pre-supposed}. + +Here's what to do with the stuff in each directory, once unpacked. +% (If your binary distribution, doesn't look like this---don't despair! +% It may be a ``dumped-from-a-build'' distribution; please see +% \sectionref{dumped-from-build}.) + +\begin{description} +%--------------------------------------------------------------------- +\item[\tr{bin/} (sometimes just \tr{bin/}):] +Copy these executables so that they will be in users' PATHs. + +%--------------------------------------------------------------------- +\item[\tr{lib}:] +Move this directory, in toto, to wherever you want it to live. +It should still be called \tr{lib}. + +%--------------------------------------------------------------------- +\item[\tr{docs}:] +This is the full \tr{docs} tree. Just follow the normal instructions, +in \sectionref{make-docs}. +\end{description} + +Things you need to fiddle so the tools will spring to life: +\begin{enumerate} +\item +\tr{rehash} (csh users), so your shell will see the new stuff in your +bin directory. + +\item +CHOICE \#1 (BETTER): +Edit your \tr{ghc}, \tr{mkdependHS}, and \tr{hstags} scripts: +(a)~Create a correct \tr{#!...perl} first line in each one. (Ask a +Unix-friendly person to help you, if you don't know what a +\tr{#!}-line is.) (b) Find the line that looks something like: +\begin{verbatim} +# $ENV{'GLASGOW_HASKELL_ROOT'} = '/some/absolute/path/name'; +\end{verbatim} +Remote the comment symbol (\tr{#}) on the front, and change the +path name to be the right thing. + +So, if your ``lib'' files are now in \tr{/home/myself/lib/ghc/...}, +then you should set \tr{GLASGOW_HASKELL_ROOT} to \tr{/home/myself}. + +\item +CHOICE \#2: +Set your \tr{GLASGOW_HASKELL_ROOT} environment variable, and +don't edit the \tr{ghc}, \tr{mkdependHS}, and \tr{hstags} scripts +at all. + +It's better to edit the scripts; that way, it's once for all. + +\item +You {\em may} need to re-\tr{ranlib} your libraries (on Sun4s). +\begin{verbatim} +% cd /ghc/0.26/sparc-sun-sunos4 +% foreach i ( `find . -name '*.a' -print` ) # or other-shell equiv... +? ranlib $i +? # or, on some machines: ar s $i +? end +\end{verbatim} + +\item +Once done, test your ``installation'' as suggested in +\sectionref{GHC_test}. Be sure to use a \tr{-v} option, so you +can see exactly what pathnames it's using. + +If things don't work, double-check your hand-edited path +names. Things will go catastrophically wrong as long as they are +incorrect. +\end{enumerate} + +%************************************************************************ +%* * +\subsection[non-GHC-bin-distrib]{Other tools from binary distributions} +%* * +%************************************************************************ + +NOT DONE YET. + +All of the above is for GHC bundles. For other tools, the same +principles apply: get the binary bundles you want, then unpack them +all together in the same place. + +%************************************************************************ +%* * +%\subsection[dumped-from-build]{Installing a ``dumped-from-build'' binary distribution (some platforms)} +%* * +%************************************************************************ +%#% +%#% Sometimes, a binary distribution is taken directly from a GHC +%#% ``build.'' An example is the Solaris distribution. You can tell from +%#% the layout of the files. +%#% +%#% The setup required is nearly the same as a ``regular'' binary +%#% distribution; only some names are different. +%#% \begin{enumerate} +%#% \item +%#% Get the user-executable scripts into your PATH, either by copying it +%#% or by linking to it. These are in: +%#% \begin{verbatim} +%#% /ghc/driver/ghc +%#% /ghc/utils/mkdependHS/mkdependHS +%#% /ghc/utils/hstags/hstags +%#% \end{verbatim} +%#% +%#% \item +%#% Set the \tr{GLASGOW_HASKELL_ROOT} environment variable for the three +%#% scripts above, in the manner outlined in the previous section. +%#% +%#% \item +%#% Possibly re-\tr{ranlib}'ing your \tr{*.a} files: +%#% \begin{verbatim} +%#% % cd +%#% % foreach i ( `find . -name '*.a' -print` ) # or other-shell equiv... +%#% % ranlib $i +%#% % # or, on some machines: ar s $i +%#% % end +%#% \end{verbatim} +%#% +%#% \item +%#% Don't forget to test it! +%#% \end{enumerate} + +%************************************************************************ +%* * +\section[checklist]{Building Glasgow tools from source: a checklist} +%* * +%************************************************************************ + +\begin{enumerate} +\item +Install any pre-supposed utility programs that you do not have at your +site. You have to do this ``by hand.'' It's not hard, and these are +things you want to have anyway. Please see \sectionref{Pre-supposed}. + +\item +Be sure you have a suitable Haskell compiler, or else the intermediate +C (\tr{.hc}) files. In some cases, you might want an alternative set +of interface (\tr{.hi}) files (quicker than generating a fresh set). +\Sectionref{install-strategy} lists the various strategies you might +adopt. + +If you don't have a Haskell compiler, the most painless option is to +use a binary-distributed GHC to compile Glasgow tools (including GHC +itself) from source. Installing a binary distribution (the first +step) is described in \sectionref{installing-bin-distrib}. + +\item +You might want to write-protect your source files at this point: +\begin{verbatim} +cd +find . -type f \! -name \*.hi \! -name \*.hc \! -name \*.jm -print \ + | xargs chmod a-w +\end{verbatim} + +\item +Run the \tr{configure} script. It is a shell script that looks around +to find out things about your system. You can see the \tr{configure} +options by passing it a \tr{--help} flag, or by reading +\sectionref{Configuring}. + +\item +Once configured, build the basic support utilities and make your +Makefiles, including the automagically-created dependencies between +files. The near-universal incantation is: +\begin{verbatim} +% cd +% sh < STARTUP >& startup.log # and chk the log afterwards! +\end{verbatim} + +\item +Build the Glasgow tools you are interested in, as \tr{STARTUP} suggests: +\begin{verbatim} +% cd / +% make all >& make.log # time to go to lunch! +\end{verbatim} +Consult the list of known pitfalls (\sectionref{build-pitfalls}) if +something goes wrong. + +\item +Test what you've built, enough to know that it's working. + +\item +Actually install the tools, if you wish: +\begin{verbatim} +% cd / +% make install +\end{verbatim} + +\item +Make and/or install the documentation. + +\item +Save a copy of your \tr{config.status} file, for the next +even-more-wonderful release! + +\item +If you're finished, tidy up after yourself [\tr{make clean}], if you +want to. + +Alternatively, \tr{/bin/rm -rf } :-) +\end{enumerate} + +%************************************************************************ +%* * +\section[building-GHC]{Building the Glasgow Haskell Compiler (GHC)} +\index{GHC installation, from sources} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\downsection +\section{Building GHC from source, compiling it with itself} +\index{building GHC with itself} +\index{booting GHC with itself} +%* * +%************************************************************************ + +This section describes how to build GHC from source. You would do +this if (a)~there is no ``canned'' binary distribution for your +machine, (b)~the binary distribution omits features that you want, +(c)~you want to make changes to GHC and them build them in, or +(d)~you like torturing yourself. + +This blow-by-blow description follows the general checklist in +\sectionref{checklist}. + +%************************************************************************ +%* * +\subsection[Right-compiler-and-files]{Do you have a suitable compiler and/or \tr{.hc} files and/or \tr{.hi} files?} +\index{booting GHC, files needed} +%* * +%************************************************************************ + +We now proceed through each installation step, carefully. + +Because the compiler heart of Glorious Glasgow Haskell is written in +Haskell, you have to use some ``bootstrapping'' mechanism. + +Your best choice, if available, is to use a binary distribution for +your platform; i.e., compile GHC~0.26 with a GHC~0.26 that we have +provided. Please see \sectionref{installing-bin-distrib} for how to +install a binary distribution. + +Your remaining choice is to use the intermediate C (\tr{.hc}) files that we +supply. This is the {\em only} choice for anyone trying to port to +a new or weakly-supported system. + +The main drawback of the supplied-\tr{.hc} approach is that you will +have a lot of very bulky intermediate files on your disk for a while. + +One obscure note: if you're going to build GHC to have a native-code +generator, you're well advised to get a suitable set of interface +files (to save making them yourself). Please see \sectionref{Compiler_reconfig} +if you plan to end up with a native-code generator. + +% If you have to boot from C (\tr{.hc}) files, you should follow the +% directions in \sectionref{booting-from-C}. + +% We also supply parts of the system pre-compiled to C (in \tr{.hc} +% files). This is partly to save you work (you don't have to wait for +% them to compile yourself) and partly because this is how we will +% eventually supply the self-compiling compiler (when that's ready). +% In any case, if you slurped the \tr{.tar.gz} file, you should, {\em in +% the same directory as before}, do... +% \begin{verbatim} +% % gunzip -c ghc--hc-files.tar.gz | tar xfv - +% \end{verbatim} + +%************************************************************************ +%* * +\subsection{Write-protecting your source files} +\index{write-protecting source files} +%* * +%************************************************************************ + +At this point, some people like to write-protect their source files against +inadvertent change: +\begin{verbatim} +cd +find . -type f \! -name '*.hi' \! -name \*.hc \! -name '*.jm' -print \ + | xargs chmod a-w +\end{verbatim} + +%************************************************************************ +%* * +\subsection{Running \tr{configure} and \tr{STARTUP} for GHC} +\index{configure, for GHC} +\index{STARTUP, for GHC} +%* * +%************************************************************************ + +The \tr{configure} script finds out things about your machine. It +also allows you to specify features to include/exclude from your GHC +installation. + +Please see \sectionref{Configuring} for all about \tr{configure}, and +\sectionref{Configuring-GHC} for details of GHC configuring (including +examples). + +Once \tr{configure} runs successfully, do as it says and do +\tr{sh < STARTUP}. + +%************************************************************************ +%* * +\subsection{Build the compiler!} +\index{make all, for GHC} +%* * +%************************************************************************ + +Do the main GHC build, just as \tr{STARTUP} suggests: +\begin{verbatim} +% cd ghc +% make all >& make.log +\end{verbatim} +If this fails or something seems suspicious, check the ``known +pitfalls'' (\sectionref{build-pitfalls}). If you can't figure out how +to proceed, please get in touch with us. + +If you have to restart the build, for whatever reason, you are just as +well to make the whole thing; i.e., re-do as described above. (Well, +the \tr{compiler} and \tr{lib} subdirectories are the last two; if the +build ``dies'' in one of them, it is usually safe to finish the job by +hand.) + +%************************************************************************ +%* * +\subsection[GHC_test]{Test that GHC seems to be working} +\index{testing a new GHC} +%* * +%************************************************************************ + +The way to do this is, of course, to compile and run {\em this} program +(in a file \tr{Main.hs}): +\begin{verbatim} +main = putStr "Hello, world!\n" +\end{verbatim} + +First, give yourself a convenient way to execute the driver script +\tr{ghc/driver/ghc}, perhaps something like... +\begin{verbatim} +% ln -s /local/src/ghc-0.26/ghc/driver/ghc ~/bin/sun4/ghc +% rehash +\end{verbatim} + +Compile the program, using the \tr{-v} (verbose) flag to verify that +libraries, etc., are being found properly: +\begin{verbatim} +% ghc -v -o hello -fhaskell-1.3 Main.hs +\end{verbatim} + +Now run it: +\begin{verbatim} +% ./hello +Hello, world! +\end{verbatim} + +Some simple-but-profitable tests are to compile and run the +notorious \tr{nfib} program, using different numeric types. Start +with \tr{nfib :: Int -> Int}, and then try \tr{Integer}, \tr{Float}, +\tr{Double}, \tr{Rational} and maybe \tr{Complex Float}. Code +for this is distributed in \tr{ghc/misc/examples/nfib/}. + +For more information on how to ``drive'' GHC, +either do \tr{ghc -help} or consult the User's Guide (distributed in +\tr{ghc/docs/users_guide}). + +%************************************************************************ +%* * +\subsection[GHC_install]{Actually installing GHC} +\index{make install, GHC} +\index{installing, GHC} +%* * +%************************************************************************ + +``Installing GHC'' means copying the files required to run it to their +``permanent home.'' You can then delete, or at least tidy up, your +source directory. + +If you have no reason to install GHC, you can execute directly out of +the source tree, as sketched in the section above +(\sectionref{GHC_test}). + +Assuming that everything's OK so far, all you need to do is: +\begin{verbatim} +% cd /ghc +% make install +\end{verbatim} + +If you're a little dubious (as I usually am), you can always do a +``trial run'' first: +\begin{verbatim} +% cd /ghc +% make -n install >& temp-log-file-to-look-at +\end{verbatim} + +In both cases, if something breaks, it's a {\em bug}. + + +%************************************************************************ +%* * +\subsection[make-docs]{Installing the GHC documentation (optional)} +\index{documentation, making} +\index{make docs, GHC} +\index{installing documentation} +%* * +%************************************************************************ + +Because our documentation is in DVI/Info formats, and because there is +no standard practice about how such documents are ``installed,'' we +haven't tried to automate this (at least not enough that we promise it +works). + +You can find all the documentation in the distribution with: +\begin{verbatim} +% cd ghc/docs +% find . \( -name '*.dvi' -o -name '*.info' -o -name '*.html' \) -print +\end{verbatim} + +If you have a standard place to put such files, just copy +them there. (Better ideas welcome.) + +The following ``man'' pages are hidden around in the distribution: +\begin{verbatim} +ghc/utils/hp2ps/hp2ps.1 +literate/info-utils/info.1 +glafp-utils/scripts/mkdirhier.man +glafp-utils/scripts/lndir.man +\end{verbatim} +Please install them by hand if you need to. + +%There are various pieces of GHC whose code can be formatted +%``literately.'' The usual procedure is... +%\begin{verbatim} +%% cd ghc/ +%% make depend # VERY IMPORTANT for literate docs! +%% make docs # or more directly.... +%% make whatever.dvi # or, for Info freaks,... +%% make whatever.info +%\end{verbatim} + +%For ``chunks'' of the compiler proper, in \tr{ghc/compiler}, you will +%need to make a \tr{Makefile} for them first: +%\begin{verbatim} +%cd ghc/compiler +%make Makefile SUBDIRS=prelude # for example... +%cd prelude +%make depend # i.e., as before +%make prelude.dvi +%\end{verbatim} +%Directories for which this {\em might} (I emphasize: `MIGHT') work are ... +%\begin{verbatim} +%codeGen/Jmakefile +%coreSyn/Jmakefile +%deSugar/Jmakefile +%podizeCore/Jmakefile +%prelude/Jmakefile +%typecheck/Jmakefile +%\end{verbatim} +% +%Remember: an unpatched perl 4.035 will {\em crash} on making many of +%our ``literate'' Info files. (The current version, 4.036, will not.) + +%$$ Note: Because we make our Info files by going through Texinfo format, +%$$ you can use \tr{texi2html} to produce HTML files. A +%$$ minisculely-hacked version is in the distribution in +%$$ \tr{literate/texi2html/texi2html}. + +%************************************************************************ +%* * +\subsection[clean-up]{Cleaning up after yourself} +\index{make clean, GHC} +\index{cleaning up afterwards} +%* * +%************************************************************************ + +\tr{make clean} is the basic command to tidy things up. However: if +you do this, {\em you will not be able to execute directly out of the +source tree thereafter!} (as sketched in \sectionref{GHC_test}). Nor will +you be able to make documents, etc.---you would have to re-build parts +of GHC first. + +If you want to execute out of the source tree but would like to clear +off lots and lots of stuff, you can do: +\begin{verbatim} +% cd ghc/lib # scrub library C and object files +% rm */*.hc +% find . -name '*.o' -print | xargs /bin/rm + +% cd ghc/compiler # scrub compiler object files +% rm */*.o +% rm */*.hc # if you have been keeping them around +\end{verbatim} +(You can scrub the object files in \tr{ghc/runtime} similarly---except +\tr{main/TopClosure*.o}.) + +%\tr{make veryclean} is the command to clear off everything that can be +%safely cleared off. Not recommended (inadequately tested). + +%************************************************************************ +%* * +\section[booting-from-C]{Booting/porting from C (\tr{.hc}) files} +\index{building GHC from .hc files} +\index{booting GHC from .hc files} +%* * +%************************************************************************ + +This section is for people trying to get GHC going by using the +supplied intermediate C (\tr{.hc}) files. This would probably be +because no binaries have been provided, or because the machine +is not ``fully supported.'' + +To boot from C (\tr{.hc}) files, you need the regular source distribution +(\tr{ghc-0.26-src.tar.gz}) and also some extra files in +\tr{ghc-0.26-hc-files.tar.gz}. DON'T FORGET any extra \tr{.hc} +files for profiling, concurrent, parallel, ... + +Whatever you want to build, just unpack all the files ``together'': +\begin{verbatim} +% cd +% gunzip -c ghc-0.26-src.tar.gz | tar xf - +% gunzip -c ghc-0.26-hc-files.tar.gz | tar xf - # basic... +% gunzip -c ghc-0.26-prof-hc-files.tar.gz | tar xf - # profiling... +% gunzip -c ghc-0.26-conc-hc-files.tar.gz | tar xf - # concurrent... +... etc ... +\end{verbatim} + +For the ``it's been tried before'' machines, the normal +configure/build procedure will probably work; just keep your eyes +peeled for mischief. + +WORD OF WISDOM: Be sure you have a suitable GCC (GNU C compiler); please +see \sectionref{port-info} for any specific requirements for your machine. + +You'll need plenty of disk space to do this whole procedure! + +%$$ %************************************************************************ +%$$ %* * +%$$ \subsection[boot-file-fiddling]{Unpack; then fiddle files before booting} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ Unpack the relevant files for booting as described above. +%$$ +%$$ If you are on a never-seen-before platform, then there is a little +%$$ machine-specific code/stuff scattered around the GHC files, which will +%$$ need to be updated before you get started. +%$$ +%$$ \begin{description} +%$$ %--------------------------------------------------------------------- +%$$ \item[Change \tr{configure}, so it recognizes your machine:] +%$$ Add the obvious stuff if it says ``Unrecognised platform for GHC.'' +%$$ +%$$ If you are teaching GHC how to ``registerise'' on a new platform, you +%$$ will also need to make sure the variable @GhcWithRegisterised@ is set +%$$ correctly. +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Change {\em two} copies of \tr{platform.h.in}:] +%$$ In the obvious way. They are in \tr{ghc/includes/} and \tr{mkworld/}. +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Floating-pointness:] +%$$ Grep for \tr{_TARGET} in \tr{ghc/includes/*.*h} and make suitable +%$$ adjustments. +%$$ +%$$ One change you will certainly make is in \tr{StgMacros.lh}, to decide +%$$ the inclusion of \tr{ieee-flpt.h} and \tr{BIGENDIAN}. +%$$ +%$$ Please use the CPP symbols defined in \tr{platform.h.in}! +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[64-bitness:] +%$$ Again, grepping for \tr{_TARGET} in \tr{ghc/includes/*.lh} will find +%$$ the places that need adjusting. \tr{GhcConstants.lh} and +%$$ \tr{StgTypes.lh} are two places that will need tweaking, for example. +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[``Registerizing'' magic:] +%$$ This is the platform-specific stuff in \tr{COptJumps.lh}, +%$$ \tr{COptWraps.lh}, and \tr{MachRegs.lh} in \tr{ghc/includes}. +%$$ +%$$ If you are doing an initial unregisterised boot for your platform, you +%$$ don't need to mess with these files at all. +%$$ +%$$ \Sectionref{real-version-from-init-boot} discusses how to get a +%$$ ``registerised'' version of GHC going. (Much trickier, but much +%$$ faster. [0.26: and the documentation is OUT-OF-DATE]) +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Host/target platforms in the driver:] +%$$ Grep for all occurrences of \tr{$HostPlatform} and \tr{$TargetPlatform} +%$$ in \tr{ghc/driver/*.lprl}. +%$$ +%$$ Don't worry about the \tr{process_asm_block} stuff in +%$$ \tr{ghc-split.lprl}. Not used in a straight ``unregisterised'' +%$$ version. +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Target-specific GCC flags in the driver:] +%$$ +%$$ The main thing to worry about in \tr{ghc.lprl} is the section on how +%$$ to ``Add on machine-specific C-compiler flags.'' +%$$ You may want to add something {\em vaguely} like: +%$$ \begin{verbatim} +%$$ ... +%$$ } elsif ($TargetPlatform =~ /^mips-dec-ultrix/) { +%$$ unshift(@CcBoth_flags, ('-G0', '-static')) if $GccAvailable; +%$$ \end{verbatim} +%$$ +%$$ Explanations: (1)~Static linking {\em tends} to give less problems, so +%$$ it is a reasonable choice for an initial attempt. +%$$ +%$$ (2)~In processing +%$$ the intermediate C (\tr{.hc}) files, you are compiling some {\em huge} +%$$ wads of C. Sadly, quite a few systems don't cope well with this, and +%$$ more than a few silently produce object files that won't link. GCC +%$$ usually provides some platform-specific flag that says ``generate code +%$$ that will work no matter how big the files are''. The \tr{-G0} for +%$$ DEC MIPS boxes is an example. If your system has such restrictions, +%$$ insert some magic {\em here}! +%$$ \end{description} + +%************************************************************************ +%* * +\subsection{Do \tr{configure}; \tr{sh < STARTUP}; \tr{cd ghc; make all}; test it!} +\index{configure, GHC with .hc files} +\index{make all, GHC with .hc files} +%* * +%************************************************************************ + +Go ahead and try \tr{configure}, as described \Sectionref{Configuring} +(GHC specifics in \Sectionref{Configuring-GHC}). + +The key \tr{configure} option is \tr{--with-hc=c}. A typical +going-via-C invocation might be: + +\begin{verbatim} +% ./configure --prefix=/local/fp --with-hc=c # basic + profiling +\end{verbatim} + +Other common possibilities might be: + +\begin{verbatim} +% ./configure --with-hc=c --disable-profiling # basic only + +% ./configure --with-hc=c --enable-concurrent --enable-parallel + # basic + profiling + concurrent + parallel +\end{verbatim} + +%$$ One likely reason it won't work is it will say it never heard of your +%$$ machine. Just edit the script and carry on! (As always, please send +%$$ us the changes.) + +Next, run \tr{STARTUP} in the usual way, as described in +\Sectionref{STARTUP}. + +It's now time to type \tr{cd ghc; make all}! This ``should'' work, +especially, on a known machine. Also, it can take a VERY long time +(esp. on oldish machines), so it's good to run overnight, on a quiet +machine, nice'd, etc., etc. + +When it's all built, test your alleged GHC system, as suggested in +\sectionref{GHC_test}. + +%$$ What you should end up with, built in this order: (1)~a runtime system +%$$ [\tr{ghc/runtime/libHSrts_ap.a}]; (2)~Prelude libraries +%$$ [\tr{ghc/lib/libHS_ap.a} and \tr{ghc/lib/libHShbc_ap.a}]; and (3)~a +%$$ compiler [\tr{ghc/compiler/hsc}] (which needs the first two). +%$$ +%$$ (Umm... if you are on a supported platform, but compiling via C, then +%$$ the \tr{*.a} suffixes will be \tr{_ap_o.a} (regular) and \tr{_p.a} +%$$ (profiling).) + +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection{A pre-emptive \tr{hello, world} test} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ On an unsupported platform, +%$$ You very well may want to {\em kill the compilation} once +%$$ \tr{libHSrts_ap.a} and \tr{libHS_ap.a} are built, to do a little +%$$ pre-emptive testing: time to run \tr{Hello, world!}. Using +%$$ \tr{ghc/CONTRIB/hello.hc}... +%$$ \begin{verbatim} +%$$ % .../ghc/driver/ghc -c -g hello.hc +%$$ % .../ghc/driver/ghc -v -o hello -g hello.o +%$$ % ./hello +%$$ \end{verbatim} +%$$ +%$$ If you have any trouble to do with ``consistency checking,'' just +%$$ avoid it, with the \tr{-no-link-chk} flag. +%$$ +%$$ If \tr{hello} crashes/breaks, it's time for Ye Olde Debugger, or +%$$ perhaps Ye Older Cry for Help... +%$$ +%$$ If things are OK and if you {\em did} kill the compilation, just re-do +%$$ \tr{make} to finish the job (build any other libraries, then the +%$$ compiler binary \tr{ghc/hsc}). +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[init-boot-hsc]{Finishing the initial boot} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ If you manage to get a \tr{ghc/hsc} binary (usually huge), then... +%$$ YOU HAVE A HASKELL COMPILER, albeit big and slow! So test it, +%$$ ``from the sources,'' before installing it: +%$$ \begin{verbatim} +%$$ % cat > test.hs +%$$ main = print ((10001 - 30002)::Integer) +%$$ -- or any other program(s) you want... +%$$ ^D +%$$ % .../ghc/driver/ghc -v -g -c test.hs +%$$ % .../ghc/driver/ghc -v -g -o test test.o +%$$ % ./test +%$$ \end{verbatim} +%$$ (Note how I fiendishly included a \tr{-g}, in case I had to throw a +%$$ debugger at it...) +%$$ +%$$ Of course, you {\em may not} have a \tr{ghc/hsc} binary---something +%$$ went wrong. The most likely cause is a compiler/assembler/linker +%$$ failure due to the HUGE size of this program. Please revisit the +%$$ discussion about this towards the end of +%$$ \sectionref{boot-file-fiddling}. Sadly, if you have to tweak +%$$ C-compiler/whatever flags, you may have to rebuild all the +%$$ libraries/compiler again; the following is sufficient to clear +%$$ off everything for a fresh start (NB: don't do \tr{make clean}): +%$$ \begin{verbatim} +%$$ % cd ghc/runtime # clear off RTS +%$$ % make clean SUBDIRS=foo # but avoid clearing GMP lib +%$$ % cd ../lib +%$$ % rm */*.o +%$$ % cd ../compiler +%$$ % rm */*.o +%$$ \end{verbatim} +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[installing-init-boot]{`Installing' the initial boot} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ If you are satisfied that things are working, {\em possibly install} the +%$$ initial booted version. The main point is: save the precious files +%$$ you've just created. +%$$ +%$$ Should you choose {\em not to install}, be sure to secure these files +%$$ somewhere/somehow: +%$$ \begin{verbatim} +%$$ ghc/compiler/hsc # compiler +%$$ ghc/runtime/libHSrts_ap.a # RTS things +%$$ ghc/lib/libHS_ap.a # prelude library +%$$ \end{verbatim} +%$$ +%$$ Should you install, the comments about `normal' installing, in +%$$ \Sectionref{GHC_install}, do apply. It should come down to +%$$ something like... +%$$ \begin{verbatim} +%$$ % cd ghc +%$$ % make -n install >& temp-log-file-to-look-at # trial run: chk it out! +%$$ % make install # the real thing... +%$$ \end{verbatim} +%$$ +%$$ (I'd probably do the install by hand, if at all; let me know if you're +%$$ worried about the exact incantations.) +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[testing-init-boot]{Testing the initial boot} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ It wouldn't be a bad idea, especially on an unusual machine; I usually +%$$ just skip this part, though :-) +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsection[split-libs]{Getting ``splitting'' going on your Prelude libraries} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ ghc-split.lprl +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsection[real-version-from-init-boot]{Getting a ``registerised'' version going} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ Version 0.26: THIS DOCUMENTATION IS OUT-OF-DATE. (Sigh) +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[registerised-magic-files]{Setting up files for `registerizing'} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ It's time to jiggle some files related to GCC-magic-optimisation. +%$$ {\em This is real work, folks.} What follows is a {\em rough} guide to +%$$ what needs looking at. +%$$ +%$$ \begin{description} +%$$ %--------------------------------------------------------------------- +%$$ \item[\tr{ghc/includes/MachRegs.lh}:] +%$$ This maps ``STG registers'' (Hp, SpA, TagReg, etc.) to machine +%$$ registers on a platform-by-platform basis. +%$$ If you can't figure it out, you'd probably better ask. +%$$ +%$$ We are using a GCC extension to put C global variables in specific +%$$ registers; see the \tr{Global Reg Vars} node in the GCC documentation. +%$$ +%$$ You should get the idea from the settings for our ``fully supported'' +%$$ platforms, but you will need to know/learn something about your +%$$ hardware and your GCC (e.g., what registers it snaffles for itself). +%$$ +%$$ One way I went about learning these register secrets was to try the +%$$ following test file (a Sun3 version here, \tr{regs3.hc}): +%$$ \begin{verbatim} +%$$ #define StgPtr long int * +%$$ +%$$ register StgPtr FooL0 __asm__("a0"); +%$$ register StgPtr FooL1 __asm__("a1"); +%$$ register StgPtr FooL2 __asm__("a2"); +%$$ register StgPtr FooL3 __asm__("a3"); +%$$ register StgPtr FooL4 __asm__("a4"); +%$$ register StgPtr FooL5 __asm__("a5"); +%$$ register StgPtr FooL6 __asm__("a6"); +%$$ register StgPtr FooL7 __asm__("a7"); +%$$ +%$$ register StgPtr FooG0 __asm__("d0"); +%$$ register StgPtr FooG1 __asm__("d1"); +%$$ register StgPtr FooG2 __asm__("d2"); +%$$ register StgPtr FooG3 __asm__("d3"); +%$$ register StgPtr FooG4 __asm__("d4"); +%$$ register StgPtr FooG5 __asm__("d5"); +%$$ register StgPtr FooG6 __asm__("d6"); +%$$ register StgPtr FooG7 __asm__("d7"); +%$$ +%$$ wurble(x) +%$$ int x; +%$$ { +%$$ return (x + 42); +%$$ } +%$$ \end{verbatim} +%$$ Then compile it repeatedly with your new driver, e.g., +%$$ \tr{ghc-boot-me -v -S regs3.hc}, removing register declarations that +%$$ offend it. Note: GCC's error messages about these register things +%$$ can be less than totally enlightening. +%$$ +%$$ Note: don't worry about warnings that you're stealing a +%$$ ``call-clobbered'' (caller-saves) register. These are stealable, +%$$ though some extra work may be required. +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[\tr{ghc/includes/COptJumps.lh}:] +%$$ The name of the game, essentially, is for the @JMP_@ macro to turn +%$$ into a simple jump instruction. Also, through fiendish collaboration +%$$ with the assembly-language post-processor in the driver (coming up +%$$ soon...), we're going to rip out all the pushing/popping to do with +%$$ the C stack. +%$$ +%$$ You {\em may} need to do something as on 680x0s, where we inject +%$$ beginning-of- and end-of-real-code markers, which gives the post-processor +%$$ something to look out for and tidy up around. +%$$ +%$$ You also need to define some mini-interpreter-related macros. These +%$$ are discussed under \tr{StgMiniInt.lc} (below). +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[\tr{ghc/includes/COptWraps.lh}:] +%$$ +%$$ The macro @STGCALL1(f,a)@ is defined here; it almost certainly should +%$$ just be \tr{callWrapper(f,a)} (where the magical routine @callWrapper@ +%$$ is yet to come). +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[\tr{ghc/driver/ghc-asm-.lprl}:] +%$$ This is the notorious ``optimised assembler post-processor.'' You +%$$ need to create a suitable \tr{require}-able file (if you haven't +%$$ already), add a mention in the \tr{Jmakefile}, and add suitable code +%$$ in the driver, \tr{ghc.lprl} to invoke it. +%$$ +%$$ This is really quite horrible for a SPARC; we have to shut down the +%$$ register-window mechanism {\em entirely}, by ripping out all the +%$$ \tr{save} and \tr{restore} instructions. +%$$ +%$$ We also go to lots of trouble to move info tables next to entry code, +%$$ elide slow and fast entry-point routines, and probably some things +%$$ I've forgotten about. +%$$ +%$$ Ask if you are desperately confused... +%$$ +%$$ Perhaps it will be less gruesome for your machine! +%$$ +%$$ Don't forget to test it with \tr{-g} turned on (lots of \tr{\.stab?} +%$$ lines suddenly appear)... +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[\tr{CallWrap_C.lc} or \tr{CallWrapper.ls}, in ghc/runtime/c-as-asm/:] +%$$ +%$$ These files have register saving/restoring code. For a SPARC, quite a +%$$ bit has to be written in assembly language (\tr{CallWrapper.ls}), to +%$$ avoid register windowing; but, for other machines, the C versions +%$$ (\tr{CallWrap_C.lc}) should work fine. +%$$ +%$$ Look at the generated assembly-language very carefully! +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[ghc/runtime/c-as-asm/StgMiniInt.lc:] +%$$ +%$$ You need to manage to create entry points named @miniInterpret@ and +%$$ @miniInterpretEnd@, the former to jump off into threaded code; the +%$$ latter to come back to. +%$$ +%$$ You may be able to do something quite simple---it's not bad either for +%$$ mc680x0s or SPARCs---but you will want to inspect the assembler output +%$$ before declaring victory. +%$$ +%$$ In the SPARC case, it uses a macro (@MINI_INTERPRETER_END_IS_HERE@) +%$$ defined in \tr{imports/COptJumps.lh}. +%$$ \end{description} +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[testing-registerisation]{Initial testing of a `registerisation'} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ {\em How to begin testing this registerised stuff:} +%$$ +%$$ Make sure your imports files are up-to-date: +%$$ \begin{verbatim} +%$$ % cd ghc/includes +%$$ % make +%$$ \end{verbatim} +%$$ +%$$ Park yourself in your driver subdirectory and ... +%$$ \begin{verbatim} +%$$ % cd ghc/driver # park +%$$ % make Makefile # if you changed "only4-ghc.ljm"... +%$$ % make # just to be sure +%$$ +%$$ % cp ../compiler/utils/Util.hc temp.hc # grab a test file; +%$$ # you may want to chop it down +%$$ % ghc-boot-me -v -S -ddump-raw-asm temp.hc # see what happens! +%$$ \end{verbatim} +%$$ +%$$ (The \tr{-ddump-raw-asm} option shows you, on stderr, what comes +%$$ directly out of GCC. That's what your post-processing mangler has to +%$$ chomp on.) +%$$ +%$$ {\em Going further on testing this stuff:} +%$$ +%$$ Another good place to practice is \tr{ghc/runtime}; so, for example: +%$$ \begin{verbatim} +%$$ % cd ghc/runtime +%$$ % make Makefile +%$$ % make clean +%$$ % make libHSrts_ap_o.a +%$$ \end{verbatim} +%$$ +%$$ The .s output from \tr{main/StgUpdate.lhc} can be particularly +%$$ enlightening, in that, if you are going to have register spills (e.g., +%$$ because your registerisation choices left GCC with too few with which +%$$ to generate good code), you will see it on this file. +%$$ +%$$ Don't forget: you need a working \tr{CallWrapper.ls} and +%$$ \tr{StgMiniInt.lc} (both in \tr{c-as-asm}) before this registerised +%$$ stuff will actually run. +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[building-registerized]{Building the basics of a registerised GHC} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ \begin{description} +%$$ %--------------------------------------------------------------------- +%$$ \item[What you need to run a registerised program:] +%$$ +%$$ Once you make a \tr{libHSrts_ap_o.a} in runtime, all you need is a +%$$ prelude library. You need to do it by hand still. +%$$ \begin{verbatim} +%$$ % cd ghc/lib +%$$ % ghc-boot-me -c -g -O -osuf _ap_o.o */*.hc # takes a while +%$$ % +%$$ % rm libHS_ap_o.a +%$$ % ar clq libHS_ap_o.a */*_ap_o.o +%$$ % ranlib libHS_ap_o.a +%$$ \end{verbatim} +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Testing the registerised GHC:] +%$$ +%$$ As before, starting with the \tr{.hc} you made in the first round: +%$$ \begin{verbatim} +%$$ % ghc-boot-me -v -g -c test.hc +%$$ % ghc-boot-me -v -g -o test test.o +%$$ % ./test +%$$ \end{verbatim} +%$$ +%$$ If things are broken, the likely outcome is a core dump, and you'll +%$$ need to throw GDB (or equiv) at it. Useful breakpoints are +%$$ \tr{main}, \tr{miniInterpret}, \tr{Main_main_entry}, and +%$$ \tr{startStgWorld} (when you're just getting going), and +%$$ \tr{stopStgWorld} and \tr{miniInterpretEnd} (which can show that you +%$$ ``almost made it''). +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[If you get a consistency-checking error:] +%$$ +%$$ [From the driver] (These are not as terrible as they seem...) +%$$ +%$$ The driver, notably \tr{driver/ghc-consist.lprl}, runs the SCCS +%$$ program \tr{what} over your executable, and tries to make sense of the +%$$ output. +%$$ +%$$ If you need to make changes to \tr{ghc-consist.lprl}, just do so, then +%$$ re-\tr{make} in the driver directory. +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Compiling the compiler registerisedly:] +%$$ +%$$ If you can successfully compile and run {\em some} registerised +%$$ programs, you are probably ready to compile the compiler in that way. +%$$ \begin{verbatim} +%$$ % cd ghc/compiler +%$$ % ghc-boot-me -c -g -O */*.hc # takes *much more* than a while +%$$ % ghc-boot-me -g -O -o hsc */*.o # LINK! +%$$ \end{verbatim} +%$$ +%$$ (Sun3 note: on the particular system I used, I had link troubles. It +%$$ was apparently a Sun bug, because I got a successful link with the GNU +%$$ linker.) +%$$ +%$$ %--------------------------------------------------------------------- +%$$ \item[Testing the {\em whole} registerised GHC:] +%$$ +%$$ As before, but now you can try compiling from \tr{.hs} to \tr{.hc} +%$$ files with the newly-registerised \tr{hsc}. +%$$ \end{description} +%$$ +%$$ %************************************************************************ +%$$ %* * +%$$ \subsubsection[real-version-fine-tuning]{Fine-tuning of a ``registerised'' version of GHC} +%$$ %* * +%$$ %************************************************************************ +%$$ +%$$ NOT FINISHED YET. Let me know if you get this far :-) +%$$ +%$$ installing +%$$ +%************************************************************************ +%* * +\subsection[Compiler_reconfig]{Building GHC again after you've bootstrapped} +\index{GHC reconfiguration, after booting} +\index{booting, then GHC reconfigure} +\index{native-code generator, after booting} +%* * +%************************************************************************ + +Two reasons why you might want to re-configure and re-build GHC after +an initial boot are: (a)~to get a native-code generator, or (b)~if you +are going to hack on GHC. + +The reason you must rebuild to get a native-code generator: The +\tr{.hc} files will {\em not} turn into a native-code generator, and +the distributed \tr{.hi} files ``match'' those \tr{.hc} files. + +From here on, I presume you've installed your booted GHC as +\tr{ghc-0.26}. + +If you are going for a native-code generator, you can save yourself +some re-compiling by getting a suitable set of interface (\tr{.hi}) +files, for GHC for your machine. You should end up doing, for example: +\begin{verbatim} +cd ghc-0.26/ghc/compiler # note where you are! + +rm */*.o # scrub the old compiler files + +gunzip -c ghc-0.26-hi-files-alpha.tar.gz | tar xfv - +\end{verbatim} + +Now you can configure as before, but using \tr{--with-hc=ghc-0.26} +(\tr{config.status} records what you did before). + +Running \tr{sh < STARTUP} isn't strictly necessary; you only need to +rebuild in \tr{ghc/compiler}: +\begin{verbatim} +cd ghc-0.26/ghc/compiler +make Makefile # if you didn't STARTUP... + +make all EXTRA_HC_OPTS=-fvia-C # -fvia-C important! +make all EXTRA_HC_OPTS=-fvia-C # again, until .hi files settle... +\end{verbatim} + +You might want to to again test GHC ``out of the build'' before you +type \tr{make install} in \tr{ghc/compiler} to finish the job. + +%************************************************************************ +%* * +\section[building-with-HBC]{Building GHC with HBC or other funny Haskell compilers} +\index{GHC, building with HBC} +\index{GHC, building with old GHCs} +\index{GHC, building with other compilers} +%* * +%************************************************************************ + +GHC~0.26 doesn't build with HBC. (It could, but we haven't put in +the effort to maintain it.) + +GHC~0.26 is best built with itself, GHC~0.26. We heartily recommend +it. GHC~0.26 can certainly be built with GHC~0.23 or 0.24, and with +some earlier versions, with some effort. + +GHC has never been built with compilers other than GHC and HBC. + +%$$ If you are going to build the compiler with HBC, +%$$ please get the appropriate set of \tr{.hi} interface +%$$ files. If you going to build with an old GHC, +%$$ visit your psychiatrist first. +%$$ +%$$ If you choose this route, +%$$ you are well advised to get and install a set of \tr{.hi} interface +%$$ files that were created by the same compiler you intend to use. If +%$$ you intend to use HBC, we may provide a suitable ``spare'' set of \tr{.hi} files, +%$$ in \tr{ghc-0.26-hi-files-hbc.tar.gz}, from an FTP site near you. +%$$ +%$$ Unpack the \tr{.hi} files in this {\em somewhat unobvious} way: +%$$ \begin{verbatim} +%$$ % cd ghc-0.26/ghc/compiler # **** this is where you want to be!!! **** +%$$ +%$$ % gunzip -c ghc-0.26-hi-files-hbc.tar.gz | tar xfv - +%$$ \end{verbatim} + +%************************************************************************ +%* * +\section[Pre-supposed]{Installing pre-supposed utilities} +\index{pre-supposed utilities} +\index{utilities, pre-supposed} +%* * +%************************************************************************ + +Here are the gory details about some utility programs you may need; +\tr{perl} and \tr{gcc} are the only important ones. (PVM is important if you're going for Parallel Haskell.) The +\tr{configure} script will tell you if you are missing something. + +\begin{description} +\item[Perl:] +\index{pre-supposed: Perl} +\index{Perl, pre-supposed} +{\em You have to have Perl to proceed!} Perl is a language quite good +for doing shell-scripty tasks that involve lots of text processing. +It is pretty easy to install. + +(We still assume Perl version 4; experience suggests that Perl~5 +is fine, too.) + +Perl should be put somewhere so that it can be invoked by the \tr{#!} +script-invoking mechanism. (I believe \tr{/usr/bin/perl} is preferred; +we use \tr{/usr/local/bin/perl} at Glasgow.) The full pathname should +be less than 32 characters long. + +Perl version 4.035 has a bug to do with recursion that will bite if +you run the \tr{lit2texi} script, when making Info files from +``literate'' files of various sorts. Either use a more recent version +(4.036, or 5.00n) or an older version +(e.g., perl 4.019). + +\item[GNU C (\tr{gcc}):] +\index{pre-supposed: GCC (GNU C compiler)} +\index{GCC (GNU C compiler), pre-supposed} +The current version is 2.7.0, and has no problems that we know of. + +If your GCC dies with ``internal error'' on some GHC source file, +please let us know, so we can report it and get things improved. +(Exception: on \tr{iX86} boxes---you may need to fiddle with GHC's +\tr{-monly-N-regs} option; ask if confused...) + +\item[PVM version 3:] +\index{pre-supposed: PVM3 (Parallel Virtual Machine)} +\index{PVM3 (Parallel Virtual Machine), pre-supposed} +PVM is the Parallel Virtual Machine on which Parallel Haskell programs +run. Underneath PVM, you can have (for example) a network of +workstations (slow) or a multiprocessor box (faster). + +The current version of PVM is 3.3.7. It is readily available on +the net; I think I got it from \tr{research.att.com}, in \tr{netlib}. + +A PVM installation is slightly quirky, but easy to do. Just follow +the \tr{Readme} instructions. + +\item[\tr{xargs} on Solaris2:] +\index{xargs, presupposed (Solaris only)} +\index{Solaris: alternative xargs} +The GHC libraries are put together with something like: +\begin{verbatim} +find bunch-of-dirs -name '*.o' -print | xargs ar q ... +\end{verbatim} +Unfortunately the Solaris \tr{xargs} (the shell-script equivalent +of \tr{map}) only ``bites off'' the \tr{.o} files a few at a +time---with near-infinite rebuilding of the symbol table in +the \tr{.a} file. + +The best solution is to install a sane \tr{xargs} from the GNU +findutils distribution. You can unpack, build, and install the GNU +version in the time the Solaris \tr{xargs} mangles just one GHC +library. + +\item[\tr{bash} (Parallel Haskell only):] +\index{bash, presupposed (Parallel Haskell only)} +Sadly, the \tr{gr2ps} script, used to convert ``parallelism profiles'' +to PostScript, is written in Bash (GNU's Bourne Again shell). +This bug will be fixed. + +\item[Makeindex:] +\index{pre-supposed: makeindex} +\index{makeindex, pre-supposed} +You won't need this unless you are re-making our documents. Makeindex +normally comes with a \TeX{} distribution, but if not, we can provide +the latest and greatest. + +\item[Tgrind:] +\index{pre-supposed: tgrind} +\index{tgrind, pre-supposed} +This is required only if you remake lots of our documents {\em and} +you use the \tr{-t tgrind} option with \tr{lit2latex} (also literate +programming), to do ``fancy'' typesetting of your code. {\em +Unlikely.} + +\item[Flex:] +\index{pre-supposed: flex} +\index{flex, pre-supposed} +This is a quite-a-bit-better-than-Lex lexer. Used in the +literate-programming stuff. You won't need it unless you're hacking +on some of our more obscure stuff. + +\item[Something other than Sun's \tr{/usr/bin/yacc}:] +\index{pre-supposed: non-worthless Yacc} +\index{Yacc, pre-supposed} +If you mess with the Haskell parser, you'll need a Yacc that can cope. +The unbundled \tr{/usr/lang/yacc} is OK; the GNU \tr{bison} is OK; +Berkeley yacc, \tr{byacc}, is not OK. +\end{description} + +%************************************************************************ +%* * +\section[build-pitfalls]{Known pitfalls in building Glasgow Haskell} +\index{problems, building} +\index{pitfalls, in building} +\index{building pitfalls} +%* * +%************************************************************************ + +WARNINGS about pitfalls and known ``problems'': + +\begin{enumerate} +%------------------------------------------------------------------------ +\item +One difficulty that comes up from time to time is running out of space +in \tr{/tmp}. (It is impossible for the configuration stuff to +compensate for the vagaries of different sysadmin approaches re temp +space.) + +The quickest way around it is \tr{setenv TMPDIR /usr/tmp} or +even \tr{setenv TMPDIR .} (or the equivalent incantation with the +shell of your choice). + +The best way around it is to use the \tr{--with-tmpdir=} option +to \tr{configure}. Then GHC will use the appropriate directory +in all cases. + +%------------------------------------------------------------------------ +\item +When configuring the support code (mkworld, glafp-utils, etc.), you +will see mention of \tr{NO_SPECIFIC_PROJECT} and +\tr{NO_SPECIFIC_VERSION}. This is cool. + +%------------------------------------------------------------------------ +\item +In compiling some support-code bits, e.g., in \tr{ghc/runtime/gmp} and +even in \tr{ghc/lib}, you may get a few C-compiler warnings. We think +these are OK. + +%------------------------------------------------------------------------ +\item +In 0.26, when compiling via C, you'll sometimes get ``warning: +assignment from incompatible pointer type'' out of GCC. Harmless. + +%------------------------------------------------------------------------ +%\item +%If you build an ``unregisterised'' build, you will get bazillions of +%warnings about `ANSI C forbids braced-groups within expressions'. +%Especially in \tr{ghc/lib}. These are OK. + +%------------------------------------------------------------------------ +\item +Similarly, \tr{ar}chiving warning messages like the following are not +a problem: +\begin{verbatim} +ar: filename GlaIOMonad__1_2s.o truncated to GlaIOMonad_ +ar: filename GlaIOMonad__2_2s.o truncated to GlaIOMonad_ +... +\end{verbatim} + +%------------------------------------------------------------------------ +\item +Also harmless are some specialisation messages that you may see when +compiling GHC; e.g.: +\begin{verbatim} +SPECIALISATION MESSAGES (Desirable): +*** INSTANCES +{-# SPECIALIZE instance Eq [Class] #-} +{-# SPECIALIZE instance Eq (Class, [Class]) #-} +{-# SPECIALIZE instance Outputable [ClassOp] #-} +{-# SPECIALIZE instance Outputable [Id] #-} +\end{verbatim} + +%------------------------------------------------------------------------ +\item +In compiling the compiler proper (in \tr{compiler/}), you {\em may} get an +``Out of heap space'' error message. These +can vary with the vagaries of different systems, it seems. The +solution is simple: (1)~add a suitable \tr{-H} flag to the \tr{compile} +macro for the offending module, +in \tr{ghc/compiler/Jmakefile} (towards the end); +(2)~re-\tr{make Makefile} in that directory; (3)~try again: \tr{make}. + +Alternatively, just cut to the chase scene: +\begin{verbatim} +% cd ghc/compiler +% make EXTRA_HC_OPTS=-H32m # or some nice big number +\end{verbatim} + +%------------------------------------------------------------------------ +\item +Not too long into the build process, you may get a huge complaint +of the form: +\begin{verbatim} +Giant error 'do'ing getopts.pl: at ./lit2pgm.BOOT line 27. +\end{verbatim} +This indicates that your \tr{perl} was mis-installed; the binary is +unable to find the files for its ``built-in'' library. Speak to your +perl installer, then re-try. + +%------------------------------------------------------------------------ +\item +If you try to compile some Haskell, and you get errors from GCC +about lots of things from \tr{/usr/include/math.h}, then your GCC +was mis-installed. \tr{fixincludes} wasn't run when it should've +been. + +As \tr{fixincludes} is now automagically run as part of GCC +installation, this bug also suggests that you have an old GCC. + +%------------------------------------------------------------------------ +%\item +%Sooner or later in your ``make-worlding'' life you will do and see +%something like: +%\begin{verbatim} +%% make Makefile +% rm -f Makefile.bak; mv Makefile Makefile.bak +%../.././mkworld/jmake -P ghc -S std -I../.././mkworld -DTopDir=../../. -DTopDir=... +%../.././mkworld/jrestoredeps +%==== The new Makefile is for: ==== +%make: Fatal error in reader: Makefile, line 850: Unexpected end of line seen +%Current working directory /export/users/fp/grasp/ghc-0.26/ghc/runtimes/standard +%*** Error code 1 +%make: Fatal error: Command failed for target `Makefile' +%\end{verbatim} +% +%Don't panic! It should restore your previous \tr{Makefile}, and +%leave the junk one in \tr{Makefile.bad}. Snoop around at your leisure. + +%------------------------------------------------------------------------ +%\item +%If you do corrupt a \tr{Makefile} totally, or you need to glue a new +%directory into the directory structure (in \tr{newdir}---which must +%have a \tr{Jmakefile}, even if empty), here's a neat trick: +%\begin{verbatim} +%# +%# move to the directory just above the one where you want a Makefile... +%cd .. +%# +%# make Makefiles, but lie about the directories below... +%make Makefiles SUBDIRS=newdir +%\end{verbatim} +% +%This will create a \tr{Makefile} {\em ex nihilo} in \tr{newdir}, and +%it will be properly wired into the general make-world structure. + +%------------------------------------------------------------------------ +%\item +%Don't configure/build/install using a variety of machines. A +%mistake we've made is to do \tr{make Makefiles} on a Sun4, then try to +%build GHC (\tr{make all}) on a Sun3. + +%------------------------------------------------------------------------ +\item +If you end up making documents that involve (La)TeX and/or \tr{tib} +(Simon's favourite), the odds are that something about your/our setup +will reach out and bite you. Yes, please complain; meanwhile, +you can do \tr{make -n whatever.dvi} to see the intended commands, +then try to muddle through, doing them by hand. + +%------------------------------------------------------------------------ +%\item +\end{enumerate} + +%************************************************************************ +%* * +\section[weird-configs]{Making weird GHC configurations} +\index{GHC unusual configurations} +%* * +%************************************************************************ + +The usual way to build a ``weird'' GHC configuration is to turn +various \tr{configure} knobs, e.g., \tr{--enable-concurrent}. +Please see \sectionref{Configuring-GHC} about GHC configuring. + +If you want to build some Very Customised GHC libraries, it's +probably best to send email to us, asking how. + +%$$ Usually, you will build whatever libraries your chosen ``setup'' +%$$ specifies. However, perhaps you are a hacker, and you want an extra +%$$ ``ticky-ticky profiling'' version of the libraries. (Or, you want a +%$$ version compiled with your Very Own Optimisation...) +%$$ +%$$ To create a ``user way'' or setup, put +%$$ something like this somewhere (more on ``somewhere'', below): +%$$ \begin{verbatim} +%$$ #ifndef GhcBuild_UserWay_a +%$$ #define GhcBuild_UserWay_a YES +%$$ GHC_USER_WAY_FLAG_a = -ticky +%$$ GHC_USER_WAY_OPTS_a = -fstg-reduction-counts -O +%$$ #endif /* ! GhcBuild_UserWay_a */ +%$$ \end{verbatim} +%$$ You'll be able to invoke the driver with a \tr{-ticky} option, which +%$$ will be as if you typed in all that other stuff. It will also arrange +%$$ that there is a version of the prelude (\tr{libHS_a.a} library, +%$$ \tr{Prelude_a.hi} to match) and runtime system (\tr{libHSrts_a.a}) to +%$$ match. (Neat, huh?) +%$$ +%$$ On the ``somewhere'' to specify what to build: If you don't plan +%$$ to re-\tr{configure}, just change \tr{site-ghc.jm}. If you do plan to +%$$ re-\tr{configure}, change \tr{site-ghc.jm.in} and re-\tr{configure} +%$$ immediately. +%$$ +%$$ One note about {\em adding} ``user setups'' to an existing build: +%$$ Besides remaking your \tr{Makefiles} straight away, {\em don't forget} +%$$ to remake the driver (in \tr{ghc/driver}) before making any libraries! +%$$ The short cut is: +%$$ \begin{verbatim} +%$$ cd ..../ghc/driver +%$$ make Makefile; make all +%$$ cd ../runtime +%$$ make Makefile; make all +%$$ cd ../lib +%$$ make Makefile; make all +%$$ \end{verbatim} + +\upsection + +%************************************************************************ +%* * +\section[building-Haggis]{Building Haggis (Haskell GUI toolkit)} +\index{Haggis, building} +\index{building Haggis} +%* * +%************************************************************************ + +NOT DONE YET. + +%************************************************************************ +%* * +\section[building-Happy]{Building Happy (Haskell parser generator)} +\index{Happy, building} +\index{building Happy} +%* * +%************************************************************************ + +NOT DONE YET. + +%************************************************************************ +%* * +\section[building-NoFib]{Building NoFib (Haskell benchmark suite)} +\index{NoFib suite, building} +\index{building the NoFib suite} +%* * +%************************************************************************ + +NOT DONE YET. + +%************************************************************************ +%* * +\section[Configuring]{Running \tr{configure}} +\index{configure script} +%* * +%************************************************************************ + +The GNU-style \tr{configure} script figures out things which we need +to know to build one or more Glasgow tools for your machine. Also, +\tr{configure} lets you specify what you want built. + +Most people will configure/build one tool at a time. The +``short-cut'' instructions +for GHC are in \sectionref{Configuring-GHC}, +for Haggis in \sectionref{Configuring-Haggis}, +for Happy in \sectionref{Configuring-Happy}, +and for NoFib in \sectionref{Configuring-NoFib}. + +However, \tr{configure} lets you pick and choose, so you can build +several things ``in a one-er''. Just fling in all the options +at once, and be amazed. + +%************************************************************************ +%* * +\subsection[Configuring-general]{\tr{configure} options for all tools} +\index{Configuring (general)} +%* * +%************************************************************************ + +Many \tr{configure} options apply no matter what tools you are building. + +\begin{description} +\item[\tr{--help}:] (a standard GNU option) +\index{--help configure option} +Prints out a long usage message. The first part is GNU boilerplate; +after that is the Glasgow info. + +\item[\tr{--prefix=}{\em directory}:] (a standard GNU option) +\index{--prefix configure option} +Sets the ``root'' directory for where a system should be installed; +defaults to \tr{/usr/local}. + +With Happy, for example, the main \tr{happy} binary will end up in +\tr{/usr/local/bin/happy}. + +%-------------------------------------------------------------- +\item[\tr{--exec-prefix=}{\em directory}:] (a standard GNU option) +\index{--exec-prefix configure option} +Sets the ``root'' directory +for where executables +(e.g., the GHC driver) should be installed; defaults to whatever +\tr{--prefix} is, +meaning that things will be installed in \tr{/usr/local/bin}. + +%$$ At Glasgow, we want such executables to go in (e.g.) +%$$ \tr{/local/fp/bin.sun4}, so \tr{--exec-prefix} is no use to us. +%$$ Happily, there's more than one way to do it!---just change +%$$ \tr{InstBinDir_GHC} in \tr{ghc/mkworld/site-ghc.jm.in}... (We hope +%$$ this doesn't bring back too many bad memories for our +%$$ pre-\tr{configure} users.) + +%-------------------------------------------------------------- +\item[\tr{--with-hc=}{\em hask}:] +\index{--with-hc configure option} +Use {\em hask} as my ``installed Haskell compiler.'' + +The name {\em hask} has to be one of \tr{ghc*} (for Glasgow Haskell), +\tr{hbc*} (for Chalmers HBC), or \tr{nhc*} (for Rojemo's NHC). +We hope to add more! + +As a special case, \tr{--with-hc=c} means ``I don't have a Haskell +compiler, please compile from intermediate C files (produced by GHC +somewhere else).'' + +%-------------------------------------------------------------- +\item[\tr{--with-tmpdir=}{\em directory}:] +Set the directory where temporary files should be created. This is +\tr{/tmp} by default, which is Sometimes Uncool (because, e.g., +\tr{/tmp} is too small). There's just no telling. + +On our Alphas, for example, we use \tr{--with-tmpdir=/usr/tmp}. + +%-------------------------------------------------------------- +\item[\tr{--with-max-heap=}{\em size}:] +When whatever Haskell compiler is run while building the Glasgow +tools, it will try to use some sane-but-not-too-big heap size. If you +have a machine with plenty of memory, you might want to say ``Go ahead +and use a great big heap.'' This option allows this. So, for +example, on our Alphas we might say \tr{--with-max-heap=48m}. +\end{description} + +%************************************************************************ +%* * +\subsection[Configuring-GHC]{GHC-specific things in \tr{configure}} +\index{Configuring for GHC} +%* * +%************************************************************************ + +The easiest way to see all the \tr{configure} options for GHC is to +type \tr{./configure --help}. (I don't feel like typing the whole +thing again, into this document...) + +Some common combinations would be: + +\begin{verbatim} +./configure --prefix=/users/fp/partain --with-hc=c --disable-profiling + # use .hc files; don't bother with profiling + +./configure --with-hc=ghc-0.26 --with-readline-library --with-sockets-library + # simple build with itself; for Sun4s & Alphas, you + # should grab & use ghc-0.26-hi-files-.tar.gz + # (because those machines have a native-code generator). + # For the extra libraries, you've got to have the right + # stuff to link to. + +./configure --with-hc=ghc-0.26 --disable-hsc-optimised --enable-hsc-debug + # Don't use -O on GHC itself; turn on -DDEBUG. + # Slows things way down, but it's the right thing if + # you're hacking on GHC and doing lots of recompilations. + +./configure --with-hc=c --enable-concurrent --enable-parallel --with-tmpdir=/usr/tmp + # Do everything from .hc files; besides the normal ones, + # you'll need the "prof", "conc" and "par" .hc files. + # Use /usr/tmp as TMPDIR... +\end{verbatim} + +Remember, if you build \tr{--with-hc=c} on a Sun4 or Alpha, you +do {\em not} have a native-code generator. + +%************************************************************************ +%* * +\subsection[Configuring-Haggis]{Haggis-specific things in \tr{configure}} +\index{Configuring for Haggis} +%* * +%************************************************************************ + +Use \tr{--enable-haggis}. If you have Haggis and GHC in the same +build tree but only want to build Haggis, use \tr{--disable-ghc}. + +MORE TO COME. + +%************************************************************************ +%* * +\subsection[Configuring-Happy]{Happy-specific things in \tr{configure}} +\index{Configuring for Happy} +%* * +%************************************************************************ + +Use \tr{--enable-happy}. If you have Happy and GHC in the same +build tree but only want to build Happy, use \tr{--disable-ghc}. + +MORE TO COME. + +%************************************************************************ +%* * +\subsection[Configuring-NoFib]{NoFib-specific things in \tr{configure}} +\index{Configuring for NoFib} +%* * +%************************************************************************ + +Use \tr{--enable-nofib}. If you have NoFib and GHC in the same build +tree but only want to build the NoFib suite, use \tr{--disable-ghc}. + +You may want to enable or disable various sets of tests, as +suggested by \tr{./configure --help}. If you use \tr{--enable-all-tests}, +be aware that many of them are GHC-specific. Also, we may not have +given you all of the source :-) + +%************************************************************************ +%* * +\section[STARTUP]{Running \tr{STARTUP}} +\index{STARTUP script} +%* * +%************************************************************************ + +Once you've \tr{configure}d, utter the magic incantation: +\begin{verbatim} +% sh < STARTUP >& startup.log +\end{verbatim} +The reason you might want to pipe the chatter into a file is so you +can check it afterwards. It should be pretty obvious if it is happy. +Note: it takes a little while. + +\tr{STARTUP} is a simple shell script that builds \tr{mkworld} +(Makefile-generating system), \tr{literate} (literate-programming +system), and \tr{glafp-utils} (a few utility programs); then makes the +Makefiles and dependencies for everything. + +If you have any problems before getting through \tr{STARTUP}, you +are probably best off re-running \tr{configure} and \tr{STARTUP} +(after fixing what was broken). + +%************************************************************************ +%* * +\section[utils_install]{Installing the support software (optional)} +\index{utilities, installing} +%* * +%************************************************************************ + +By default, the support software that comes with the Glasgow +tools---\tr{mkworld}, \tr{literate}, and \tr{glafp-utils}---is not +installed. However, they're generally-useful tools, so... + +If you did want to install the ``make world'' system, for example: +\begin{verbatim} +% cd /mkworld +% make install +\end{verbatim} + +If it isn't installing things where you want it to, you can either +fiddle things on the fly... +\begin{verbatim} +% make install prefix=/home/sweet/home +\end{verbatim} + +If you want to install just one utility, for example \tr{lndir}: +\begin{verbatim} +% cd /glafp-utils/scripts +% make install_lndir +\end{verbatim} + +``Make world''---It slices, it dices... it's great! + +%************************************************************************ +%* * +\section[arrangement-of-sources]{Arrangement of the sources} +%* * +%************************************************************************ + +Once you un\tr{tar} the Glorious Haskell Compilation (GHC) system sources +and \tr{cd} into the top directory, here's a bird's-eye view of what +you should see: + +\begin{tabular}{ll} +mkworld/ & ``Make world'' sub-system for configuring the system.\\ + & \\ +glafp-utils/ & Utility programs and scripts used in building the distribution;\\ + & often acquired from elsewhere. \\ +literate/ & Glasgow literate programming sub-system. \\ + & \\ +ghc/driver/ & The driver program for GHC; \\ + & currently a perl script, \tr{ghc}. \\ + & \\ +ghc/compiler/ & The Haskell compiler proper, called \tr{hsc}; \\ + & source files are in \tr{compiler/*/[A-Z]*.lhs}. \\ + & \\ +ghc/runtime/ & The runtime system, including the garbage-collector(s).\\ + & \\ +ghc/lib/prelude/& Source for the linked-in code for the ``standard prelude''. \\ +ghc/lib/glaExts/ & Source for the linked-in code for our Glasgow extensions. \\ +ghc/lib/haskell-1.3/ & Source for the linked-in code for Haskell 1.3 I/O. \\ +ghc/lib/hbc/ & Source for the HBC `system library'. \\ +ghc/lib/ghc/ & Source for the GHC `system library'.\\ + & \\ +ghc/includes/ & The ``public'' .hi files slurped by the parser, \\ + & and .h files \tr{#include}d in generated .hc files come from.\\ + & \\ +ghc/docs/ & documents; see the README file there. \\ + & \\ +ghc/CONTRIB/ & reserved for contributed things \\ +haggis/ & Haggis Haskell X11 GUI toolkit \\ +happy/ & Happy Haskell parser generator \\ +nofib/ & NoFib Haskell benchmark and test suite \\ +\end{tabular} + +\begin{onlystandalone} +\printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/docs/release_notes/0-02-notes.lit b/ghc/docs/release_notes/0-02-notes.lit new file mode 100644 index 0000000..3d4e69c --- /dev/null +++ b/ghc/docs/release_notes/0-02-notes.lit @@ -0,0 +1,230 @@ +\section[0-02-limitations]{Limitations of Glasgow \Haskell{}, release~0.02} + +[Scribe for the 0.02 notes: Cordy Hall.] + +These are the current major limitations of release~0.02, +and a way to get around each if there is one. + +\begin{enumerate} +\item +{\em Doesn't yet track version~1.1 of the \Haskell{} Report.} +If you are lucky, sections might work anyway... +\item +{\em No automatic importation of Prelude.} You can add an import of +module @MiniPrel@, which is in \tr{lib/prelude/MiniPrel.hi}, and +extend your own version of this file as you wish as long as you do not +add anything currently built into the compiler. The following are +already built in (see \tr{compiler/typecheck/PrelCoreEnv.lhs}): +\begin{itemize} +\item +the boolean data type +\item +the string data type +\item +the primitive Haskell types, @Int@, @Char@, @Integer@, @Float@, @Double@ +\item +function type +\item +list type +\item +tuple type (up to and including 5 tuples) +\item +random unboxed types (@IntPrim@, @StringPrim@, etc.) +\item +class @Eq@ with all operations, and the following instances: +@Integer@, @Int@, @Rational@, @List@, @Char@, 2 tuple +\item +class @Ord@ with all operations, and the following instances: +@Integer@, @Int@ +\item +class @Num@ with all operations, and the following instances: +@Integer@, @Int@, @Rational@ +\item +class @Fractional@ with all operations, and the following instances: +@Integer@, @Rational@ +\item +cons @(:)@ and @[]@ +\end{itemize} +\item +{\em No renaming} +\item +{\em No selective export} +\item +{\em No re-export of imported entities} +\item +{\em No contexts in data declarations} +\item +{\em No ambiguity resolution for numeric types} +\item +{\em No overloaded numeric patterns or @n+k@ patterns} +\item +{\em No deriving clause on data type declarations.} You can get around this +by creating explicit instances for the data type. For example, if you wanted +to derive @Eq@ for the data type + +\begin{verbatim} +data T a = D (B a) | C +data B b = X | Y b +\end{verbatim} + +then you would write + +\begin{verbatim} +import MiniPrel + +data T a = D (B a) | C +data B b = X | Y b + +instance (Eq a) => Eq (T a) where + (D x) == (D y) = x == y + C == C = True + a == b = False + + a /= b = not (a == b) + +instance (Eq b) => Eq (B b) where + X == X = True + (Y a) == (Y b) = a == b + a == b = False + + a /= b = not (a == b) +\end{verbatim} + +The reason that @MiniPrel@ is imported is that it provides a type for @not@. +\item +{\em No default methods in class declarations} +\end{enumerate} + +So far, operations on @Int@s will have code generated for them +but more work needs to be done to handle other types +in the code generator. However, all of the above should be handled by the +typechecker. + +Other limitations: +\begin{itemize} +\item +Error messages need lots of improvement. +\item +The generated code is inefficient, and it takes a long time to generate it. +\item +Documentation is minimal. +\item +The only programs that compile and run are those for which @main@ has +type @Int@!!! Examples in \tr{compiler/tests/codeGen}... +\end{itemize} + +\section[0-02-new-tools]{New Tools} + +Programs with type errors can be difficult to correct +without some help. Unfortunately, providing this help is a difficult research +problem. Wand's recent POPL paper suggests an interesting approach, but it +costs overhead even when the code typechecks. Instead, we've taken the +following approach: + +\begin{enumerate} +\item +People who program in functional languages like interpreters because they + can find out how a small function behaves, and then deduce how it will + behave in a larger context. + +\item + Type checking is rather like debugging, so it would be nice to give the user + something that would allow probing of function and expression types + within the context of the rest of the program. + +\item + To do this, we allow the user to attach a special type variable as a + signature to any function definition or expression of interest. The + typechecker can then textually substitute the type of that expression for + the signature, and print out the original program. +\end{enumerate} + +For example, in the following program + +\begin{verbatim} +f x = ((g :: tyreq1) 'a',(g :: tyreq2) True) + where + g x = x +\end{verbatim} + +the type variables @tyreq1@ and @tyreq2@ are seen as special by the compiler. +The program printed out is: + +\begin{verbatim} +f x = ((g :: Char -> Char) 'a',(g :: Bool -> Bool) True) + where + g x = x +\end{verbatim} + +If the program was instead + +\begin{verbatim} +f x = (g 'a', True) + where + g :: tyreq1 + g x = x +\end{verbatim} + +then the program printed out would be + +\begin{verbatim} +f x = (g 'a', g True) + where + g :: a -> a + g x = x +\end{verbatim} + +A note about these `special type variables'---the user must guarantee +(at present) that each is unique, and that each +begins with the string @tyreq@. + +At present, the typechecker fails whenever there is a type error. Once +it can be made to succeed on errors, handing control to something +which can deal with this situation, then it will be easy to get some +idea of what the typechecker thought about interesting expressions in +the code, even though these types may not yet be fully defined. {\em For +now, this tool is really only useful if you have a program that does +typecheck (avoiding failure) but you wish to examine some of the types +of the program's expressions.} + +To use this feature, the compiler must be built using the +\tr{-DTYPE_ERROR_HELP} +flag (change \tr{compiler/Jmakefile} in the appropriate place). When +invoking the driver \tr{driver/ghc}, use the \tr{-ddump-type-error} +flag. + +If you do use this and/or have any comments to make, please email to +cvh\@dcs.glasgow.ac.uk. + +\section[0-02-instabilities]{Known instabilities in the compiler internals} + +Here are some things we know we are going to change in the internals +of the compiler. Fellow developers may want to query these if they +think that they may be adversely affected. + +\begin{enumerate} +\item +A modest revision to the basic data types for variables, constructors, +and type variables (currently in \tr{compiler/names/{Local,Global}.lhs} +and in \tr{compiler/absSyntax/UniType.lhs}). See +\tr{compiler/names/Id.lhs} for our notes on what to do. + +\item +A major overhaul of the pretty-printing and error-reporting machinery. + +\item +A major overhaul of the ``make world'' machinery. Ideas welcome. + +\item +A fairly significant module-renaming exercise. A proposal, not yet +agreed, is in \tr{docs/FILE-RENAMING}. +\end{enumerate} + +\section[0-02-other-problems]{Other known problems in the distribution} + +The GNU Info-file reader (\tr{literate/info-utils/info.c}) is an +unusually buggy version, for some reason. + +The tests files have been stripped out of this release, merely to +reduce the sheer volume of the distribution. Let us know if you want +the test files. diff --git a/ghc/docs/release_notes/0-03-README b/ghc/docs/release_notes/0-03-README new file mode 100644 index 0000000..516e449 --- /dev/null +++ b/ghc/docs/release_notes/0-03-README @@ -0,0 +1,47 @@ +Version 0.03 of the new Glasgow Haskell compiler was an unannounced +(exceedingly unpolished) release for our friends at York. + +------------------------------------- + +A quick list of things to note: + +* Significantly different parser (parsers/hsp/) and reader + (compiler/reader/), to do Haskell 1.1 syntax. The abstract syntax + (compiler/abstractSyn/) now covers the entire Haskell language. + +* Compiler files have been majorly shuffled, renamed, in part to + ensure filenames are <= 14 chars. Another such catastrophic + re-shuffle is unlikely for the foreseeable future. + + The file docs/FILE-RENAMING is a fairly complete list of + what-changed-to-what. + +* Pretty-printing machinery (compiler/utils/{Pretty,Outputable}.lhs) + is completely changed. + +* Identifiers are now "Ids" (compiler/basicTypes/Id.lhs), not "Locals" + or "Globals". + +* What-the-compiler-must-know-about-the-prelude (compiler/prelude) is + believed to be complete; this includes Chars, Ints, Floats, and + Doubles as primitives. + + (Stuff for Integers and Rationals is NOT all there.) + + All other prelude stuff should be specifiable w/ an ordinary + interface file (notably lib/prelude/MiniPrel.hi). + +* The compiler does full-blown overloading of expressions and + patterns. Yell if this really won't do -- perhaps a build-time + option to override? + +* All flavours of patterns and expressions (e.g., n+k patterns, + arithmetic sequences) are in; testing in some cases near zero. + +* BUGS INEVITABLE, MAJOR BUGS ENTIRELY POSSIBLE, PATCHES WILL PROBABLY + BE REQUIRED. Don't panic, report promptly! + +* "main"'s (main/Main.lhs) handling of command-line options [and the + feeding of same by the driver, driver/ghc.lprl] has been revised. + +* Documentation has _not_ been updated. diff --git a/ghc/docs/release_notes/0-04-README b/ghc/docs/release_notes/0-04-README new file mode 100644 index 0000000..14be2b0 --- /dev/null +++ b/ghc/docs/release_notes/0-04-README @@ -0,0 +1,15 @@ +Version 0.04 of the new Glasgow Haskell compiler was yet another +unannounced release for our friends at York (and elswhere). + +---------------------------------------------------------------- +91/11/01: + +2 notes: [1] "main" should no longer have the non-std type "Int"; instead, +it should have the non-std type "IOPrim"! (We're creeping towards +real Haskell I/O.) compiler/tests/codeGen/cg001/Main.hs is a New +Improved "main", I believe. docs/io-design may also be useful. +[2] The old "import MiniPrel" trick has changed (and will change +again). Because we're in the middle of trying to get full/original +names going, you have to use one or more MODULE-SPECIFIC +"MiniPrel*.hi" files; they're in lib/prelude. + diff --git a/ghc/docs/release_notes/0-05-notes.lit b/ghc/docs/release_notes/0-05-notes.lit new file mode 100644 index 0000000..3f42108 --- /dev/null +++ b/ghc/docs/release_notes/0-05-notes.lit @@ -0,0 +1,86 @@ +\begin{description} +%------------------------------------------------------------------- +\item[1.1 syntax:] +Does \Haskell{} version~1.1 syntax. The code for the parser +(\tr{parsers/hsp/}) has been tidied up quite a bit [nice job, Kevin]. + +%------------------------------------------------------------------- +\item[Expressions and patterns:] +All forms of expressions and patterns work, including overloaded +patterns and @n+k@ patterns. + +%------------------------------------------------------------------- +\item[A big part of the standard prelude is operational:] +These parts (in \tr{lib/prelude}) have been compiled with the new +compiler, and programs compiled with the new compiler can be linked to +it. + +With the exceptions of (a)~hooking in the standard Haskell I/O system +(see next item) and (b)~special pleading for constant-time-access +arrays (or other magical features), all Prelude stuff is either done +or easily do-able. + +%------------------------------------------------------------------- +\item[Simple resolution of ambiguous overloading of numeric types:] +(As per Haskell report, section~4.3.4). @default@ declarations do +{\em NOT} work; however, the ``default default'' +(@default (Int, Double)@) is wired in. This should clear up nearly +all annoying ``ambiguous dictionary'' errors. + +%------------------------------------------------------------------- +\item[Better non-standard I/O:] +We have implemented the bare bones of the I/O described in +\tr{docs/io-design/}. It's not standard \Haskell{} I/O +(we haven't yet implemented the impedance-matcher discussed in the +doc), and it's not the same as what was there in 0.02. However, you +can now write a simple reads-stdin/writes-stdout program: + +\begin{verbatim} +#include "GhcPrelude.h" + +main = readString `thenIO` ( \ s -> + writeString (my_String_to_String_manglification s) ) +\end{verbatim} + +The implementation of @error@ (via @sysError@) is also as described in +the I/O document. + +%------------------------------------------------------------------- +\item[Faster compiler:] +The compiler is faster than version~0.02---we promise---but the +significant tuning work is not yet done. We will do it after The +Mangler (renamer) is in. + +%------------------------------------------------------------------- +\item[Run compiled code on a Sun4:] +If you compile your program to C (\tr{.hc} files), with, e.g.: + +\begin{verbatim} +% glhc -C Foo.hs +\end{verbatim} + +then you compile the output on a Sun4 with: + +\begin{verbatim} +% glhc -c Foo.hc +\end{verbatim} + +and, if you have the right things to link to, you can link with: + +\begin{verbatim} +% glhc -o foo Foo.o +\end{verbatim} + +The ``right things to link to'' include: the runtime system ( +\tr{cd runtimes/standard; make} on a sun4), and the standard libraries +(\tr{cd lib; make all} on a sun4). + +We have not yet tried to make this work for Every Known Unix Box In +The Universe. (But we plan to, with your help :-) + +%------------------------------------------------------------------- +\item[Upheaval during FPCA:] +As advertised with 0.02: Files moved around, modules and data types +were renamed, and a generally Much Cleaner World now exists. We have +no plans to do more of the same (at least for the compiler proper). +\end{description} diff --git a/ghc/docs/release_notes/0-06-notes.lit b/ghc/docs/release_notes/0-06-notes.lit new file mode 100644 index 0000000..e91ceac --- /dev/null +++ b/ghc/docs/release_notes/0-06-notes.lit @@ -0,0 +1,266 @@ +The really new thing about release 0.06 is this: if you can get +your program through the compiler, then it should actually work when you +run it! + +Another thing we have worked hard on recently is {\em documentation} (see +next section). + +%************************************************************************ +%* * +\subsection[0-06-new-docs]{New documentation, especially for hackers!} +%* * +%************************************************************************ + +See the file \tr{docs/README} for a full ``roadmap'' to all known +documentation. + +\begin{description} +%------------------------------------------------------------------- +\item[STG-machine paper.] +A monster (70+-page) paper which gives a detailed description of the +Spineless Tagless G-machine, on which the back end of the compiler is based. +Simon is Jolly Proud of this paper. + +This paper isn't in the distribution, but is available by asking +Simon, or by FTP from \tr{ftp.dcs.glasgow.ac.uk:pub/glasgow-fp/stg.dvi}. +%------------------------------------------------------------------- +\item[\tr{imports/SMinterface.lh}.] +The storage manager is carefully isolated from the rest of the runtime +system behind a carefully identified interface. This paper documents +the interface, and says a little about the implementation. NB: +``literate'' \tr{.h} file! +%------------------------------------------------------------------- +\item[\tr{docs/C_optimisation}.] +Lots of details about how we use C as a target language, and +the tricks we use to make it go fast. Still drafty. +%------------------------------------------------------------------- +\item[\tr{docs/runtime}.] +The {\em beginnings} of a description of details of the runtime system +which aren't covered by the STG paper above. +%------------------------------------------------------------------- +\item[\tr{docs/typecheck}.] +The {\em beginnings} of a description of tricky corners of the type checker. +%------------------------------------------------------------------- +\item[\tr{docs/arrays}.] +A work-in-progress on how to handle arrays properly. +%------------------------------------------------------------------- +\item[\tr{docs/core-overview}:] +The beginnings of a description of the Core data type, plus the other +data types you need to know about to write programs which manipulate +the Core data type. + +The ``how to add to the compiler'' document +(\tr{docs/add_to_compiler}) has some of this stuff in it, too. +%------------------------------------------------------------------- +\item[Type classes paper:] +This is a short (20-page) form of the massive ``Static Semantics of +Haskell'' paper. We submitted it to Lisp and FP 1992, but they +(unaccountably) rejected it. + +This paper isn't in the distribution; please ask for it. +\end{description} + +%************************************************************************ +%* * +\subsection[0-06-new-in-compiler]{To do with the compiler proper} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +%------------------------------------------------------------------- +\item[1.2 syntax:] +The parser handles the Haskell syntax given in the Haskell report, +version~1.2. See \tr{parsers/hsp}. + +%------------------------------------------------------------------- +\item[Graph reduction:] +Updates are in and we're doing graph reduction! (All the bells and +whistles for doing a good job of [avoiding] updates are not +in yet.) + +See \tr{compiler/codeGen/{CodeGen,CgClosure}.lhs} and +\tr{runtime/main/Update.lhc} for the main bits. + +%------------------------------------------------------------------- +\item[Closure layout less deeply wired into compiler:] +Rather than knowing word-for-word how each closure is layed out in +memory, the compiler emits C macro calls to access/fill-in the ``fixed +header'' and ``variable header'' parts of each closure (all described +in the storage-manager document). + +This means, for example, that the very same C code used on sequential +machines can be used on GRIP as well, even though closures in GRIP +have some extra fields---all that is required is suitable \tr{.h} +files to define the header macros accordingly! + +Anyone whose efforts involve munging around in or pinning things onto +closures should like this ``feature.'' + +%------------------------------------------------------------------- +\item[Statistics about program execution:] +The compiler emits macro calls into the C output which, if expanded +(use @-DDO_RUNTIME_PROFILING@, default: on), will accumulate +statistics about program behaviour. To have those statistics printed +out (to @stderr@), give your program the @-p@ RTS flag, thusly: + +\begin{verbatim} +% a.out +RTS -p +\end{verbatim} + +We welcome any interesting profiles that you may churn up! + +See \tr{imports/StgProfile.h} and \tr{runtime/main/StgProfile.lc}, +plus insertions of those macro calls in +\tr{compiler/codeGen}. + +%------------------------------------------------------------------- +\item[New simplifier/transformation stuff:] +Contributed by research students Andr\'e Santos and Andy Gill. In +\tr{compiler/simplify} and \tr{compiler/stranal-triv}; it's still +thoroughly experimental. + +The old-but-reliable brain-damaged simplifier is now in +\tr{compiler/simplify0} and is still the default. + +%------------------------------------------------------------------- +%\item[Faster compiler:] +% (NOT QUITE YET) The compiler is again faster than the previous release +% (version~0.05). The C output is also smaller. + +%------------------------------------------------------------------- +\item[Compiler is compilable with Chalmers's HBC or Glasgow prototype compiler:] +The default set of \tr{compiler/*/*.hi} interface files in the +distribution are for compiling with HBC (this seems to be the people's +preference); version 0.997.3 or greater, please. + +A separate set of \tr{.hi} files are provided for those who use the +Glasgow prototype compiler. These are in the file +\tr{ghc-0.06-proto-hi-files.tar.Z}, available wherever you got the +basic distribution. The installation document says how to deal with +these various blobs of files. + +The possibility of using HBC means you can compile the Glasgow Haskell +compiler on any machine supported for HBC (Sun3s, Sun4s, DEC 3100s +[and one or two more flavours?]). +\end{description} + +%************************************************************************ +%* * +\subsection[0-06-new-in-compiler-contrib]{In contributed bits of the compiler} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[Semantique strictness analyser:] +The one in the distribution now builds; in \tr{compiler/stranal-sem}. +This would only be of interest to those who might want to play with +it. The rest of the compiler can't use its results. + +If you want to build this strictness analyser, you need to configure +appropriately (see \tr{mkworld/Project-ghc-full.*}, when you get to +that part of the installation instructions). +\end{description} + +Please send us {\em your} bits for next time! + +%************************************************************************ +%* * +\subsection[0-06-new-in-libraries]{In @Prelude@ and runtime support} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[``Binary bloat'' from the prelude, ameliorated:] +The C files produced from compiling the prelude are chopped into +some 400 separate C files, which are individually compiled and +banged into an archive. Result is that you only get the bits you +``need,'' and binary sizes have about halved. +(There is more work to do in this department.) + +%------------------------------------------------------------------- +\item[Naive implementation of Haskell I/O:] +At least \tr{ReadChan stdin} and \tr{AppendChan stdout} requests work. +It shouldn't be too hard to add support for other requests in +\tr{lib/io/DialogueToIO.lhs}. (Only [extended] Haskell hacking needed!) + +%------------------------------------------------------------------- +\item[Storage management moved behind a safe wall:] + +It's now in \tr{runtime/storage/.} All four flavours of garbage +collector (two-space copying, one-space compacting, dual-mode, and +Appel-like generational) seem to work. + +Patrick Sansom, research student and hacker extraordinaire, did all +of this. + +%------------------------------------------------------------------- +\item[Flags-to-RTS machinery in place:] + +When your @ghc@-compiled Haskell program starts up, any command-line +arguments bracketted by @+RTS@ and @-RTS@ (or the end of the arguments) +are assumed to be flags for the runtime system. These flags are used +to alter the heap size, ask for garbage-collection stats, etc. + +To see what flags are available, try: \tr{myprog +RTS -f}. + +Patrick did this, too. + +%------------------------------------------------------------------- +\item[C-optimisation sleaziness also better hidden:] + +It is in \tr{runtime/c-as-asm/}. (It needs to be tidier, but...) + +We are still actively working on getting this right. Please get in +touch if you are interested. +\end{description} + +%************************************************************************ +%* * +\subsection[0-06-new-in-mkworld]{In distribution/build/installation machinery} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[Better line numbers, and Emacs-able TAGS files:] +(Yes, they're related!) Error messages should come out with better +line numbers than before. + +The distribution now includes tags-making things: souped-up \tr{etags} +program [for C], \tr{perltags} [for perl], and \tr{hstags} [for +Haskell] (mostly in \tr{utils/scripts}). The Haskell tags program +uses the parser, so it Does It Right. + +\tr{make tags fulltags} at the top of the distribution tree will make a +huge TAGS file for the whole compilation system. + +%------------------------------------------------------------------- +\item[\tr{make install} might do something sensible:] +Yes, it does. But you'd be well advised to do a \tr{make -n install} +just to check first! +\end{description} + +%************************************************************************ +%* * +\subsection[0-06-new-misc]{Miscellaneous new things} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[Consistency-checking for executables:] +Given that our system can generate \tr{.o} object files which are +seriously {\em incompatible} with each other, depending on choice of +garbage collector, degree of optimisation, whether or not compiling +for GRIP, etc., we have implemented a scheme (in the driver \tr{ghc}) +that checks that all the linked bits in an executable ``belong'' +together. + +%------------------------------------------------------------------- +\item[Scripts from Denis Howe:] +We have included his \tr{fptags} and \tr{mira2hs} scripts that he +posted to \tr{comp.lang.functional}. +\end{description} diff --git a/ghc/docs/release_notes/0-07-README b/ghc/docs/release_notes/0-07-README new file mode 100644 index 0000000..4048f17 --- /dev/null +++ b/ghc/docs/release_notes/0-07-README @@ -0,0 +1,4 @@ +Version 0.07 was an unannounced not-really-a-release to a few diehard +friends. Much of what is described in the 0.08 release notes was +actually done in 0.07. Please see the 0.08 release ntoes for further +details. diff --git a/ghc/docs/release_notes/0-07-notes.lit b/ghc/docs/release_notes/0-07-notes.lit new file mode 100644 index 0000000..7b729d6 --- /dev/null +++ b/ghc/docs/release_notes/0-07-notes.lit @@ -0,0 +1,51 @@ +%************************************************************************ +%* * +\section[0-07-new]{New things in Glasgow \Haskell{}, release~0.07} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[0-07-new-docs]{New documentation, especially for hackers!} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[0-07-new-in-compiler]{To do with the compiler proper} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[eval does right thing:] + +%------------------------------------------------------------------- +\item[CAFs fully supported (notably updatable ones):] +\end{description} + +%************************************************************************ +%* * +\subsection[0-07-new-in-compiler-contrib]{In contributed bits of the compiler} +%* * +%************************************************************************ + +Please send us {\em your} bits for next time! + +%************************************************************************ +%* * +\subsection[0-07-new-in-libraries]{In @Prelude@ and runtime support} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[0-07-new-in-mkworld]{In distribution/build/installation machinery} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[0-07-new-misc]{Miscellaneous new things} +%* * +%************************************************************************ diff --git a/ghc/docs/release_notes/0-08-notes.lit b/ghc/docs/release_notes/0-08-notes.lit new file mode 100644 index 0000000..eaefa74 --- /dev/null +++ b/ghc/docs/release_notes/0-08-notes.lit @@ -0,0 +1,149 @@ +0.08 was not an announced release, so these notes are of historical +interest, at best. + +%************************************************************************ +%* * +\subsection[0-08-new-docs]{New documentation, especially for hackers!} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[0-08-new-in-usage]{Main user-visible changes} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[@ghc@ driver flag fiddling:] +These things change... A good thing to try is \tr{ghc -help}, unless +of course you think the documentation might be right (in which case +look there :-). + +%------------------------------------------------------------------- +\item[@ghc@ driver more ``policy-free'':] + +The driver no longer has great wads of built-in options for its +constituent phases (parser, Haskell compiler, C compiler, etc.). It +is much easier to configure these (if required) at build time. A +better idea, which we use, is to wired in very few options, but to use +the ``make world'' machinery to ensure that the desired (wads of +options) are always passed explicitly. + +%------------------------------------------------------------------- +\item[-OC:] We got rid of the \tr{-OC} flag. +\end{description} + +%************************************************************************ +%* * +\subsection[0-08-new-in-compiler]{To do with the compiler proper} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[``Renamer'' is in:] +Essentially, this implements module-system stuff. Checks for +naming/scoping errors have been moved out of the typechecker into the +renamer, which should be faster. + +%------------------------------------------------------------------- +\item[Interface-file (\tr{.hi} file) generation:] +It works. + +%------------------------------------------------------------------- +\item[Ambiguous-type resolution:] +It's basically right now, except that we still don't grok @default@ +declarations (which we have yet to see in a real Haskell program :-). + +%------------------------------------------------------------------- +\item[Smaller C output:] + +%------------------------------------------------------------------- +\item[Code generator:] +Improvements related to the information carried around about closures +(@ClosureInfo@ and @LambdaFormInfo@ types); matches the STG-machine paper. + +CAFs fully supported (notably updatable ones). + +Black-holing (at garbage-collection time) fully supported. + +%------------------------------------------------------------------- +\item[Simplifiers:] +Further work on the @Core@-to-@Core@ local-transformation passes (in +\tr{compiler/simplCore/}). Also, we have added +some @STG@-to-@STG@ transformations; for example, floating @lets@ +outward is most conveniently done at the STG level... + +%------------------------------------------------------------------- +\item[Cost-centre-style profiling:] + +%------------------------------------------------------------------- +\item[Improvements to basic datatypes:] +Notably to @Ids@ (\tr{basicTypes/Id.lhs}) and names +(\tr{basicTypes/NameTypes.lhs}). There is a new compiler-wide class, +@NamedThing@ (\tr{utils/Outputable.lhs}). Essentially it is easier to +ask of an entity: where did you come from? (e.g., PreludeCore?, +imported?) what are you? (a data-constructor? a dictionary selector?) +what is your original name? where are you going? (exported or not...) +\end{description} + +%************************************************************************ +%* * +\subsection[0-08-new-in-compiler-contrib]{In contributed bits of the compiler} +%* * +%************************************************************************ + +\begin{description} +\item[Evaluation-transformer bits:] +Denis Howe has sent us an initial version (\tr{compiler/evalTran}). +It isn't used by default, but is presumably play-withable... + +This @Core@-to-@Core@ transformation makes all lets of the form +\begin{verbatim} +let VAR = eval EXPR in ... +\end{verbatim} +strict. @eval@ is a dummy name which is thrown away (i.e., @eval x = x@). +\end{description} + +Please send us {\em your} bits for next time! + +%************************************************************************ +%* * +\subsection[0-08-new-in-libraries]{In @Prelude@ and runtime support} +%* * +%************************************************************************ + +Prelude is 1.2. + +The compiler has basically all of @PreludeCore@ wired into it (see +\tr{compiler/prelude/}); the rest is brought in with a straightforward +\tr{import Prelude} (which brings in \tr{imports/Prelude.hi}). [The +old \tr{MiniPrel*} files are dead and unmissed.] + +%************************************************************************ +%* * +\subsection[0-08-new-in-mkworld]{In distribution/build/installation machinery} +%* * +%************************************************************************ + +The ``make world'' machinery has many small improvements. + +It works notably better in a shared-symlink-tree world (which we use +at Glasgow). + +We have abandoned efforts to use one build tree for making object +files for multiple platforms. We can make simpler Makefiles as a +result. + +There's a new standard setup, called \tr{fast}. The name is +inappropriate at present, but it is intended to be for people who +value compiled-code-speed above all else (within reason, of course). + +%************************************************************************ +%* * +\subsection[0-08-new-misc]{Miscellaneous new things} +%* * +%************************************************************************ + +New version of Denis Howe's \tr{mira2hs} script. diff --git a/ghc/docs/release_notes/0-10-notes.lit b/ghc/docs/release_notes/0-10-notes.lit new file mode 100644 index 0000000..9048e8a --- /dev/null +++ b/ghc/docs/release_notes/0-10-notes.lit @@ -0,0 +1,72 @@ +Release~0.10 was the first major, public release of this compilation +system. + +The announcement (now distributed in \tr{ghc/docs/ANNOUNCE-0.10}) +describes the most notable features of this release. These notes, +therefore, just cover some of the fine points... + +%************************************************************************ +%* * +\subsection[0-10-new-docs]{New documentation} +%* * +%************************************************************************ + +We're providing a few more papers, in \tr{ghc/docs/papers}. See +\tr{ghc/docs/README} for a full list of documentation. + +%************************************************************************ +%* * +\subsection[0-10-new-in-usage]{User-visible changes} +%* * +%************************************************************************ + +An ``Appel-style'' generational garbage collector is now the default. +(It used to be a two-space copying collector.) + +The flag to use the unboxery and other Glasgow extensions was +\tr{-funboxed}. We've changed it to \tr{-fglasgow-exts}. We may +elaborate this further, eventually... + +(If 0.06 is the last version you looked at, flags/options have changed +a fair bit since then.) + +%************************************************************************ +%* * +\subsection[0-10-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +Derived instances are in, well partly. We'll put in the rest when +there's a demand (or we have nothing better to do). + +@Integers@ (arbitrary-precision integers) are now in properly. +Just as HBC does, we use the GNU multi-precision arithmetic package. +Source is in \tr{ghc/runtime/gmp}. + +We did a bunch of stuff in the typechecker region to support +overloading better; we called it ``dictionary stomping.'' One +side-effect of this work is that error messages related to overloading +have a slight chance of being sensible (which they weren't before). + +``Primitive arrays,'' on top of which efficient, regular Haskell +arrays can be (are) built, went in. There's a {\em little} about +using them, in the ``Glasgow extensions'' section of the User's Guide. + +Similarly, the mechanisms for calling C directly (@ccall@ and @casm@) +are more likely to be useful. Again, a little documentation in the +same place... + +%************************************************************************ +%* * +\subsection[0-10-new-in-libraries]{In the prelude and runtime support} +%* * +%************************************************************************ + +Our standard prelude conforms to the Haskell~1.2 report. + +We support a non-standard @fromInt@ method for the @Num@ class, just as +HBC does. + +We support a non-standard @cmp3@ method for the @Ord@ class. Snoop +around in the \tr{ghc/lib/prelude/*.hs} code, if you care. (We use it +in code generated for derived instances.) diff --git a/ghc/docs/release_notes/0-16-notes.lit b/ghc/docs/release_notes/0-16-notes.lit new file mode 100644 index 0000000..ba2d504 --- /dev/null +++ b/ghc/docs/release_notes/0-16-notes.lit @@ -0,0 +1,106 @@ +Release~0.16 was the second public release of this compilation system. +It was primarily a bug-fixing and ``solidifying'' release. + +The announcement for this release is distributed as \tr{ANNOUNCE-0.16} +in the top-level directory. + +%************************************************************************ +%* * +\subsection[0-16-new-docs]{New documentation} +%* * +%************************************************************************ + +We're providing a few more papers, in \tr{ghc/docs/papers}. See +\tr{ghc/docs/README} for a full list of documentation. + +%************************************************************************ +%* * +\subsection[0-16-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +New strictness analyser and update analyser; their use will be +reflected in the pragmas in your interface files. The format of these +interface pragmas {\em will probably change}. + +Errors related to misuse of Prelude identifiers are more likely to be +caught. + +For some unknown reason, our ``wired-in'' default declaration in 0.10 was +\tr{default (Integer,Double)}. We changed it to +\tr{default (Int,Double)}, as the Report suggests (which is less safe). + +We've switched from basing our derived instances on a non-standard +@cmp3@ method (class @Ord@), to basing them on another non-standard +method @tagCmp@. The relevant types and things are... +\begin{verbatim} +cmp3 :: b -> b -> b -> a -> a -> b + +tagCmp :: a -> a -> CMP_TAG +data CMP_TAG = LT_TAG | EQ_TAG | GT_TAG +\end{verbatim} +If you peer into the \tr{ghc/lib/prelude/*.hs} code, it will be +obvious what's going on here. We hope to make further improvements +on comparison code in the foreseeable future. + +%************************************************************************ +%* * +\subsection[0-16-new-in-libraries]{In the prelude and runtime support} +%* * +%************************************************************************ + +The libraries underpinning Glasgow monadic I/O, sequencing, primitive +arrays, and variables have been reworked, with some consequent +changes. If you encounter difficulties, you should consult the +@PreludeGlaIO.hi@ and @PreludeGlaArray.hi@ interfaces in your +\tr{imports} directory. + +Andy Gill's proposal for access to standard Haskell I/O functions from +the monadic I/O world has been implemented. So you have functions +such as @getArgsIO@, @appendChanIO@, etc., etc. + +The stuff you used to get from @Stdio.hi@ now comes directly from +@PreludeGlaIO.hi@. + +The @packString#@ function has been moved into a module of its own, +@PackedString@, and {\em its type has changed}. The functions now in +that module are (to be elaborated...): +\begin{verbatim} +packString :: String -> PackedString +packString# :: String -> Arr# Char# +\end{verbatim} +The latter is very useful to preparing @String@ arguments to pass to C. + +The HBC library modules that compile readily with GHC are available, +you'll need to give a \tr{-lHShbc} option to the driver. These +modules are: +\begin{verbatim} +Either, Hash, ListUtil, Maybe, Miranda, Number, Parse, Pretty, QSort, +Random, Time, Word +\end{verbatim} + +The GNU multi-precision (GMP) package which underpins our @Integer@ +support has been upgraded to version 1.3.2. + +%************************************************************************ +%* * +\subsection[0-16-new-elsewhere]{New elsewhere} +%* * +%************************************************************************ + +0.16 has a new and much uglier ``assembler mangler'' +(\tr{ghc/driver/ghc-asm-*.lprl}), which is what converts GCC-produced +assembly-language output into the stuff you actually run. Besides +throwing away function prologues/epilogues, it parks ``info tables'' +next to entry code, and fast-entry code right next to slow-entry code. + +The net effect of this assembler-mangler is that there is {\em very +little runtime penalty} for compiling via GCC. + +The way we go about mapping ``STG registers'' to real machine +registers (\tr{ghc/imports/StgRegs.lh}) is different. It should be +particularly better for machines with few registers (though we still +don't have a good solution for x86 machines). + +We can now ``steal'' caller-save registers; in the past, we could only +steal callee-save registers. diff --git a/ghc/docs/release_notes/0-17-notes.lit b/ghc/docs/release_notes/0-17-notes.lit new file mode 100644 index 0000000..5528f2a --- /dev/null +++ b/ghc/docs/release_notes/0-17-notes.lit @@ -0,0 +1 @@ +Added @getProgNameIO@ and @getProgNameIOE@ (inadvertently omitted). diff --git a/ghc/docs/release_notes/0-18-README b/ghc/docs/release_notes/0-18-README new file mode 100644 index 0000000..dc6ec5f --- /dev/null +++ b/ghc/docs/release_notes/0-18-README @@ -0,0 +1,63 @@ +This is version 0.18 of the Glasgow Haskell compiler. + +0.18 is an "internal" release intended *ONLY* for those actually +hacking on the compiler source -- that is, those who *REALLY* know +what they are doing. Anyone else is crazy to use it; anyone who uses +it without keeping a "real" GHC release (0.16 or 0.17) around is +obviously demented. + +The chances of a "clean" build are near zero, no matter what Haskell +compiler you build with. Be prepared to utter magic incantations. +(For example, `make reader/ReadPragmas.o +EXTRA_HC_OPTS="-fno-strictness -fno-specialise -fno-case-of-case"'.) + +An incomplete "what's new" list: + +* Unfoldings across module boundaries. Still v limited. + +* Specialisation of overloaded functions. Instances -- not yet. + +* Strictness analyser that handles "nested" strictness and does + "absence analysis" as well. Makes Prelude.hi fun to read. Hints: + _N_ = nothing, _A_ = arity, _U_ = update analysis info, _S_ = + strictness (U = unpack, A = absent, L = lazy, S = strict, E = strict + & enumeration type, P = primitive). + +* Prelude info no longer horribly built into the compiler (as much). + Manipulating the prelude is not nearly so delicate as it once was. + +* Some names have changed: MkChar => C#, MkInt => I#, MkFloat => F#, + MkDouble => D#, MkInteger => J#. (They won't change again...) + +* Includes Patrick Sansom's array-based substitution code (much faster + typechecking). (You probably won't see the speedup, though, because + we've spent all the savings on fancier intermodule stuff.) + +* We've added a Core "lint" pass, which can be used to check + types/out-of-scope-errors/etc after every Core-to-Core pass. It's + great! -dcore-lint. + +* Initial "Native" class support; use "-syslib hbc". + +* Lots of compiler code hacked on, for better or worse. + +* Lots of gratuitous "trace" messages when running the compiler :-) + +Documentation is unchanged since 0.1[67]. There is not one word about +any new features. + +We *hope* for a new public release before Christmas (1993). + +Will Partain +Keeper of the Bits, AQUA Project + +Dated: 93/11/04 + +E-mail contacts: + glasgow-haskell-bugs@dcs.glasgow.ac.uk (bug reports) + glasgow-haskell-request@dcs.glasgow.ac.uk (general queries) + +Anonymous FTP site: ftp.dcs.glasgow.ac.uk:pub/haskell/glasgow. Mostly +mirrored by ftp.cs.chalmers.se and nebula.cs.yale.edu (same +directory). Also: src.doc.ic.ac.uk, in +computing/programming/languages/haskell/glasgow/. diff --git a/ghc/docs/release_notes/0-19-notes.lit b/ghc/docs/release_notes/0-19-notes.lit new file mode 100644 index 0000000..66c1024 --- /dev/null +++ b/ghc/docs/release_notes/0-19-notes.lit @@ -0,0 +1,187 @@ +Release~0.19 was the third public release of this compilation system. +It incorporates our new work for the last half of 1993. + +The announcement for this release is distributed as \tr{ANNOUNCE-0.19} +in the top-level directory. + +%************************************************************************ +%* * +\subsection[0-19-user-visible]{User-visible changes in 0.19, including incompatibilities} +%* * +%************************************************************************ + +You'll need to recompile everything if you're switching from a +previous version of GHC. (If you don't, you'll get ``consistency +errors''.) + +Default declarations: in. + +Derived instances of \tr{Ix} and \tr{readsPrec} (\tr{Text} class): in. +(Random Prelude instances of weird things: in.) You can avoid the +\tr{readsPrec} methods by using the \tr{-fomit-derived-read} option. + +Should be {\em faster}, for two reasons: (1)~A native-code generator +for the SPARC architecture (avoids C compilation time); (2)~an +array-based [vs naive list-based...] substitution mechanism in the +typechecker. Using \tr{-O2} or \tr{-fvia-C} avoids the native-code +generator. + +(Shouldn't be too much faster, because we spent a lot of the winnings +:-() + +\tr{MkInt} and friends {\em renamed}: \tr{MkInt}, \tr{MkChar}, +\tr{MkFloat}, \tr{MkDouble}, and \tr{MkInteger} are now \tr{I#}, +\tr{C#}, \tr{F#}, \tr{D#}, and \tr{J#}, respectively. +We won't change them again, we promise. + +\tr{-i}/\tr{-I} flags changed: You used to specify directories to +search for interface files with \tr{-I }; now you do it with +\tr{-i} [{\em no space after the \tr{-i}}] (same as HBC). +\tr{-I} is reserved for when doing \tr{-cpp} and for the C compiler, +when it is run. + +Renaming, feature horribilis that it is, is more-or-less fully +implemented. The User's Guide lists one or two exceptions. + +Specialised versions of overloaded functions: these are created +automagically with \tr{-O}, and also when you ask for them with +\tr{SPECIALIZE} pragmas. See the User's Guide for how to do this +(same as HBC). (We don't have specialised instance declarations yet.) + +GHC tries hard to do inlining (or ``unfolding'') across module +boundaries; just look at \tr{-O}-produced interface files. You can +enliven this process with \tr{INLINE} pragmas. + +The \tr{__GLASGOW_HASKELL__} CPP directive is only set when +pre-processing Haskell source (and not when pre-processing generated +C). + +Revised scheme for using system-provided libraries (e.g., the HBC +library). Just use a \tr{-syslib } option when compiling and +linking. See the User's Guide for details. + +%************************************************************************ +%* * +\subsection[0-19-new-docs]{New documentation} +%* * +%************************************************************************ + +See \tr{ghc/docs/README} for a full list of documentation. + +The updated User's Guide has new sections including: (a)~advice for +creating smaller and faster programs more quickly, and (b)~about the +HBC library [stolen documentation]. + +We've dropped papers from the distribution (they're big, and you can +get them easily anyway); instead, we provide abstracts of all +documents about all relevant work at Glasgow; see +\tr{ghc/docs/abstracts}. + +New: ``A Simple Country Boy's Guide to Monadic-Style Programming'' (Will +Partain). In \tr{ghc/docs/simple-monad.lhs}. + +%************************************************************************ +%* * +\subsection[0-19-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +Strictness analyser: produces/handles ``nested'' strictness -- e.g., +\tr{U(SLL)} means ``this single-constructor argument is strict, and it +is also strict in its first component.'' There's also ``absence +analysis'' in there: \tr{U(ASA)} means ``strict in the second +component, and the first/third are not used at all.'' + +New simplifier: the program-transformation engine in the middle of the +compiler. The ``old simplifier,'' primarily the work of Andr\'e +Santos, has retired to an Old Simplifier's Home on the coast of +Brazil, where it is collecting a well-deserved monadic pension. + +%************************************************************************ +%* * +\subsection[0-19-new-in-libraries]{In the prelude and runtime support} +%* * +%************************************************************************ + +A couple of new functions in the @PackedString@ module that comes with +the system. Mentioned in the User's Guide. + +The HBC library has been upgraded to match the latest HBC release +(0.999.5). We now support the \tr{Native} and \tr{NameSupply} +modules, which we didn't before. + +Alastair Reid's implementation of ``stable pointers,'' which he uses +to do callbacks with the X Window System (yow!), is in. I (WDP) don't +know about documentation.... send mail if you need to know. + +%************************************************************************ +%* * +\subsection[0-19-new-ports]{In the porting department} +%* * +%************************************************************************ + +We use Sun4s running SunOS~4.1.3, so those are the best-supported +machines. For these, we have a native-code generator (the best); next +best is a ``registerised'' port; the bare minimum is an +``unregisterised'' port. + +The 0.19 infrastructure for ``stealing'' registers for a registerised port +(using a GCC extension) is much more robust---take note, brave porters. + +Here's everying that's known about the porting world: +\begin{description} +%------------------------------------------------------------------- +\item[Sun3 running SunOS~4.1.3:] +A registerised port is done; could be made available. + +%------------------------------------------------------------------- +\item[GRIP multiprocessor:] +68020-based multiprocessor for running parallel Haskell programs. +A registerised port is done; too bad we have the only machine! +If you have something parallel you {\em really} wanted to run on it, +please get in touch with us. + +%------------------------------------------------------------------- +\item[HP-PA box running HP/UX:] +An unregisterised port of 0.17 (0.16+portability fixes) seems to +work, except that floating-point is definitely busted. 0.19~should be +no worse. + +%------------------------------------------------------------------- +\item[DECstation (MIPS-based):] +An unregisterised port of 0.17 works; 0.19~should be the same. + +%------------------------------------------------------------------- +\item[DEC Alpha running OSF/1:] +We've done an unregisterised port (unreleased), and a registerised +port is not far off. + +%------------------------------------------------------------------- +\item[Sun running Solaris 2.x:] +We've started on this ourselves and foresee no obstacle to a +``registerised'' port. Not sure about native-code... + +%------------------------------------------------------------------- +\item[x86 PCs running Linux:] +This really needs a native-code generator to be viable. We hope the +elves will give us one for Christmas! + +%------------------------------------------------------------------- +\item[Macintosh, using MPW:] +As mind-blowing at it may seem, David Wright in Tasmania has actually +gotten GHC to run on a Macintosh. I believe it's still in the ``you +can do it, but you don't want to'' stage. +\end{description} + +%************************************************************************ +%* * +\subsection[0-19-new-elsewhere]{New elsewhere} +%* * +%************************************************************************ + +In the ``literate programming'' stuff that happens to come with GHC: a +few bug fixes, plus a significant contribution from Chris Toshok +(\tr{toshok@cs.uidaho.edu}) of ``lit2html'' stuff; i.e., to convert +your literate programs into HTML, the Hypertext Markup Language used +on the World-Wide Web. I (WDP) am not sure it's completely finished, +or exactly what you invoke to do what, but it seems Way Cool. diff --git a/ghc/docs/release_notes/0-22-notes.lit b/ghc/docs/release_notes/0-22-notes.lit new file mode 100644 index 0000000..aa9e722 --- /dev/null +++ b/ghc/docs/release_notes/0-22-notes.lit @@ -0,0 +1,205 @@ +Release~0.22 is the fourth public release of Glasgow Haskell. +It incorporates our new work for the first half of 1994. + +The announcement for this release is distributed as \tr{ANNOUNCE-0.22} +in the top-level directory. + +%************************************************************************ +%* * +\subsection[0-22-ports]{What machines GHC~0.22 runs on} +%* * +%************************************************************************ + +We use Sun4s running SunOS~4.1.3 and DEC~Alphas running OSF/1~V2.0, so +those are the ``fully-supported'' platforms, unsurprisingly. For +Sun4s, we have a native-code generator, which makes for somewhat +quicker compilations. (We actually produce better code by compiling +intermediate C with GCC.) + +The GHC hierarchy of Porting Goodness: (a)~Best is a native-code +generator [only for Sun4s, now]; (b)~next best is a ``registerised'' +port; (c)~the bare minimum is an ``unregisterised'' port. +``Unregisterised'' Haskell programs are much bigger and slower, +but the port is much easier to get going. + +Here's everything that's known about GHC ports, as of 0.22: +\begin{description} +%------------------------------------------------------------------- +\item[Sun4 running SunOS~4.1.3:] +Fully supported, including native-code generator. + +%------------------------------------------------------------------- +\item[DEC Alpha running OSF/1 V2.0:] +Fully supported, but no native-code generator (none planned). + +%------------------------------------------------------------------- +\item[Sun3 running SunOS~4.1.3:] +GHC~0.22 should work, registerised. (0.21 did work.) + +%------------------------------------------------------------------- +\item[Sun4 running Solaris 2.x:] +We expect to finish a ``registerised'' port ourselves, in the +foreseeable future. Feel free to ask about it, if interested. Not +sure about native-code... + +%------------------------------------------------------------------- +\item[HP-PA box running HP/UX 9.x:] +An unregisterised port of 0.21 (last ``internal'' release before 0.22) +seems to work, except that floating-point is definitely busted. +0.22~should be the same. + +%------------------------------------------------------------------- +\item[Silicon Graphics box running IRIX 5.x:] +An unregisterised port of 0.21 +seemed to work. 0.22~should be the same. + +%------------------------------------------------------------------- +\item[DECstation (MIPS-based):] +An unregisterised port back around the time of 0.17 seemed to work; +0.22~should be the same, modulo a little bit-rot. + +%------------------------------------------------------------------- +\item[x86 PCs running Linux/NetBSD/FreeBSD:] +This really needs a native-code generator to be viable. No +recent progress. + +%------------------------------------------------------------------- +\item[GRIP multiprocessor:] +GRIP is a 68020-based multiprocessor for running parallel Haskell +programs; too bad we have the only machine! We run GHC~0.16 on it, +with no plans to upgrade. + +We are working on other parallel stuff. Stay tuned. + +%------------------------------------------------------------------- +\item[NeXT box running whatever NeXTs run:] +Carsten Schultz succeeded with a ``registerised'' port of GHC~0.19. +There's probably a little bit-rot since then, but otherwise it should +still be fine. + +%------------------------------------------------------------------- +\item[Macintosh, using MPW:] +As mind-blowing at it may seem, David Wright in Tasmania has actually +gotten GHC to run on a Macintosh. Ditto James Thomson here at Glasgow. +You may be able to get Thomson's from here. (Not sure that it will +excite you to death, but...) +\end{description} + +%************************************************************************ +%* * +\subsection[0-22-user-visible]{User-visible changes in 0.22, including incompatibilities} +%* * +%************************************************************************ + +You'll need to recompile everything if you're switching from a +previous version of GHC. (If you don't, you'll get ``consistency +errors''.) + +Lazy pattern-matching (e.g., \tr{let (x,y) = ... in ...}) no longer +carries with it the threat of a space leak. (It used to be that, as +long as {\em either} of \tr{x} or \tr{y} was ``live,'' the storage +manager would hang onto {\em both} chunks of graph.) No longer. + +We've done a complete overhaul of the state-transformer stuff which +underlies our array, I/O, and C-calling support. The ``state +interface document,'' distributed in \tr{ghc/docs/state-interface.dvi} +defines what we have done. You may wish to check our abstracts +(\tr{ghc/docs/abstracts/}) to find papers about this stuff. If you've +written code that grovels around in GHC innards (e.g., uses +``primitive operations'' directly), it will probably need updating. + +We do {\em not} support Haskell~1.3 monadic I/O (any draft version), +but we will once the dust settles. We still support the +\tr{PreludeGlaIO} interface that we have had for some time. + +You can now build GHC to support ``threaded'' execution. (Configure +\tr{--with-threads=yes}, then use GHC with a \tr{-threads} option.) +Using the \tr{_seq_} and \tr{_par_} constructs, + +GHC does a better job of not stealing from the user's name space (for +its own extensions, etc.). For example, the ``set cost-centre'' +keyword is now \tr{_scc_}, rather than \tr{scc} (though the latter +will continue to be accepted for a while). With the +\tr{-fglasgow-exts} flag on, names may begin with an underscore +(\tr{_}). + +We have friendly interaction between ``Haskell land'' and ``C land'' +via (a)~{\em stable pointers} (pass Haskell pointers to C and have the +garbage-collector not forget about them); and (b)~{\em malloc +pointers} (return C pointers to Haskell and tell Haskell ``throw this +away when you're finished with it''). See the User's Guide for more +info. + +%************************************************************************ +%* * +\subsection[0-22-support]{New in support tools (e.g., profiling)} +%* * +%************************************************************************ + +The profiling system of GHC has been improved in version~0.22 in the +following ways: +\begin{description} +\item[Now uses the ``hybrid scheme'':] (Rather than pure ``lexical +scoping'') What this means for you: ``CAF'' cost-centres will no +longer be blamed for gigantic chunks of the time in your program. + +\item[Uses the generational garbage-collector:] (At least when doing +time profiling) It used to use a two-space copying GC; it still does +when space profiling. You should be able to profile larger programs. +\end{description} + +%************************************************************************ +%* * +\subsection[0-22-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +The ``simplifier''---the program-transformation engine in the middle +of the compiler---has settled down (at least until Simon has another +Brain Wave). We've made ``per-simplification'' flags, so that each +run of the simplifier can be controlled separately---this allows very +precise control. (But makes it pretty hard to exercise any control +from the command-line.) More in the docs. + +Related to simplifier stuff was a revision of the ``unfoldery'' +machinery. We try very hard to find and exploit unfolding (or +inlining), including across module boundaries. + +%************************************************************************ +%* * +\subsection[0-22-new-in-libraries]{In the prelude and runtime support} +%* * +%************************************************************************ + +We've introduced a ``GHC system library,'' similar to the ``HBC system +library'' which we have supported for some time. Just say +\tr{-syslib ghc} and the GHC library stuff is at your fingertips. +See the User's Guide for exactly what's on offer (not a lot right now, +but more will show up). + +The @PackedString@ module that comes with the system is even beefier +than before; see the User's Guide. (This module really should be +in the GHC library.) + +%************************************************************************ +%* * +\subsection[0-22-new-elsewhere]{Other new stuff} +%* * +%************************************************************************ + +We have two new mailing lists about Glasgow Haskell. +\begin{description} +\item[glasgow-haskell-users:] +This list is for GHC users to chat among themselves. Subscribe by +sending mail to \tr{glasgow-haskell-users-request@dcs.glasgow.ac.uk}. +Messages for the list go to \tr{glasgow-haskell-users}. + +\item[glasgow-haskell-bugs:] +This used to be an address for some lonely person who received bug +reports. It is now a mailing list for the sort of people who discuss, +well, bug reports when they go to a party. + +Subscribe via \tr{glasgow-haskell-bugs-request@dcs.glasgow.ac.uk}; +send bug reports and rumination thereupon go to +\tr{glasgow-haskell-bugs}. +\end{description} diff --git a/ghc/docs/release_notes/0-23-notes.lit b/ghc/docs/release_notes/0-23-notes.lit new file mode 100644 index 0000000..196592c --- /dev/null +++ b/ghc/docs/release_notes/0-23-notes.lit @@ -0,0 +1,253 @@ +Release~0.23 is the fifth public release of Glasgow Haskell. +It incorporates our new work for the second half of 1994. + +The announcement for this release is distributed as \tr{ANNOUNCE-0.23} +in the top-level directory. + +%************************************************************************ +%* * +\subsection[0-23-ports]{What machines GHC~0.23 runs on} +%* * +%************************************************************************ + +NOTE: the porting situation is essentially unchanged between 0.22 and +0.23, except for adding the native-code generator for DEC Alphas. + +We use Sun4s running SunOS~4.1.3 and DEC~Alphas running OSF/1~V2.0, so +those are the ``fully-supported'' platforms, unsurprisingly. Both +have native-code generators, for quicker compilations. + +The GHC hierarchy of Porting Goodness: (a)~Best is a native-code +generator; (b)~next best is a ``registerised'' +port; (c)~the bare minimum is an ``unregisterised'' port. +``Unregisterised'' Haskell programs are much bigger and slower, +but the port is much easier to get going. + +Here's everything that's known about GHC ports, as of 0.23: +\begin{description} +%------------------------------------------------------------------- +\item[Sun4 running SunOS~4.1.3 (\tr{sparc-sun-sunos4}):] +Fully supported, including native-code generator. + +%------------------------------------------------------------------- +\item[Sun4 running Solaris 2.x (\tr{sparc-sun-solaris2}):] +Fully supported, including native-code generator. +(NB: not tested before release.) + +%------------------------------------------------------------------- +\item[DEC Alpha running OSF/1 V2.0 (\tr{alpha-dec-osf1}):] +Fully supported, including native-code generator. + +%------------------------------------------------------------------- +\item[Sun3 running SunOS~4.1.3 (\tr{m68k-sun-sunos4}):] +GHC~0.23 works registerised. No native-code generator. + +%------------------------------------------------------------------- +\item[HP-PA box running HP/UX 9.x:] +An unregisterised port of 0.21 (last ``internal'' release before 0.23) +seems to work, except that floating-point is definitely busted. +0.23~should be the same. + +%------------------------------------------------------------------- +\item[Silicon Graphics box running IRIX 5.x:] +An unregisterised port of 0.21 +seemed to work. 0.23~should be the same. + +%------------------------------------------------------------------- +\item[DECstation (MIPS-based):] +An unregisterised port back around the time of 0.17 seemed to work; +0.23~should be the same, modulo a little bit-rot. + +%------------------------------------------------------------------- +\item[x86 PCs running Linux/NetBSD/FreeBSD:] +This really needs a native-code generator to be viable. No +recent progress. + +%------------------------------------------------------------------- +\item[GRIP multiprocessor:] +GRIP is a 68020-based multiprocessor for running parallel Haskell +programs; too bad we have the only machine! We run GHC~0.16 on it, +with no plans to upgrade. + +We are working on other parallel stuff. Stay tuned. + +%------------------------------------------------------------------- +\item[NeXT box running whatever NeXTs run:] +Carsten Schultz succeeded with a ``registerised'' port of GHC~0.19. +There's probably a little bit-rot since then, but otherwise it should +still be fine. Had a report that things were basically OK at 0.22. + +%------------------------------------------------------------------- +\item[Macintosh, using MPW:] +As mind-blowing at it may seem, David Wright in Tasmania has actually +gotten GHC to run on a Macintosh. Ditto James Thomson here at Glasgow. +You may be able to get Thomson's from here. (Not sure that it will +excite you to death, but...) +\end{description} + +%************************************************************************ +%* * +\subsection[0-23-config]{New configuration things in 0.23} +%* * +%************************************************************************ + +Essentially, upgraded to Autoconf~2. Probably the easiest way to see +what all the options are now is to type \tr{./configure --help} and +look at the stuff near the end. + +%************************************************************************ +%* * +\subsection[0-23-user-visible]{User-visible changes in 0.23, including incompatibilities} +%* * +%************************************************************************ + +You'll need to recompile everything if you're switching from a +previous version of GHC. (If you don't, you'll get ``consistency +errors''.) Some day, we will stop doing this to you :-) + +Monadic I/O has taken yet another shake-up; that is outlined in the +next section. + +To use the 1.3-DRAFT I/O features, you use a \tr{-fhaskell-1.3} flag. +This also nets you, from your Prelude, the \tr{Maybe} and \tr{Either} +types, and the functions \tr{thenMaybe}, \tr{curry}, and \tr{uncurry}. + +The driver supports a heap-and-stack-sizes scaling flag. For example, +\tr{-Rscale-sizes2} would cause the driver to use twice as much +heap/stack space as it would otherwise. This is a convenient way to +move between machines with differing memory setups (e.g., 32-bit vs +64-bit) without changing millions of -H flags in a Makefile. Note: +something like \tr{-Rscale-sizes1.5} is OK, too. + +``Lit-lit'' literals are now overloaded. They can be any +\tr{_CCallable} type, not just \tr{_Addrs}. The price of this extra +convenience is that you sometimes have to insert a type signature. + +The shift-right primitive-operation, \tr{shiftR#}, has been renamed +and clarified to \tr{shiftRA#} (arithmetic). A new prim-op +\tr{shiftRL#} (logical) has been added. + +Comparable shift primitive-ops on \tr{Int#s} (rather than \tr{Word#s}) +have been added: \tr{iShiftL#}, \tr{iShiftRA#}, and \tr{iShiftRL#}. +Long live high-level languages! + +%************************************************************************ +%* * +\subsection[0-23-io]{New in I/O, esp. ``monadic,'' esp. ``1.3''} +%* * +%************************************************************************ + +GHC~0.23 is still a Haskell~1.2 compiler. Do nothing weird, and it +should work exactly as before. + +If you give GHC a \tr{-fhaskell-1.3} flag (both compile and link time, +please!), it will use a VERY EARLY, LARGELY UNTESTED implementation of +the DRAFT 1.3 I/O PROPOSAL. + +The \tr{PreludeGlaIO} interface, which was based on a long-ago 1.3 I/O +proposal, is DEAD. It was in a pretty bad state, anyway. +Putting \tr{PreludeGlaIO} code through as 1.3 code, I got pretty +far with just these few impedance-matching definitions: +\begin{verbatim} +> type Void = () +> returnIO = return +> thenIO = (>>=) +> mapIO :: (a -> IO b) -> [a] -> IO [b] +> mapIO f = accumulate {-was:listIO-} . map f +\end{verbatim} + +We supply the DRAFT 1.3 I/O PROPOSAL in \tr{ghc/docs/io-1.3/}. +It is in HTML format. + +We still give access to our underlying \tr{PrimIO} monad, via the +\tr{PreludePrimIO} interface. This is the level at which \tr{_ccall_s} +operate. It should still be quite solid, and counts as a good fall-back +position when the 1.3-DRAFT stuff dies on you. See the User's Guide. + +%************************************************************************ +%* * +\subsection[0-23-support]{New in support tools (e.g., profiling)} +%* * +%************************************************************************ + +The reports from profiling should be a bit tidier. The ``automagic'' +cost-centres for, e.g., ``all the CAFs in module X'', will now be +reported against \tr{CAFs_in_... X}. Which seems fair enough. + +GHCI---an INTERPRETER for Glasgow Haskell! The brainchild and work of +Alastair Reid, before he defected to the Enemy at Yale. Accepts full +Glasgow Haskell, including many extensions. Can mix interpreted and +compiled code, the Prelude being a notably case of the latter. +MASSIVE HACK VALUE! The problem is it doesn't quite compile under +0.23 (I ran out of time), and some of its dodgy bits (used to mix +interpreted and compiled code) need upgrading to work with the new +info tables. It lives in \tr{ghc/compiler} and below, notably the +\tr{interpreter} subdirectory. Don't be shy now---roll up your +sleeves and strut your hacking stuff! + +%************************************************************************ +%* * +\subsection[0-23-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +The compiler is quite a bit faster at compiling, {\em without} +\tr{-O}. We are in the HBC league now. I don't remember all the +HACKs that we threw in to make this happen :-) + +New-format ``info tables'' (work by Bryan O'Sullivan and friends). +Essentially, static info used by the garbage-collector has been moved +one indirection further away, into a ``rep table,'' of which there are +a fixed number. So the same GC info isn't replicated over and over +again. This is our main space-savings gain in 0.23. + +A native-code generator for the DEC Alpha. Jim Mattson did it in one +weekend. What a great system! + +Rather than have a separate Yacc-parser process that spews a long +``prefix form'' string into the compiler, the compiler now just does a +\tr{_ccall_ yyparse} and then walks the resulting parse tree directly. +(Not quite {\em that} simple, but... still pretty cool.) + +A {\em selective} lambda-lifter. (Simon is very excited about its +selectiveness.) That means it only does lambda-lifting if there is a +benefit in doing so. It's done on the STG syntax (quite late in the +compilation). + +%************************************************************************ +%* * +\subsection[0-23-new-in-libraries]{In the prelude and runtime support} +%* * +%************************************************************************ + +PackedStrings (now called \tr{_PackedString}s) are now a built-in +type, just like \tr{Int}s, say. Their interface is described with the +Glasgow extensions in the User's Guide. There is also a +``extensions-free'' interface (no underscores on the front of names) +which you can get at as a system library (\tr{-syslib ghc}). + +The pretty-printing code that we use in GHC is now available in the +GHC system library (\tr{-syslib ghc} and \tr{import Pretty}). We +would claim it is more ``industrial strength'' than the one in the HBC +system library... + +Because of name-grabbing by the DRAFT-1.3-I/O, two functions in the +HBC library's \tr{Parse} module have been renamed: \tr{(>>)} is now +\tr{act}, and \tr{fail} is now \tr{failP}. (We will change these +again if Lennart does something differently.) + +%************************************************************************ +%* * +\subsection[0-23-new-elsewhere]{Other new stuff} +%* * +%************************************************************************ + +We've added a new utility, \tr{pphs}, for pretty-printing Haskell code +in LaTeX documents. It was written by Andrew Preece, a student at +Glasgow. The code is in \tr{ghc/CONTRIB/pphs}. + +Over in literate-land, we've hidden a copy of a slightly-tweaked +\tr{texi2html} script (in \tr{literate/texi2html/texi2html}). This is +probably the most painless way to turn ``literate'' things into +Webbable HTML documents. (Use our literate stuff to make Texinfo +files, then convert with \tr{texi2html}.) NB: not really tested. diff --git a/ghc/docs/release_notes/0-26-notes.lit b/ghc/docs/release_notes/0-26-notes.lit new file mode 100644 index 0000000..b10c7e1 --- /dev/null +++ b/ghc/docs/release_notes/0-26-notes.lit @@ -0,0 +1,244 @@ +Release~0.26 is a major public release of Glasgow Haskell. +It incorporates our new work for the first half of 1995. + +The announcement for this release is distributed as \tr{ANNOUNCE-0.26} +in the top-level directory. + +You'll need to recompile everything if you're switching from a +previous version of GHC. (If you don't, you'll get ``consistency +errors''.) Some day, we will stop doing this to you :-) + +Information about ``what's ported to which machine'' is now given in +the Installation Guide. +The new ports since 0.23 are: \tr{hppa1.1-hp-hpux}, +\tr{i386-*-linuxaout}, and \tr{mips-sgi-irix5}. + +%************************************************************************ +%* * +\subsection[0-26-config]{New configuration things in 0.26} +%* * +%************************************************************************ + +We are moving towards one \tr{configure} script for all Glasgow +functional-programming tools. Consequently, the configure options +have been tweaked. Doing \tr{./configure --help} will show you the +current state of play. + +%************************************************************************ +%* * +\subsection[0-26-user-visible]{User-visible changes in 0.26, including incompatibilities} +%* * +%************************************************************************ + +The names \tr{scc}, \tr{ccall}, and \tr{casm} are no longer stolen +from the user's name space. (The magical constructs they once were +have been known as \tr{_scc_}, \tr{_ccall_}, and \tr{_casm_} for some +time now...) + +Similarly, \tr{trace} is no longer built-in (so you can use the name +if you want to). You can get \tr{trace} either as \tr{_trace} +(Glasgow extension), or as itself via \tr{import Trace} with +\tr{-syslib hbc} (i.e., exactly like HBC). + +Lazy, or irrefutable, patterns with unboxed-type components are +no longer allowed. You'll need to rewrite \tr{let (I# x) = exp ...} +as \tr{let x = case exp of { I# i -> i } in ... }. + +GHC now supports hexadecimal and octal numeric syntax for integer constants. +(But \tr{read} doesn't grok it yet...) + +GHC now supports specialised instances (as in HBC); you can write: +\begin{verbatim} +instance Eq a => Eq (Foo a) where { ... } +{-# SPECIALIZE instance Eq (Foo Bool) #-} +\end{verbatim} + +GHC's pragmas for specialised values now have a magical \tr{= blah} +form, in which you specify the code to be used for the specialised value. +For example: +\begin{verbatim} +f :: Ord a => a -> Int -> a +{-# SPECIALIZE f :: Double -> Int -> Double = f_Double #-} + +f_Double :: Double -> Int -> Double +f_Double ... +\end{verbatim} +In some cases, the \tr{= blah} form can be a {\em big} win. + +What we used to call ``threaded'' Haskell, we now call ``Concurrent +Haskell.'' And there's a paper about it. Please see the User's Guide. + +``Parallel Haskell,'' running under PVM, is here. Again, see the +User's Guide. + +%************************************************************************ +%* * +\subsection[0-26-options]{New or changed GHC command-line options} +%* * +%************************************************************************ + +The \tr{-g}, \tr{-p}, \tr{-pg}, \tr{-fpic}, and \tr{-fPIC} are no +longer passed straight through to GCC. They probably buy you nothing, +while potentially causing substantial mischief. If you know what you're doing, +you can still use them, via \tr{-optcO-...}. + +The main option for Concurrent Haskell is \tr{-concurrent}; for +Parallel Haskell, it's \tr{-parallel}. + +The \tr{-dict-all} option, used with \tr{-prof}, has died. It never +did anything anyway. + +Besides the \tr{-fshow-specialisations} option to see what specialisations +have occurred, you may also use the \tr{-fshow-import-specs} option +to see what specialisations GHC would like to have had available. +By then adding these ``desirable'' pragmas to your code, you can +squash most of the overloading from your program. + +There are some new sanity-checking options. Use +\tr{-fsignatures-required} if you want to force all top-level +definitions to have type signatures. Use \tr{-fshadowing-not-ok} +if you want to disallow name shadowing. You can't use the latter on +modules that include circular definitions. + +The \tr{-Rghc-timing} option gives a convenient one-line summary to +GHC's runtime and heap allocation. + +The \tr{-odump} option may be used to save GHC's standard-error output +to a file. (It normally shows up on your screen.) + +You can now use \tr{-H0} and \tr{-K0} to reset the heap and stack +sizes. As these sizes are normally ``maxxed up'' (\tr{-H32m -H16m} +gets you a 32MB heap), you can use this form to decrease the size: +\tr{-H6m -H0 -H250k} gives you a heap of 250KB. + +%************************************************************************ +%* * +\subsection[0-26-io]{New in monadic I/O} +%* * +%************************************************************************ + +GHC~0.26 is still a Haskell~1.2 compiler (and will remain so until +there is a non-DRAFT 1.3 standard). + +We killed the \tr{PreludePrimIO} interface. You can get all the same +functions from \tr{PreludeGlaST}. + +All the \tr{_IVar} and \tr{_MVar} operations are now in the 1.3 +\tr{IO} monad, not the non-standard \tr{PrimIO} monad. You now +get them from \tr{Concurrent}, not from \tr{PreludeGlaST}. + +%************************************************************************ +%* * +\subsection[0-26-new-in-compiler]{New in the compiler proper} +%* * +%************************************************************************ + +The main new things are ``foldr-build'' deforestation (by Andy Gill) +and ever-more-glorious specialisation (by Patrick Sansom). + +And the usual few megabytes of gratuitous changes. + +%************************************************************************ +%* * +\subsection[0-26-new-in-libraries]{In the prelude and libraries} +%* * +%************************************************************************ + +All of the basic state-transformer stuff now comes from +\tr{PreludeGlaST}. The \tr{PreludePrimIO} interface no longer exists. + +The function \tr{foldrPrimIO} went away. The function \tr{forkPrimIO} +sprang to life. + +The what-you-need-for-Concurrent-Haskell interface is \tr{Concurrent}. +The GHC option is \tr{-concurrent}. Please see the User's Guide. +Note that the operations @threadDelay@ and @threadWait@ now come +from \tr{Concurrent}, not \tr{PreludeGlaMisc}. + +I-Vars and M-Vars (synchronising variables) are now +specifically I/O operations, not general state-transformer operations. +They also come from the \tr{Concurrent} interface. + +Renamings: what used to be the \tr{newMVar} operation is now called +\tr{newEmptyMVar}; what was \tr{initMVar} is now \tr{newMVar}. + +The what-you-need-for-Parallel-Haskell interface is \tr{Parallel}. +The GHC option is \tr{-parallel}. At the moment, the \tr{Parallel} +interface just provides \tr{par} and \tr{seq}. But that will change. + +\tr{LibPosix} now provides \tr{runProcess}, our candidate for the +high-level OS-independent operation. + +NEW: The \tr{Regex} (\tr{-syslib ghc}) interface provides direct +access to the GNU regexp (regular expressions on strings) package. +The \tr{MatchPS} interface is higher-level, providing string-matching +functions on \tr{_PackedStrings}. (All by Sigbjorn Finne) + +NEW: The \tr{Readline} interface (also \tr{-syslib ghc}) provides +access to the GNU readline package. Instant command-line editing +for your Haskell programs. (By Darren Moffat) + +NEW: A ``network interface toolkit'' by Darren Moffat. BSD sockets +for Haskell---way cool. + +The \tr{FiniteMap} module has two new functions, \tr{isEmptyFM} and +\tr{elemFM}. + +The \tr{Maybes} module now uses the Haskell~1.3 built-in \tr{Maybe} +type; you should use \tr{-fhaskell-1.3} with this module now. + +The HBC library modules \tr{Maybe}, \tr{Either}, and \tr{Option} are +{\em gone}. Just use \tr{-fhaskell-1.3} and get the types directly +from the Prelude. + +All system-library modules that use the \tr{Maybe} type now require +\tr{-fhaskell-1.3}. For the GHC library, that means \tr{FiniteMap}, +\tr{Maybes}, \tr{Util}, \tr{Set}, \tr{Regex}, and \tr{MatchPS}. For +the HBC library, that means \tr{ListUtil}, \tr{Native}, and +\tr{Parse}. (In some cases, you could avoid the \tr{-fhaskell-1.3} +requirement by doing selective imports.) + +GHC now supports \tr{trace} exactly like HBC: \tr{import Trace} and +do \tr{-syslib hbc}. The built-in no-import-required version +is now called \tr{_trace}. + +Instances for \tr{Shorts} and \tr{Bytes} have been added to the +HBC library module \tr{Word}. + +As part of the GHC system library, we now provide an interface to the +GNU regexp (regular-expression) library; the \tr{Regexp} interface. +A higher-level interface, to do matches on \tr{_PackedString}s comes +from the \tr{MatchPS} interface. + +We no longer provide specialisations of Prelude functions to the +\tr{Float} type; only to \tr{Double}. It saves space, and we want to +discourage the use of single-precision floating-point. + +%************************************************************************ +%* * +\subsection[0-26-new-in-rts]{In the runtime system} +%* * +%************************************************************************ + +GHC now supplies some very simple ``hooks'' to let you change the +failure messages for stack and heap overflow, \tr{error}, and +pattern-matching failure. Please see the User's Guide. + +You can now force garbage collection after every N bytes of allocation +(presumably for stats collection, or something). Use the \tr{-j} RTS +option. + +``Squeezing out'' update frames at garbage-collection time is now {\em +on} by default. (You can turn it off with the \tr{-Z} RTS option, but +I can't think why you would want to.) + +%************************************************************************ +%* * +\subsection[0-26-new-elsewhere]{Other new stuff} +%* * +%************************************************************************ + +The GHC distribution now includes an ``examples'' directory, including +a simple shell (\tr{hsh} and quite a few to do with 1.3 I/O +(\tr{ioNNN}) and \tr{LibPosix} (\tr{poNNN}). All in +\tr{ghc/misc/examples}... diff --git a/ghc/docs/release_notes/Jmakefile b/ghc/docs/release_notes/Jmakefile new file mode 100644 index 0000000..88109ac --- /dev/null +++ b/ghc/docs/release_notes/Jmakefile @@ -0,0 +1,13 @@ +/* there are rules to make this piece of "the book" + * as a standalone document, + * but nothing to "install" it + */ + +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) + +LiterateSuffixRules() +DocProcessingSuffixRules() + +/* no space between the two args! */ +LitDocRootTarget(release,lit) diff --git a/ghc/docs/release_notes/real-soon-now.lit b/ghc/docs/release_notes/real-soon-now.lit new file mode 100644 index 0000000..7fd5b85 --- /dev/null +++ b/ghc/docs/release_notes/real-soon-now.lit @@ -0,0 +1,49 @@ +%************************************************************************ +%* * +%* Stuff for : Real Soon Now * +%* * +%************************************************************************ + +Below is a short list of things we hope to tackle soon. We welcome +prodding, cajoling, large sums of money, offers of holidays in warm +climates... Umm, excuse me, I got carried away.... + +\begin{description} +%------------------------------------------------------------------- +\item[Compilation speed:] +This is still our \#1 priority. (Actually, we {\em have} saved a lot +on compilation time since~0.16; however, we've spent a goodly chunk of +our winnings.) + +%------------------------------------------------------------------- +\item[Revised I/O scheme:] We've {\em finally} figured out the right +way to do this ``state'' stuff; see the Launchbury/Peyton Jones ``Lazy +Functional State Threads'' paper (draft; check +\tr{ghc/docs/abstracts/abstracts93.tex}). + +Simultaneously, the Haskell~1.3 I/O proposal is coming along. We hope +to use the former to do the latter, if you know what I mean. + +%------------------------------------------------------------------- +\item[More with unfoldings:] +And our new simplifier. Both of these new pieces of machinery are +still a bit ``raw.'' (The reason we don't quote performance numbers +is because we haven't collected any yet.) + +%------------------------------------------------------------------- +\item[Specialised instances:] Tedious and boring. + +%------------------------------------------------------------------- +\item[More with ``semi-tagging'':] +(which we haven't done much with yet...) and other code-generator-ish +hacks. [It depends how close we let Simon get to the code.] + +%------------------------------------------------------------------- +\item[More tuning:] +We're {\em generally} happy with the time/space behaviour of Haskell +programs compiled with this system. But there's always work to do. + +We still welcome a copy of any Haskell program for which a competing +compiler generates better code. We want to stamp out these +unfortunate anomalies! +\end{description} diff --git a/ghc/docs/release_notes/release.lit b/ghc/docs/release_notes/release.lit new file mode 100644 index 0000000..16e4d24 --- /dev/null +++ b/ghc/docs/release_notes/release.lit @@ -0,0 +1,93 @@ +\begin{onlystandalone} +\documentstyle[11pt,literate]{article} +\begin{document} +\title{Release notes for Glasgow Haskell} +\author{Will Partain (for the AQUA Team)\\ +Department of Computing Science\\ +University of Glasgow\\ +Glasgow, Scotland\\ +G12 8QQ\\ +\\ +Email: glasgow-haskell-\{bugs,request\}\@dcs.glasgow.ac.uk} +\maketitle +\begin{rawlatex} +\tableofcontents +\end{rawlatex} +\clearpage +\end{onlystandalone} + +% NOTE TO MAINTAINERS: the way these notes are organized: +% (1) What's new in the current release +% (2) What's next ("real soon now") +% (3) What was new in previous releases (reverse chronological order) +% (4) anything else +% +% Remember: this isn't the compiler documentation! -- it's just +% pointers to it. Mentioning something in the release notes is not +% the same as documenting it. + +\section[release-0-26]{Release notes for version~0.26---7/95} +\input{0-26-notes.lit} + +%\section[release-RSN]{What we hope to do Real Soon Now} +%\downsection +%\input{real-soon-now.lit} +%\upsection + +\section{Non-release notes for versions~0.24 and 0.25} +Version~0.24 (March 1995) was a tidy-up release; it mostly +fixed some ``threads'' problems (now ``Concurrent Haskell''), +some I/O problems, and some porting problems. + +Version~0.25 was a binary-only dump of a \tr{i386-*-linuxaout} +build, just so people could try it. + +\section[release-0-23]{Release notes for version~0.23---12/94} +\input{0-23-notes.lit} + +\section[release-0-22]{Release notes for version~0.22---7/94} +\input{0-22-notes.lit} + +\section[release-0-19]{Release notes for version~0.19---12/93} +\input{0-19-notes.lit} + +\section[release-0-16]{Release notes for version~0.16---07/93} +\input{0-16-notes.lit} + +\section[release-0-10]{Release notes for version~0.10---12/92} +\input{0-10-notes.lit} + +\section[release-0-09]{Release~0.09---9/92} + +This was an unannounced pseudo-release to a few people. + +\section[release-0-08]{Release notes for version~0.08---7/92} +\input{0-08-notes.lit} + +\section[release-0-07]{Release~0.07} + +This was an unannounced pseudo-release to a few people. + +\section[release-0-06]{Release notes for version~0.06---3/92} +\input{0-06-notes.lit} + +\section[release-0-05]{Release notes for version~0.05---12/91} +\input{0-05-notes.lit} + +\section[releases-0-03-04]{Releases between 0.02 and 0.05} + +There were a couple of private releases to highly zealous people, +mainly our friends at York. There are README files in the +\tr{release_notes/} dir about those, if you are really interested. + +\section[release-0-02]{Release notes for version~0.02---8/91} +\downsection +Nothing about version 0.02, our very first release, is still +interesting :-) +%\input{0-02-notes.lit} +\upsection + +\begin{onlystandalone} +% \printindex +\end{document} +\end{onlystandalone} diff --git a/ghc/docs/simple-monad.lhs b/ghc/docs/simple-monad.lhs new file mode 100644 index 0000000..82157b3 --- /dev/null +++ b/ghc/docs/simple-monad.lhs @@ -0,0 +1,264 @@ +A Simple Country Boy's Guide to Monadic-Style Programming +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Forget the category theory, forget all the fancy talk, forget "monadic +I/O", forget Phil Wadler's papers! Let's just do a little *plumbing* +in the monadic style, in plain-vanilla Haskell. + +You can compile this guide as a Haskell module; I haven't put in +enough code to make it run or do anytning interesting. Excuse me for +a moment, while I get some preliminaries out of the way... +\begin{code} +module Foo where + +infixr 9 `thenFoo`, `thenFoo_` -- ignore me + +data Foo = NullFoo | ConsFoo Int Foo -- assorted types, of little interest +type SwitchChecker = String -> Bool +type EnvA = [(String, Float)] +type NameSupply = Int +\end{code} + +*** MOTIVATION ********* + +If you find that your Haskell functions are starting to carry around a +lot of baggage ..., e.g., +\begin{code} +f :: EnvA -> SwitchChecker -> NameSupply -> Foo -> (Int, NameSupply) + +f env sw_chkr names NullFoo = (0, names) + +f env sw_chkr names (ConsFoo x xs) + = let + (x', names') = f env sw_chkr names xs + in + (x + x', names') +{- + `env' is some kind of environment; + what most people call "lookup tables". + `sw_chkr' is a function which, when presented with a + String, will tell you if that string was present + on the command line. + `names' is some kind of "name supply"; `f' + `f' returns a depleted name supply (2nd component of result). +-} +\end{code} + +...then it may be time to use monadic code to hide some of the mess!! + +GRATUITOUS PLUMBING OF STATE MUST DIE. + + +*** SETTING UP THE MONAD MACHINERY ******* + +First, divide the things to be plumbed into: + + * things that are only passed "downwards" through the function; + in the example above, the `env' and `sw_chkr' are such things; + + * things that are "threaded" through the function; you want the + changed whatsit back from "down below"; `names' is such a thing. + +Now, implement your monad; let's call it `FooM'; think of a `FooM +Wibble' as an *action* that, when performed, produces a `Wibble'. + +\begin{code} +type FooM a = EnvA -- type of lookup-tbl being plumbed + -> SwitchChecker -- type of switch looker-upper... + -> NameSupply -- NameSupply going down... + -> (a, -- result of the `FooM a' action + NameSupply) -- NameSupply that comes back... +\end{code} + +(Note: in reality, it would be good practice to hide all this stuff +behind a clean interface, in another module.) + +Let's write the basic operations on these `FooM a' guys: + +\begin{code} +returnFoo :: a -> FooM a + -- make a `FooM thing' action from a `thing' value + -- [Phil W would call this `unitFoo'] + +thenFoo :: FooM a -> (a -> FooM b) -> FooM b + -- sequence two actions; the second uses the + -- result of the first + -- [Phil W would call this `bindFoo', or semi-colon :-] + +thenFoo_ :: FooM a -> FooM b -> FooM b + -- sequence two actions; don't care about the + -- result of the first + -- [the name is a mnemonic for "... thenFoo \ _ -> ...] +\end{code} + +They're implemented in the obvious way: +\begin{code} +returnFoo thing env sw_chkr ns = (thing, ns) + +thenFoo action1 action2 env sw_chkr ns + = case (action1 env sw_chkr ns) of + (result1, ns1) -> action2 result1 env sw_chkr ns1 + +thenFoo_ action1 action2 env sw_chkr ns + = case (action1 env sw_chkr ns) of + (_{-boring result-}, ns1) -> action2 env sw_chkr ns1 +\end{code} + +All those are "pure plumbing". We need a few "monadic functions" that +do something useful. + +For example, you need to be able to "do a `FooM' action" and get the +answer back (along with the depleted NameSupply); for that, use... +\begin{code} +initFoo :: FooM a -> SwitchChecker -> NameSupply -> (NameSupply, a) + +initFoo action sw_chkr ns + = case (action [] sw_chkr ns) of + (result, new_ns) -> (new_ns, result) + -- gratuitous order-swapping +\end{code} + +You would then have a this-monad-specific set of functions to ``reach +down'' in the plumbing and use the env, switch-checker, etc., that are +being carried around. Some examples might be: +\begin{code} +getNewName :: FooM Int + +getNewName env sw_chkr ns = (ns, ns+1) + +------------ + +ifSwitchSet :: String -> FooM a -> FooM a -> FooM a + +ifSwitchSet sw_to_chk then_ else_ env sw_chkr ns + = (if (sw_chkr sw_to_chk) then then_ else else_) env sw_chkr ns + +------------ + +lookupInEnv :: String -> FooM Float + +lookupInEnv key env sw_chkr ns + = case [ v | (k, v) <- env, k == key ] of + [] -> error "lookupInEnv: no match" + (val:_) -> (val, ns) +\end{code} + +*** USING THE MONAD MACHINERY ******* + +We now have everything needed to write beautiful (!) monadic code. To +remind you of the basic "monadic" functions at our disposal: + +\begin{verbatim} +returnFoo :: a -> FooM a +thenFoo :: FooM a -> (a -> FooM b) -> FooM b +thenFoo_ :: FooM a -> FooM b -> FooM b +initFoo :: FooM a -> SwitchChecker -> NameSupply -> (NameSupply, a) + +getNewName :: FooM Int +ifSwitchSet :: String -> FooM a -> FooM a -> FooM a +lookupInEnv :: String -> FooM Float +\end{verbatim} + +Before going on: there are a few plumbing things that aren't +essential, but tend to be useful. They needn't be written at the +"bare-bones" level; they show the use of `returnFoo' and `thenFoo'. +\begin{code} +mapFoo :: (a -> FooM b) -> [a] -> FooM [b] + +mapFoo f [] = returnFoo [] +mapFoo f (x:xs) + = f x `thenFoo` \ r -> + mapFoo f xs `thenFoo` \ rs -> + returnFoo (r:rs) + +mapAndUnzipFoo :: (a -> FooM (b,c)) -> [a] -> FooM ([b],[c]) + +mapAndUnzipFoo f [] = returnFoo ([],[]) +mapAndUnzipFoo f (x:xs) + = f x `thenFoo` \ (r1, r2) -> + mapAndUnzipFoo f xs `thenFoo` \ (rs1, rs2) -> + returnFoo (r1:rs1, r2:rs2) +\end{code} + +You should read + + f x `thenFoo` \ r -> ... + +as + + "do `f' with argument `x', giving result `r'". + +If you wanted, you could do really horrible things with the C +pre-processor (GHC and HBC let you do this...): +\begin{verbatim} +#define RETN returnFoo +#define BIND {--} +#define _TO_ `thenFoo` \ {--} + +mapFoo f [] = RETN [] +mapFoo f (x:xs) + = BIND (f x) _TO_ r -> + BIND (mapFoo f xs) _TO_ rs -> + RETN (r:rs) +\end{verbatim} + +*** USING THE MONAD MACHINERY, FOR REAL ******* + +We can finally re-write our `f' function in a "monadic style" (except +I'll call it `g'), using the functions above. +\begin{code} +g :: Foo -> FooM Int + -- `g' has the same arguments as `f' (really), but in a different + -- order: just unravel the type synonyms + +g NullFoo = returnFoo 0 + +g (ConsFoo x xs) + = g xs `thenFoo` \ x' -> + returnFoo (x + x') +\end{code} + +LOOK, MOM, NO GRATUITOUS PLUMBING OF STATE! + +OK, `g' shows how much the monadic style tidies up the plumbing, but +it is really boring---it doesn't use any of the functions we defined +earlier. Here's a function that does: +\begin{code} +h :: Int -> FooM Integer + +h x + = getNewName `thenFoo_` -- ignore that one... + getNewName `thenFoo` \ int_name -> + + mapAndUnzipFoo zwonk [int_name ..] + `thenFoo` \ (some_nums, more_nums) -> + + ifSwitchSet "-beat-hbc" ( + returnFoo (toInteger (some_nums !! 6) + 42) + + ) {-else-} ( + lookupInEnv "-ghc-is-cool" `thenFoo` \ ghc_float -> + returnFoo (toInteger (truncate ghc_float)) + ) + where + zwonk :: Int -> FooM (Int, Int) + zwonk i = returnFoo (i, x*i) +\end{code} + +*** CONCLUSION ******* + +Ordinary Haskell programming, but in a "monadic style", is a good way +to control the plumbing of state through your code. + +I have left out lots and lots of Neat Things you can do with monads -- +see the papers for more interesting stuff. But 99% of the monadic +code you're likely to write or see will look like the stuff in here. + +Comments, suggestions, etc., to me, please. + +Will Partain +partain@dcs.glasgow.ac.uk + +% compile with: +% ghc -cpp Foo.lhs +% hbc -M Foo.lhs diff --git a/ghc/docs/users_guide/Jmakefile b/ghc/docs/users_guide/Jmakefile new file mode 100644 index 0000000..018e0e1 --- /dev/null +++ b/ghc/docs/users_guide/Jmakefile @@ -0,0 +1,9 @@ +LitStuffNeededHere(docs depend) +InfoStuffNeededHere(docs) + +LiterateSuffixRules() +DocProcessingSuffixRules() + +/* no space between the args! */ +/*LitDocRootTarget(profiling,lit)*/ +LitDocRootTarget(user,lit) diff --git a/ghc/docs/users_guide/glasgow_exts.lit b/ghc/docs/users_guide/glasgow_exts.lit new file mode 100644 index 0000000..e480f8c --- /dev/null +++ b/ghc/docs/users_guide/glasgow_exts.lit @@ -0,0 +1,722 @@ +%************************************************************************ +%* * +\section[glasgow-exts]{Glasgow extensions to Haskell} +\index{Haskell, Glasgow extensions} +\index{extensions, Glasgow Haskell} +%* * +%************************************************************************ + +As with all known Haskell systems, GHC implements some extensions to +the language. +To use them, you'll need to give +a \tr{-fglasgow-exts}% +\index{-fglasgow-exts option} option. + +Virtually all of the Glasgow extensions serve to give you access to the +underlying facilities with which we implement Haskell. Thus, you can +get at the Raw Iron, if you are willing to write some non-standard +code at a more primitive level. You need not be ``stuck'' on +performance because of the implementation costs of Haskell's +``high-level'' features---you can always code ``under'' them. In an +extreme case, you can write all your time-critical code in C, and then +just glue it together with Haskell! + +Executive summary of our extensions: +\begin{description} +\item[Unboxed types and primitive operations:] You can get right down +to the raw machine types and operations; included in this are +``primitive arrays'' (direct access to Big Wads of Bytes). +Please see \Sectionref{glasgow-unboxed} and following. + +%\item[Synchronising variables---\tr{_IVar}s, \tr{_MVar}s:] +%These are used when reads and writes need to be coordinated, +%e.g., if the readers and writers are different concurrent threads. +%Please see \Sectionref{ivars-mvars}. + +\item[Calling out to C:] Just what it sounds like. We provide {\em +lots} of rope that you can dangle around your neck. +Please see \Sectionref{glasgow-ccalls}. + +\item[``Monadic I/O:''] This stuff will be coming to you For Real +with Haskell~1.3, whenever that is. +Please see \Sectionref{io-1-3} (the ``1.3 I/O'' section). + +\item[``HBC-ish'' extensions:] Extensions implemented because people said, +``HBC does Y. Could you teach GHC to do the same?'' Please see +\Sectionref{glasgow-hbc-exts} for a quick list. +\end{description} + +Before you get too carried away working at the lowest level (e.g., +sloshing \tr{MutableByteArray#}s around your program), you may wish to +check if there are system libraries that provide a ``Haskellised +veneer'' over the features you want. See \Sectionref{syslibs}. + +The definitive guide for many of the low-level facilities in GHC is +the ``state interface document'' (distributed in +\tr{ghc/docs/state-interface.dvi}). We do not repeat its details here. + +%Pieter Hartel led an interesting comparison-of-many-compilers (and +%many languages) in which GHC got to show off its extensions. We did +%very well! For the full details, check out +%\tr{pub/computer-systems/functional/packages/pseudoknot.tar.Z} on \tr{ftp.fwi.uva.nl}. +%Good clean fun! + +%************************************************************************ +%* * +\subsection[glasgow-unboxed]{Unboxed types} +\index{Unboxed types (Glasgow extension)} +%* * +%************************************************************************ + +These types correspond to the ``raw machine'' types you would use in +C: \tr{Int#} (long int), \tr{Double#} (double), +\tr{Addr#} (void *), etc. The {\em primitive +operations} (PrimOps) on these types are what you might expect; e.g., +\tr{(+#)} is addition on \tr{Int#}s, and is the machine-addition that +we all know and love---usually one instruction. + +A numerically-intensive program using unboxed types can go a {\em lot} +faster than its ``standard'' counterpart---we saw a threefold speedup +on one example. + +Please see the very first part of the ``state interface document'' +(distributed in \tr{ghc/docs/state-interface.dvi}) for the details of +unboxed types and the operations on them. + +%************************************************************************ +%* * +\subsection[glasgow-ST-monad]{Primitive state-transformer monad} +\index{state transformers (Glasgow extensions)} +%* * +%************************************************************************ + +This monad underlies our implementation of arrays, mutable and immutable, +and our implementation of I/O, including ``C calls''. + +You probably won't use the monad directly, but you might use all those +other things! + +The ``state interface document'' defines the state-related types in +sections~1.4 and~1.5, and the monad itself in section~2.1. + +%************************************************************************ +%* * +\subsection[glasgow-prim-arrays]{Primitive arrays, mutable and otherwise} +\index{primitive arrays (Glasgow extension)} +\index{arrays, primitive (Glasgow extension)} +%* * +%************************************************************************ + +GHC knows about quite a few flavours of Large Swathes of Bytes. + +First, GHC distinguishes between primitive arrays of (boxed) Haskell +objects (type \tr{Array# obj}) and primitive arrays of bytes (type +\tr{ByteArray#}). + +Second, it distinguishes between... +\begin{description} +\item[Immutable:] +Arrays that do not change (as with ``standard'' Haskell arrays); you +can only read from them. Obviously, they do not need the care and +attention of the state-transformer monad. + +\item[Mutable:] +Arrays that may be changed or ``mutated.'' All the operations on them +live within the state-transformer monad and the updates happen {\em +in-place}. + +\item[``Static'' (in C land):] +A C~routine may pass an \tr{Addr#} pointer back into Haskell land. +There are then primitive operations with which you may merrily grab +values over in C land, by indexing off the ``static'' pointer. + +\item[``Stable'' pointers:] +If, for some reason, you wish to hand a Haskell pointer (i.e., {\em +not} an unboxed value) to a C~routine, you first make the pointer +``stable,'' so that the garbage collector won't forget that it exists. +That is, GHC provides a safe way to pass Haskell pointers to C. + +Please see \Sectionref{glasgow-stablePtrs} for more details. + +\item[``Malloc'' pointers:] +A ``malloc'' pointer is a safe way to pass a C~pointer to Haskell and +have Haskell do the Right Thing when it no longer references the +object. So, for example, C could pass a large bitmap over to Haskell +and say ``please free this memory when you're done with it.'' + +Please see \Sectionref{glasgow-mallocPtrs} for more details. +\end{description} + +See sections~1.4 and~1.6 of the ``state interface document'' for the +details of all these ``primitive array'' types and the operations on +them. + + +%************************************************************************ +%* * +\subsection[glasgow-ccalls]{Calling~C directly from Haskell} +\index{C calls (Glasgow extension)} +\index{_ccall_ (Glasgow extension)} +\index{_casm_ (Glasgow extension)} +%* * +%************************************************************************ + +%Besides using a \tr{-fglasgow-exts} flag, your modules need to include... +%\begin{verbatim} +%import PreludePrimIO +%\end{verbatim} + +SINCE VERSION 0.22: ``Literal-literals'', e.g., \tr{``NULL''}, can now +be any `boxed-primitive' type---they are not automatically taken to be +\tr{_Addr}s. This is cool, except you may sometimes have to put in +a type signature to force the desired type. + +SINCE VERSION 0.19: \tr{ccall} and \tr{casm} have been renamed to +\tr{_ccall_} and \tr{_casm_} and \tr{veryDangerousCcall} and +\tr{veryDangerousCasm} have been removed. It is no longer necessary +(nor legal!) to unbox/rebox the arguments and results to @_ccall_@. +GHC does the unboxing/reboxing for you. + +GOOD ADVICE: Because this stuff is not Entirely Stable as far as names +and things go, you would be well-advised to keep your C-callery +corraled in a few modules, rather than sprinkled all over your code. +It will then be quite easy to update later on. + +WARNING AS OF 0.26: Yes, the \tr{_ccall_} stuff probably {\em will +change}, to something better, of course! We are only at the +musing-about-it stage, however. + +%************************************************************************ +%* * +\subsubsection[ccall-intro]{\tr{_ccall_} and \tr{_casm_}: an introduction} +%* * +%************************************************************************ + +The simplest way to use a simple C function +\begin{verbatim} +double fooC( FILE *in, char c, int i, double d, unsigned int u ) +\end{verbatim} +is to provide a Haskell wrapper +\begin{verbatim} +fooH :: Char -> Int -> Double -> _Word -> PrimIO Double +fooH c i d w = _ccall_ fooC ``stdin'' c i d w +\end{verbatim} +The function @fooH@ will unbox all of its arguments, call the C +function \tr{fooC} and box the corresponding arguments. + +So, if you want to do C-calling, you have to confront the underlying +Glasgow I/O system. It's just your typical monad whatnot. + +%The code in \tr{ghc/lib/glaExts/*.lhs} is not too obtuse. +%That code, plus \tr{lib/prelude/Builtin.hs}, give examples +%of its use. The latter includes the implementations of \tr{error} and +%\tr{trace}. + +One of the annoyances about \tr{_ccall_}s is when the C types don't quite +match the Haskell compiler's ideas. For this, the \tr{_casm_} variant +may be just the ticket (NB: {\em no chance} of such code going through +a native-code generator): +\begin{verbatim} +oldGetEnv name + = _casm_ ``%r = getenv((char *) %0);'' name `thenPrimIO` \ litstring@(A# str#) -> + returnPrimIO ( + if (litstring == ``NULL'') then + Failure (SearchError ("GetEnv:"++name)) + else + Str (unpackCString# str#) + ) +\end{verbatim} + +The first literal-literal argument to a \tr{_casm_} is like a +\tr{printf} format: \tr{%r} is replaced with the ``result,'' +\tr{%0}--\tr{%n-1} are replaced with the 1st--nth arguments. As you +can see above, it is an easy way to do simple C~casting. Everything +said about \tr{_ccall_} goes for \tr{_casm_} as well. + +%************************************************************************ +%* * +\subsubsection[glasgow-foreign-headers]{Using function headers} +\index{C calls---function headers} +%* * +%************************************************************************ + +When generating C (using the \tr{-fvia-C} directive), one can assist +the C compiler in detecting type errors by using the \tr{-#include} +directive to provide \tr{.h} files containing function headers. + +For example, +\begin{verbatim} +typedef unsigned long *StgMallocPtr; +typedef long StgInt; + +extern void initialiseEFS PROTO( (StgInt size) ); +extern StgInt terminateEFS (); +extern StgMallocPtr emptyEFS(); +extern StgMallocPtr updateEFS PROTO( (StgMallocPtr a, StgInt i, StgInt x) ); +extern StgInt lookupEFS PROTO( (StgMallocPtr a, StgInt i) ); +\end{verbatim} + +You can find appropriate definitions for \tr{StgInt}, +\tr{StgMallocPtr}, etc using \tr{gcc} on your architecture by +consulting \tr{ghc/includes/StgTypes.lh}. The following table +summarises the relationship between Haskell types and C types. + +\begin{tabular}{ll} +C type name & Haskell Type \\ \hline +%----- & --------------- +\tr{StgChar} & \tr{Char#}\\ +\tr{StgInt} & \tr{Int#}\\ +\tr{StgWord} & \tr{Word#}\\ +\tr{StgAddr} & \tr{Addr#}\\ +\tr{StgFloat} & \tr{Float#}\\ +\tr{StgDouble} & \tr{Double#}\\ + +\tr{StgArray} & \tr{Array#}\\ +\tr{StgByteArray} & \tr{ByteArray#}\\ +\tr{StgArray} & \tr{MutableArray#}\\ +\tr{StgByteArray} & \tr{MutableByteArray#}\\ + +\tr{StgStablePtr} & \tr{StablePtr#}\\ +\tr{StgMallocPtr} & \tr{MallocPtr#} +\end{tabular} + +Note that this approach is only {\em essential\/} for returning +\tr{float}s (or if \tr{sizeof(int) != sizeof(int *)} on your +architecture) but is a Good Thing for anyone who cares about writing +solid code. You're crazy not to do it. + +%************************************************************************ +%* * +\subsubsection[glasgow-stablePtrs]{Subverting automatic unboxing with ``stable pointers''} +\index{stable pointers (Glasgow extension)} +%* * +%************************************************************************ + +The arguments of a \tr{_ccall_} are automatically unboxed before the +call. There are two reasons why this is usually the Right Thing to do: +\begin{itemize} +\item +C is a strict language: it would be excessively tedious to pass +unevaluated arguments and require the C programmer to force their +evaluation before using them. + +\item Boxed values are stored on the Haskell heap and may be moved +within the heap if a garbage collection occurs --- that is, pointers +to boxed objects are not {\em stable\/}. +\end{itemize} + +It is possible to subvert the unboxing process by creating a ``stable +pointer'' to a value and passing the stable pointer instead. (To use +stable pointers, you must \tr{import PreludeGlaMisc}.) For example, to +pass/return an integer lazily to C functions \tr{storeC} and +\tr{fetchC}, one might write: +\begin{verbatim} +storeH :: Int -> PrimIO () +storeH x = makeStablePtr x `thenPrimIO` \ stable_x -> + _ccall_ storeC stable_x + +fetchH :: PrimIO Int +fetchH x = _ccall_ fetchC `thenPrimIO` \ stable_x -> + deRefStablePtr stable_x `thenPrimIO` \ x -> + freeStablePtr stable_x `seqPrimIO` + returnPrimIO x +\end{verbatim} + +The garbage collector will refrain from throwing a stable pointer away +until you explicitly call one of the following from C or Haskell. +\begin{verbatim} +void freeStablePointer( StgStablePtr stablePtrToToss ) +freeStablePtr :: _StablePtr a -> PrimIO () +\end{verbatim} + +As with the use of \tr{free} in C programs, GREAT CARE SHOULD BE +EXERCISED to ensure these functions are called at the right time: too +early and you get dangling references (and, if you're lucky, an error +message from the runtime system); too late and you get space leaks. + +%Doesn't work in ghc-0.23 - best to just keep quiet about them. +% +%And to force evaluation of the argument within \tr{fooC}, one would +%call one of the following C functions (according to type of argument). +% +%\begin{verbatim} +%void performIO ( StgStablePtr stableIndex /* _StablePtr s (PrimIO ()) */ ); +%StgInt enterInt ( StgStablePtr stableIndex /* _StablePtr s Int */ ); +%StgFloat enterFloat ( StgStablePtr stableIndex /* _StablePtr s Float */ ); +%\end{verbatim} +% +%ToDo ADR: test these functions! +% +%Note Bene: \tr{_ccall_GC_} must be used if any of these functions are used. + + +%************************************************************************ +%* * +\subsubsection[glasgow-mallocPtrs]{Pointing outside the Haskell heap} +\index{malloc pointers (Glasgow extension)} +%* * +%************************************************************************ + +There are two types that \tr{ghc} programs can use to reference +(heap-allocated) objects outside the Haskell world: \tr{_Addr} and +\tr{_MallocPtr}. (You must import \tr{PreludeGlaMisc} to use +\tr{_MallocPtr}.) + +If you use \tr{_Addr}, it is up to you to the programmer to arrange +allocation and deallocation of the objects. + +If you use \tr{_MallocPtr}, \tr{ghc}'s garbage collector will +call the user-supplied C function +\begin{verbatim} +void FreeMallocPtr( StgMallocPtr garbageMallocPtr ) +\end{verbatim} +when the Haskell world can no longer access the object. Since +\tr{_MallocPtr}s only get released when a garbage collection occurs, +we provide ways of triggering a garbage collection from within C and +from within Haskell. +\begin{verbatim} +void StgPerformGarbageCollection() +performGC :: PrimIO () +\end{verbatim} + +%************************************************************************ +%* * +\subsubsection[glasgow-avoiding-monads]{Avoiding monads} +\index{C calls to `pure C'} +\index{unsafePerformPrimIO (PreludeGlaST)} +%* * +%************************************************************************ + +The \tr{_ccall_} construct is part of the \tr{PrimIO} monad because 9 +out of 10 uses will be to call imperative functions with side effects +such as \tr{printf}. Use of the monad ensures that these operations +happen in a predictable order in spite of laziness and compiler +optimisations. + +There are three situations where one might like to use +@unsafePerformPrimIO@ to avoid the monad: +\begin{itemize} +\item +Calling a function with no side-effects: +\begin{verbatim} +atan2d :: Double -> Double -> Double +atan2d y x = unsafePerformPrimIO (_ccall_ atan2d y x) + +sincosd :: Double -> (Double, Double) +sincosd x = unsafePerformPrimIO ( + newDoubleArray (0, 1) `thenPrimIO` \ da -> + _casm_ ``sincosd( %0, &((double *)%1[0]), &((double *)%1[1]) );'' x da + `seqPrimIO` + readDoubleArray da 0 `thenPrimIO` \ s -> + readDoubleArray da 1 `thenPrimIO` \ c -> + returnPrimIO (s, c) + ) +\end{verbatim} + +\item Calling a set of functions which have side-effects but which can +be used in a purely functional manner. + +For example, an imperative implementation of a purely functional +lookup-table might be accessed using the following functions. + +\begin{verbatim} +empty :: EFS x +update :: EFS x -> Int -> x -> EFS x +lookup :: EFS a -> Int -> a + +empty = unsafePerformPrimIO (_ccall_ emptyEFS) + +update a i x = unsafePerformPrimIO ( + makeStablePtr x `thenPrimIO` \ stable_x -> + _ccall_ updateEFS a i stable_x + ) + +lookup a i = unsafePerformPrimIO ( + _ccall_ lookupEFS a i `thenPrimIO` \ stable_x -> + deRefStablePtr stable_x + ) +\end{verbatim} + +You will almost always want to use \tr{_MallocPtr}s with this. + +\item Calling a side-effecting function even though the results will +be unpredictable. For example the \tr{trace} function is defined by: + +\begin{verbatim} +trace :: String -> a -> a +trace string expr = unsafePerformPrimIO ( + appendChan# ``stderr'' "Trace On:\n" `seqPrimIO` + appendChan# ``stderr'' string `seqPrimIO` + appendChan# ``stderr'' "\nTrace Off.\n" `seqPrimIO` + returnPrimIO expr ) +\end{verbatim} + +(This kind of use is not highly recommended --- it is only really +useful in debugging code.) + +\end{itemize} + +%************************************************************************ +%* * +\subsubsection[ccall-gotchas]{C-calling ``gotchas'' checklist} +\index{C call dangers} +%* * +%************************************************************************ + +And some advice, too. + +\begin{itemize} +\item +\tr{_ccall_} is part of the \tr{PrimIO} monad --- not the 1.3 \tr{IO} Monad. +Use the function +\begin{verbatim} +primIOToIO :: PrimIO a -> IO a +\end{verbatim} +to promote a \tr{_ccall_} to the \tr{IO} monad. + +\item +For modules that use \tr{_ccall_}s, etc., compile with \tr{-fvia-C}.\index{-fvia-C option} +You don't have to, but you should. + +Also, use the \tr{-#include "prototypes.h"} flag (hack) to inform the +C compiler of the fully-prototyped types of all the C functions you +call. (\Sectionref{glasgow-foreign-headers} says more about this...) + +This scheme is the {\em only} way that you will get {\em any} +typechecking of your \tr{_ccall_}s. (It shouldn't be that way, +but...) + +\item +Try to avoid \tr{_ccall_}s to C~functions that take \tr{float} +arguments or return \tr{float} results. Reason: if you do, you will +become entangled in (ANSI?) C's rules for when arguments/results are +promoted to \tr{doubles}. It's a nightmare and just not worth it. +Use \tr{doubles} if possible. + +If you do use \tr{floats}, check and re-check that the right thing is +happening. Perhaps compile with \tr{-keep-hc-file-too} and look at +the intermediate C (\tr{.hc} file). + +\item +The compiler uses two non-standard type-classes when +type-checking the arguments and results of \tr{_ccall_}: the arguments +(respectively result) of \tr{_ccall_} must be instances of the class +\tr{_CCallable} (respectively \tr{_CReturnable}. (Neither class +defines any methods --- their only function is to keep the +type-checker happy.) + +The type checker must be able to figure out just which of the +C-callable/returnable types is being used. If it can't, you have to +add type signatures. For example, +\begin{verbatim} +f x = _ccall_ foo x +\end{verbatim} +is not good enough, because the compiler can't work out what type @x@ is, nor +what type the @_ccall_@ returns. You have to write, say: +\begin{verbatim} +f :: Int -> PrimIO Double +f x = _ccall_ foo x +\end{verbatim} + +This table summarises the standard instances of these classes. + +% ToDo: check this table against implementation! + +\begin{tabular}{llll} +Type &CCallable&CReturnable & Which is probably... \\ \hline +%------ ---------- ------------ ------------- +\tr{Char} & Yes & Yes & \tr{unsigned char} \\ +\tr{Int} & Yes & Yes & \tr{long int} \\ +\tr{_Word} & Yes & Yes & \tr{unsigned long int} \\ +\tr{_Addr} & Yes & Yes & \tr{char *} \\ +\tr{Float} & Yes & Yes & \tr{float} \\ +\tr{Double} & Yes & Yes & \tr{double} \\ +\tr{()} & No & Yes & \tr{void} \\ +\tr{[Char]} & Yes & No & \tr{char *} (null-terminated) \\ + +\tr{Array} & Yes & No & \tr{unsigned long *}\\ +\tr{_ByteArray} & Yes & No & \tr{unsigned long *}\\ +\tr{_MutableArray} & Yes & No & \tr{unsigned long *}\\ +\tr{_MutableByteArray} & Yes & No & \tr{unsigned long *}\\ + +\tr{_State} & Yes & Yes & nothing!\\ + +\tr{_StablePtr} & Yes & Yes & \tr{unsigned long *}\\ +\tr{_MallocPtr} & Yes & Yes & see later\\ +\end{tabular} + +The brave and careful programmer can add their own instances of these +classes for the following types: +\begin{itemize} +\item +A {\em boxed-primitive} type may be made an instance of both +\tr{_CCallable} and \tr{_CReturnable}. + +A boxed primitive type is any data type with a +single unary constructor with a single primitive argument. For +example, the following are all boxed primitive types: + +\begin{verbatim} +Int +Double +data XDisplay = XDisplay Addr# +data EFS a = EFS# MallocPtr# +\end{verbatim} + +\begin{verbatim} +instance _CCallable (EFS a) +instance _CReturnable (EFS a) +\end{verbatim} + +\item Any datatype with a single nullary constructor may be made an +instance of \tr{_CReturnable}. For example: + +\begin{verbatim} +data MyVoid = MyVoid +instance _CReturnable MyVoid +\end{verbatim} + +\item As at version 0.26, \tr{String} (i.e., \tr{[Char]}) is still +not a \tr{_CReturnable} type. + +Also, the now-builtin type \tr{_PackedString} is neither +\tr{_CCallable} nor \tr{_CReturnable}. (But there are functions in +the PackedString interface to let you get at the necessary bits...) +\end{itemize} + +\item +The code-generator will complain if you attempt to use \tr{%r} +in a \tr{_casm_} whose result type is \tr{PrimIO ()}; or if you don't +use \tr{%r} {\em precisely\/} once for any other result type. These +messages are supposed to be helpful and catch bugs---please tell us +if they wreck your life. + +\item +If you call out to C code which may trigger the Haskell garbage +collector (examples of this later...), then you must use the +\tr{_ccall_GC_} or \tr{_casm_GC_} variant of C-calls. (This does not +work with the native code generator - use \tr{\fvia-C}.) This stuff is +hairy with a capital H! +\end{itemize} + +%************************************************************************ +%* * +%\subsubsection[ccall-good-practice]{C-calling ``good practice'' checklist} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsection[glasgow-hbc-exts]{``HBC-ish'' extensions implemented by GHC} +\index{HBC-like Glasgow extensions} +\index{extensions, HBC-like} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[@fromInt@ method in class @Num@:] +It's there. Converts from an \tr{Int} to the type. + +%------------------------------------------------------------------- +\item[@toInt@ method in class @Integral@:] +Converts from type type to an \tr{Int}. + +%------------------------------------------------------------------- +\item[Overlapping instance declarations:] +\index{overlapping instances} +\index{instances, overlapping} + +In \tr{instance => Class (T x1 ... xn)}, the \tr{xi}s can be +{\em types}, rather than just {\em type variables}. + +Thus, you can have an instance \tr{instance Foo [Char]}, as well as +the more general \tr{instance Foo [a]}; the former will be used in +preference to the latter, where applicable. + +As Lennart says, ``This is a dubious feature and should not be used +carelessly.'' + +See also: \tr{SPECIALIZE instance} pragmas, in \Sectionref{faster}. + +%------------------------------------------------------------------- +\item[Signal-handling I/O request:] +\index{signal handling (extension)} +\index{SigAction I/O request} +The Haskell-1.2 I/O request \tr{SigAction n act} installs a signal handler for signal +\tr{n :: Int}. The number is the usual UNIX signal number. The action +is of this type: +\begin{verbatim} +data SigAct + = SAIgnore + | SADefault + | SACatch Dialogue +\end{verbatim} + +The corresponding continuation-style I/O function is the unsurprising: +\begin{verbatim} +sigAction :: Int -> SigAct -> FailCont -> SuccCont -> Dialogue +\end{verbatim} + +When a signal handler is installed with \tr{SACatch}, receipt of the +signal causes the current top-level computation to be abandoned, and +the specified dialogue to be executed instead. The abandoned +computation may leave some partially evaluated expressions in a +non-resumable state. If you believe that your top-level computation +and your signal handling dialogue may share subexpressions, you should +execute your program with the \tr{-N} RTS option, to prevent +black-holing. + +The \tr{-N} option is not available with concurrent/parallel programs, +so great care should be taken to avoid shared subexpressions between +the top-level computation and any signal handlers when using threads. + +%------------------------------------------------------------------- +%\item[Simple time-out mechanism, in ``monadic I/O'':] +%\index{time-outs (extension)} +% +%This function is available: +%\begin{verbatim} +%timeoutIO :: Int -> IO Void -> IO (IO Void) +%\end{verbatim} +% +%Wait that many seconds, then abandon the current computation and +%perform the given I/O operation (second argument). Uses the +%signal-handling, so it returns the previous signal-handler (in case +%you want to re-install it). As above, you may need to execute your +%program with the RTS flag \tr{-N}, to prevent black-holing. +% +\end{description} + +%************************************************************************ +%* * +%\subsection[glasgow-compiler-namespace]{Fiddlings the compiler's built-in namespaces} +%* * +%************************************************************************ + +%This is really only used for compiling the prelude. It's turgid and +%will probably change. + +% \begin{description} +% \item[\tr{-no-implicit-prelude}:] +% \index{-no-implicit-prelude option} +% +% ???? (Tells the parser not to read \tr{Prelude.hi}). +% +% \item[\tr{-fhide-builtin-names}:] +% \index{-fhide-builtin-names option} +% This hides {\em all} Prelude names built-in to the compiler. +% +% \item[\tr{-fmin-builtin-names}:] +% \index{-fmin-builtin-names option} +% This hides all but a few of the Prelude names that are built-in to the +% compiler. @:@ (cons) is an example of one that would remain visible. +% +% \item[\tr{-fhide-builtin-instances}:] +% \index{-fhide-builtin-instances option} +% This suppresses the compiler's own ideas about what instances already +% exist (e.g., \tr{instance Eq Int}). +% +% This flag is used when actually compiling the various instance +% declarations in the Prelude. +% \end{description} diff --git a/ghc/docs/users_guide/gone_wrong.lit b/ghc/docs/users_guide/gone_wrong.lit new file mode 100644 index 0000000..4403d20 --- /dev/null +++ b/ghc/docs/users_guide/gone_wrong.lit @@ -0,0 +1,332 @@ +%************************************************************************ +%* * +\section[wrong]{What to do when something goes wrong} +\index{problems} +%* * +%************************************************************************ + +If you still have a problem after consulting this section, then you +may have found a {\em bug}---please report it! See +\Sectionref{bug-reports} for a list of things we'd like to know about +your bug. If in doubt, send a report---we love mail from irate users :-! + +(\Sectionref{vs-Haskell-defn}, which describes Glasgow Haskell's +shortcomings vs.~the Haskell language definition, may also be of +interest.) + +%************************************************************************ +%* * +\subsection[wrong-compiler]{When the compiler ``does the wrong thing''} +\index{compiler problems} +\index{problems with the compiler} +%* * +%************************************************************************ + +\begin{description} +%------------------------------------------------------------------- +\item[``Help! The compiler crashed (or `panic'd)!''] +These events are {\em always} bugs in the GHC system---please report +them. + +%Known compiler ``panics'': +%\begin{description} +%\item[From SPARC native-code generator:] These tend to say something +%like ``unknown PrimOp;'' you can avoid it by compiling that module +%with \tr{-fvia-C}.\index{-fvia-C option} +%\end{description} + +%------------------------------------------------------------------- +\item[``The compiler ran out of heap (or stack) when compiling itself!''] +It happens. We try to supply reasonable \tr{-H} flags for +\tr{ghc/compiler/} and \tr{ghc/lib/}, but GHC's memory consumption +can vary by platform (e.g., on a 64-bit machine). + +Just say \tr{make all EXTRA_HC_OPTS=-H} and see +how you get along. + +%------------------------------------------------------------------- +\item[``The compiler died with a pattern-matching error.''] +This is a bug just as surely as a ``panic.'' Please report it. + +%------------------------------------------------------------------- +\item[``Some confusion about a value specialised to a type...'' Huh???] +(A deeply obscure and unfriendly error message.) + +This message crops up when the typechecker is sees a reference in an +interface pragma to a specialisation of an overloaded value +(function); for example, \tr{elem} specialised for type \tr{[Char]} +(\tr{String}). The problem is: it doesn't {\em know} that such a +specialisation exists! + +The cause of this problem is (please report any other cases...): The +compiler has imported pragmatic info for the value in question from +more than one interface, and the multiple interfaces did not agree +{\em exactly} about the value's pragmatic info. Since the compiler +doesn't know whom to believe, it believes none of them. + +The cure is to re-compile the modules that {\em re-export} the +offending value (after possibly re-compiling its defining module). +Now the pragmatic info should be exactly the same in every case, and +things should be fine. + +%------------------------------------------------------------------- +\item[``Can't see the data constructors for a ccall/casm'' Huh?] +GHC ``unboxes'' C-call arguments and ``reboxes'' C-call results for you. +To do this, it {\\em has} to be able to see the types fully; +abstract types won't do! + +Thus, if you say \tr{data Foo = Foo Int#} +(a cool ``boxed primitive'' type), but then make it abstract +(only \tr{data Foo} appears in the interface), then GHC can't figure +out what to do with \tr{Foo} arguments/results to C-calls. + +Solutions: either make the type unabstract, or compile with \tr{-O}. +With the latter, the constructor info will be passed along in +the interface pragmas. + +%------------------------------------------------------------------- +\item[``This is a terrible error message.''] +If you think that GHC could have produced a better error message, +please report it as a bug. + +%------------------------------------------------------------------- +\item[``What about these `trace' messages from GHC?''] +Almost surely not a problem. About some specific cases... +\begin{description} +\item[Simplifier still going after N iterations:] +Sad, but harmless. You can change the number with a +\tr{-fmax-simplifier-iterations}\index{-fmax-simplifier-iterations option} option (no space); +and you can see what actions took place in each iteration by +turning on the \tr{-fshow-simplifier-progress} +\index{-fshow-simplifier-progress option} option. + +If the simplifier definitely seems to be ``looping,'' please report +it. +\end{description} + +%------------------------------------------------------------------- +\item[``What about this warning from the C compiler?''] + +For example: ``...warning: `Foo' declared `static' but never defined.'' +Unsightly, but not a problem. + +%------------------------------------------------------------------- +\item[Sensitivity to \tr{.hi} interface files:] + +GHC is very sensitive about interface files. For example, if it picks +up a non-standard \tr{Prelude.hi} file, pretty terrible things will +happen. If you turn on +\tr{-fno-implicit-prelude}\index{-fno-implicit-prelude option}, the +compiler will almost surely die, unless you know what you are doing. + +Furthermore, as sketched below, you may have big problems +running programs compiled using unstable interfaces. + +%------------------------------------------------------------------- +\item[``I think GHC is producing incorrect code'':] + +Unlikely :-) A useful be-more-paranoid option to give to GHC is +\tr{-dcore-lint}\index{-dcore-lint option}; this causes a ``lint'' pass to +check for errors (notably type errors) after each Core-to-Core +transformation pass. We run with \tr{-dcore-lint} on all the time; it +costs about 5\% in compile time. (Or maybe 25\%; who knows?) + +%------------------------------------------------------------------- +%\item[``Can I use HBC-produced \tr{.hi} interface files?''] +%Yes, though you should keep compiling until you have a stable set of +%GHC-produced ones. + +%------------------------------------------------------------------- +\item[``Why did I get a link error?''] + +If the linker complains about not finding \tr{__fast}, then +your interface files haven't settled---keep on compiling! (In +particular, this error means that arity information, which you can see +in any \tr{.hi} file, has changed.) + +%If the linker complains about not finding \tr{SpA}, \tr{SuA}, and +%other such things, then you've tried to link ``unregisterised'' object +%code (produced with \tr{-O0}) with the normal registerised stuff. + +%If you get undefined symbols that look anything like (for example) +%\tr{J3C_Interact$__writeln}, \tr{C_Prelude$__$2B$2B}, +%\tr{VC_Prelude$__map}, etc., then you are trying to link HBC-produced +%object files with GHC. + +%------------------------------------------------------------------- +\item[``What's a `consistency error'?''] +(These are reported just after linking your program.) + +You tried to link incompatible object files, e.g., normal ones +(registerised, Appel garbage-collector) with profiling ones (two-space +collector). Or those compiled by a previous version of GHC +with an incompatible newer version. + +If you run \tr{nm -o *.o | egrep 't (cc|hsc)\.'} (or, on +unregisterised files: \tr{what *.o}), you'll see all the consistency +tags/strings in your object files. They must all be the same! +(ToDo: tell you what they mean...) + +%------------------------------------------------------------------- +\item[``Is this line number right?''] +On this score, GHC usually does pretty well, especially +if you ``allow'' it to be off by one or two. In the case of an +instance or class declaration, the line number +may only point you to the declaration, not to a specific method. + +Please report line-number errors that you find particularly unhelpful. +\end{description} + +%************************************************************************ +%* * +\subsection[wrong-compilee]{When your program ``does the wrong thing''} +\index{problems running your program} +%* * +%************************************************************************ + +(For advice about overly slow or memory-hungry Haskell programs, +please see \sectionref{sooner-faster-quicker}). + +\begin{description} +%----------------------------------------------------------------------- +\item[``Help! My program crashed!''] +(e.g., a `segmentation fault' or `core dumped') + +If your program has no @_ccall_@s/@_casm_@s in it, then a crash is always +a BUG in the GHC system, except in one case: If your program is made +of several modules, each module must have been compiled with a stable +group of interface (\tr{.hi}) files. + +For example, if an interface is lying about the type of an imported +value then GHC may well generate duff code for the importing module. +{\em This applies to pragmas inside interfaces too!} If the pragma is +lying (e.g., about the ``arity'' of a value), then duff code may result. +Furthermore, arities may change even if types do not. + +In short, if you compile a module and its interface changes, then all +the modules that import that interface {\em must} be re-compiled. + +A useful option to alert you when interfaces change is +\tr{-hi-diffs}\index{-hi-diffs option}. It will run \tr{diff} on the +changed interface file, before and after, when applicable. + +If you are using \tr{make}, a useful tool to make sure that every +module {\em is} up-to-date with respect to its imported interfaces is +\tr{mkdependHS} (which comes with GHC). Please see +\sectionref{mkdependHS}. + +If you are down to your last-compile-before-a-bug-report, we +would recommend that you add a \tr{-dcore-lint} option (for +extra checking) to your compilation options. + +So, before you report a bug because of a core dump, you should probably: +\begin{verbatim} +% rm *.o # scrub your object files +% make my_prog # re-make your program; use -hi-diffs to highlight changes +% ./my_prog ... # retry... +\end{verbatim} + +Of course, if you have @_ccall_@s/@_casm_@s in your program then all bets +are off, because you can trash the heap, the stack, or whatever. + +If you are interested in hard-core debugging of a crashing +GHC-compiled program, please see \sectionref{hard-core-debug}. + +% (If you have an ``unregisterised'' arity-checking +% (\tr{-O0 -darity-checks}) around [as we sometimes do at Glasgow], then you +% might recompile with \tr{-darity-checks}\index{-darity-checks option}, +% which will definitely detect arity-compatibility errors.) + +%------------------------------------------------------------------- +\item[``My program entered an `absent' argument.''] +This is definitely caused by a bug in GHC. Please report it. + +%----------------------------------------------------------------------- +\item[``What's with this `arithmetic (or `floating') exception' ''?] + +@Int@, @Float@, and @Double@ arithmetic is {\em unchecked}. Overflows +and underflows are {\em silent}. Divide-by-zero {\em may} cause an +untrapped exception (please report it if it does). I suppose other +arithmetic uncheckiness might cause an exception, too... +\end{description} + +%************************************************************************ +%* * +\subsection[bug-reports]{How to report a bug in the GHC system} +\index{bug reports} +%* * +%************************************************************************ + +Glasgow Haskell is a changing system so there are sure to be bugs in +it. Please report them to +\tr{glasgow-haskell-bugs@dcs.glasgow.ac.uk}! (However, please check +the earlier part of this section to be sure it's not a known +not-really-a problem.) + +The name of the bug-reporting game is: facts, facts, facts. +Don't omit them because ``Oh, they won't be interested...'' +\begin{enumerate} +\item +What kind of machine are you running on, and exactly what version of the +operating system are you using? (\tr{cat /etc/motd} often shows the desired +information.) + +\item +What version of GCC are you using? \tr{gcc -v} will tell you. + +\item +Run the sequence of compiles/runs that caused the offending behaviour, +capturing all the input/output in a ``script'' (a UNIX command) or in +an Emacs shell window. We'd prefer to see the whole thing. + +\item +Be sure any Haskell compilations are run with a \tr{-v} (verbose) +flag, so we can see exactly what was run, what versions of things you +have, etc. + +\item +What is the program behaviour that is wrong, in your opinion? + +\item +If practical, please send enough source files/interface files for us +to duplicate the problem. + +\item +If you are a Hero and track down the problem in the compilation-system +sources, please send us {\em whole files} (by e-mail or FTP) that we +can compare against some base release. +\end{enumerate} + +%************************************************************************ +%* * +\subsection[hard-core-debug]{Hard-core debugging of GHC-compiled programs} +\index{debugging, hard-core} +%* * +%************************************************************************ + +If your program is crashing, you should almost surely file a bug +report, as outlined in previous sections. + +This section suggests ways to Make Further Progress Anyway. + +The first thing to establish is: Is it a garbage-collection (GC) bug? +Try your program with a very large heap and a \tr{-Sstderr} RTS +flag. +\begin{itemize} +\item +If it crashes {\em without} garbage-collecting, then it is +definitely {\em not} a GC bug. +\item +If you can make it crash with one heap size but not with another, then +it {\em probably is} a GC bug. +\item +If it crashes with the normal +collector, but not when you force two-space collection (\tr{-F2s} +runtime flag), then it {\em probably is} a GC bug. +\end{itemize} + +If it {\em is} a GC bug, you may be able to avoid it by using a +particular heap size or by using a \tr{-F2s} runtime flag. (But don't +forget to report the bug!!!) + +ToDo: more here? diff --git a/ghc/docs/users_guide/how_to_run.lit b/ghc/docs/users_guide/how_to_run.lit new file mode 100644 index 0000000..79c7ab9 --- /dev/null +++ b/ghc/docs/users_guide/how_to_run.lit @@ -0,0 +1,1139 @@ +\section[invoking-GHC]{Invoking GHC: Command-line options} +\index{command-line options} +\index{options, GHC command-line} + +Command-line arguments are either options or file names. + +Command-line options begin with \tr{-}. They may {\em not} be +grouped: \tr{-vO} is different from \tr{-v -O}. +Options need not precede filenames: e.g., \tr{ghc *.o -o foo}. +All options are processed +and then apply to all files; you cannot, for example, +invoke \tr{ghc -c -O1 Foo.hs -O2 Bar.hs} to apply different +optimisation levels to the files \tr{Foo.hs} and \tr{Bar.hs}. For +conflicting options, e.g., \tr{-c -S}, we reserve the right to do +anything we want. (Usually, the last one applies.) + +Options related to profiling, Glasgow extensions to Haskell (e.g., +unboxed values), Concurrent and Parallel Haskell are +described in \sectionref{profiling}, \sectionref{glasgow-exts}, and +\sectionref{concurrent-and-parallel}, respectively. + +%************************************************************************ +%* * +\subsection[file-suffixes]{Meaningful file suffixes} +\index{suffixes, file} +\index{file suffixes for GHC} +%* * +%************************************************************************ + +File names with ``meaningful'' suffixes (e.g., \tr{.lhs} or \tr{.o}) +cause the ``right thing'' to happen to those files. + +\begin{description} +\item[\tr{.lhs}:] +\index{lhs suffix@.lhs suffix} +A ``literate Haskell'' module. + +\item[\tr{.hs}:] +A not-so-literate Haskell module. + +\item[\tr{.hi}:] +A Haskell interface file, probably compiler-generated. + +\item[\tr{.hc}:] +Intermediate C file produced by the Haskell compiler. + +\item[\tr{.c}:] +A C~file not produced by the Haskell compiler. + +% \item[\tr{.i}:] +% C code after it has be preprocessed by the C compiler (using the +% \tr{-E} flag). + +\item[\tr{.s}:] +An assembly-language source file, usually +produced by the compiler. + +\item[\tr{.o}:] +An object file, produced by an assembler. +\end{description} + +Files with other suffixes (or without suffixes) are passed straight +to the linker. + +%************************************************************************ +%* * +\subsection[options-help]{Help and verbosity options} +\index{help options (GHC)} +\index{verbose option (GHC)} +%* * +%************************************************************************ + +A good option to start with is the \tr{-help} (or \tr{-?}) option. +\index{-help option} +\index{-? option} +GHC spews a long message to standard output and then exits. + +The \tr{-v}\index{-v option} option makes GHC {\em verbose}: it +reports its version number and shows (on stderr) exactly how it invokes each +phase of the compilation system. Moreover, it passes +the \tr{-v} flag to most phases; each reports +its version number (and possibly some other information). + +Please, oh please, use the \tr{-v} option when reporting bugs! +Knowing that you ran the right bits in the right order is always the +first thing we want to verify. + +%************************************************************************ +%* * +\subsection[options-order]{Running the right phases in the right order} +\index{order of passes in GHC} +\index{pass ordering in GHC} +%* * +%************************************************************************ + +The basic task of the \tr{ghc} driver is to run each input file +through the right phases (parsing, linking, etc.). + +The first phase to run is determined by the input-file suffix, and the +last phase is determined by a flag. If no relevant flag is present, +then go all the way through linking. This table summarises: + +\begin{tabular}{llll} +phase of the & suffix saying & flag saying & (suffix of) \\ +compilation system & ``start here''& ``stop after''& output file \\ \hline + +literate pre-processor & .lhs & - & - \\ +C pre-processor (opt.) & - & - & - \\ +Haskell parser & .hs & - & - \\ +Haskell compiler & - & -C, -S & .hc, .s \\ +C compiler (opt.) & .hc or .c & -S & .s \\ +assembler & .s & -c & .o \\ +linker & other & - & a.out \\ +\end{tabular} +\index{-C option} +\index{-S option} +\index{-c option} + +Thus, a common invocation would be: \tr{ghc -c Foo.hs} + +Note: What the Haskell compiler proper produces depends on whether a +native-code generator is used (producing assembly language) or not +(producing C). + +%The suffix information may be overridden with a \tr{-lang } +%\index{-lang option} option. This says: process all inputs +%files as if they had suffix \pl{}. [NOT IMPLEMENTED YET] + +The option \tr{-cpp}\index{-cpp option} must be given for the C +pre-processor phase to be run. + +The option \tr{-E}\index{-E option} runs just the C-preprocessor part +of the C-compiling phase, sending the result to stdout [I think]. (For +debugging, usually.) + +%************************************************************************ +%* * +\subsection[options-optimise]{Optimisation (code improvement)} +\index{optimisation (GHC)} +\index{improvement, code (GHC)} +%* * +%************************************************************************ + +The \tr{-O*} options specify convenient ``packages'' of optimisation +flags; the \tr{-f*} options described later on specify {\em individual} +optimisations to be turned on/off; the \tr{-m*} options specify {\em +machine-specific} optimisations to be turned on/off. + +%---------------------------------------------------------------------- +\subsubsection[optimise-pkgs]{\tr{-O*}: convenient ``packages'' of optimisation flags.} +\index{-O options (GHC)} + +There are {\em many} options that affect the quality of code produced by +GHC. Most people only have a general goal, something like ``Compile +quickly'' or ``Make my program run like greased lightning.'' The +following ``packages'' of optimisations (or lack thereof) should suffice. + +Once you choose a \tr{-O*} ``package,'' stick with it---don't chop and +change. Modules' interfaces {\em will} change with a shift to a new +\tr{-O*} option, and you will have to recompile all importing modules +before your program can again be run safely. + +\begin{description} +\item[No \tr{-O*}-type option specified:] +\index{-O* not specified} +This is taken to mean: ``Please compile quickly; I'm not over-bothered +about compiled-code quality.'' So, for example: \tr{ghc -c Foo.hs} + +\item[\tr{-O} or \tr{-O1}:] +\index{-O option} +\index{-O1 option} +\index{optimise normally} +Means: ``Generate good-quality code without taking too long about it.'' +Thus, for example: \tr{ghc -c -O Main.lhs} + +\item[\tr{-O2}:] +\index{-O2 option} +\index{optimise aggressively} +Means: ``Apply every non-dangerous optimisation, even if it means +significantly longer compile times.'' + +The avoided ``dangerous'' optimisations are those that can make +runtime or space {\em worse} if you're unlucky. They are +normally turned on or off individually. + +As of version~0.26, \tr{-O2} is {\em unlikely} to produce +better code than \tr{-O}. + +% \item[\tr{-O0}:] +% \index{-O0 option} +% \index{optimise minimally} +% [``Oh zero''] Means: ``Turn {\em off} as many optimisations (e.g., +% simplifications) as possible.'' This is the only optimisation level +% at which the GCC-register-trickery is turned off. {\em You can't use +% it unless you have a suitably-built Prelude to match.} Intended for +% hard-core debugging. + +\item[\tr{-fvia-C}:] +\index{-fvia-C option} +Compile via C, and don't use the native-code generator. +(There are many cases when GHC does this on its own.) You might +pick up a little bit of speed by compiling via C. If you use +\tr{_ccall_}s or \tr{_casm_}s, you probably {\em have to} use +\tr{-fvia-C}. + +\item[\tr{-O2-for-C}:] +\index{-O2-for-C option} +Says to run GCC with \tr{-O2}, which may be worth a few percent in +execution speed. Don't forget \tr{-fvia-C}, lest you use the +native-code generator and bypass GCC altogether! + +\item[\tr{-Onot}:] +\index{-Onot option} +\index{optimising, reset} +This option will make GHC ``forget'' any -Oish options it has seen +so far. Sometimes useful; for example: \tr{make all EXTRA_HC_OPTS=-Onot}. + +\item[\tr{-Ofile }:] +\index{-Ofile option} +\index{optimising, customised} +For those who need {\em absolute} control over {\em exactly} what +options are used (e.g., compiler writers, sometimes :-), a list of +options can be put in a file and then slurped in with \tr{-Ofile}. + +In that file, comments are of the \tr{#}-to-end-of-line variety; blank +lines and most whitespace is ignored. + +Please ask if you are baffled and would like an example of \tr{-Ofile}! +\end{description} + +At Glasgow, we don't use a \tr{-O*} flag for day-to-day work. We use +\tr{-O} to get respectable speed; e.g., when we want to measure +something. When we want to go for broke, we tend to use +\tr{-O -fvia-C -O2-for-C} (and we go for lots of coffee breaks). + +%Here is a table to summarise whether pragmatic interface information +%is used or not, whether the native-code generator is used (if +%available), and whether we use GCC register tricks (for speed!) on the +%generated C code: +% +%\begin{tabular}{lccl} +%\tr{-O*} & Interface & Native code & `Registerised' C \\ +% & pragmas? & (if avail.) & (if avail.) \\ \hline +%% +%\pl{} & no & yes & yes, only if \tr{-fvia-C} \\ +%\tr{-O,-O1} & yes & yes & yes, only if \tr{-fvia-C} \\ +%\tr{-O2} & yes & no & yes \\ +%\tr{-Ofile} & yes & yes & yes, only if \tr{-fvia-C} \\ +%\end{tabular} + +The easiest way to see what \tr{-O} (etc) ``really mean'' is to run +with \tr{-v}, then stand back in amazement. +Alternatively, just look at the +\tr{@HsC_minus} lists in the \tr{ghc} driver script. + +%---------------------------------------------------------------------- +\subsubsection{\tr{-f*}: platform-independent flags} +\index{-f* options (GHC)} +\index{-fno-* options (GHC)} + +Flags can be turned {\em off} individually. (NB: I hope +you have a good reason for doing this....) To turn off the \tr{-ffoo} +flag, just use the \tr{-fno-foo} flag.\index{-fno- anti-option} +So, for example, you can say +\tr{-O2 -fno-strictness}, which will then drop out any running of the +strictness analyser. + +The options you are most likely to want to turn off are: +\tr{-fno-update-analysis}\index{-fno-update-analysis option} [because +it is sometimes slow], +\tr{-fno-strictness}\index{-fno-strictness option} (strictness +analyser [because it is sometimes slow]), +\tr{-fno-specialise}\index{-fno-specialise option} (automatic +specialisation of overloaded functions [because it makes your code +bigger]) [US spelling also accepted], +and +\tr{-fno-foldr-build}\index{-fno-foldr-build option} [because no-one +knows what Andy Gill made it do]. + +Should you wish to turn individual flags {\em on}, you are advised to +use the \tr{-Ofile} option, described above. Because the order in +which optimisation passes are run is sometimes crucial, it's quite +hard to do with command-line options. + +Here are some ``dangerous'' optimisations you {\em might} want to try: +\begin{description} +%------------------------------------------------------------------ +\item[\tr{-funfolding-creation-threshold}:] +(Default: 30) By raising or lowering this number, you can raise or lower the +amount of pragmatic junk that gets spewed into interface files. +(An unfolding has a ``size'' that reflects the cost in terms of ``code +bloat'' of expanding that unfolding in another module. A bigger +Core expression would be assigned a bigger cost.) + +\item[\tr{-funfolding-use-threshold}:] +(Default: 3) By raising or lowering this number, you can make the +compiler more or less keen to expand unfoldings. + +OK, folks, these magic numbers `30' and `3' are mildly arbitrary; they +are of the ``seem to be OK'' variety. The `3' is the more critical +one; it's what determines how eager GHC is about expanding unfoldings. + +\item[\tr{-funfolding-override-threshold}:] +(Default: 8) [Pretty obscure] +When deciding what unfoldings from a module should be made available +to the rest of the world (via this module's interface), the compiler +normally likes ``small'' expressions. + +For example, if it sees \tr{foo = bar}, it will decide that the very +small expression \tr{bar} is a great unfolding for \tr{foo}. But if +\tr{bar} turns out to be \tr{(True,False,True)}, we would probably +prefer {\em that} for the unfolding for \tr{foo}. + +Should we ``override'' the initial small unfolding from \tr{foo=bar} +with the bigger-but-better one? Yes, if the bigger one's ``size'' is +still under the ``override threshold.'' You can use this flag to +adjust this threshold (why, I'm not sure). + +\item[\tr{-fliberated-case-threshold}:] +(Default: 12) [Vastly obscure: NOT IMPLEMENTED YET] +``Case liberation'' lifts evaluation out of recursive functions; it +does this by duplicating code. Done without constraint, you can get +serious code bloat; so we only do it if the ``size'' of the duplicated +code is smaller than some ``threshold.'' This flag can fiddle that +threshold. + +\item[\tr{-fsemi-tagging}:] +This option (which {\em does not work} with the native-code generator) +tells the compiler to add extra code to test for already-evaluated +values. You win if you have lots of such values during a run of your +program, you lose otherwise. (And you pay in extra code space.) + +We have not played with \tr{-fsemi-tagging} enough to recommend it. +(For all we know, it doesn't even work in 0.26. Sigh.) +\end{description} + +%---------------------------------------------------------------------- +% \subsubsection[optimise-simplifier]{Controlling ``simplification'' in the Haskell compiler.} +% +%Almost everyone turns program transformation +% (a.k.a. ``simplification'') on/off via one of the ``packages'' above, +%but you can exert absolute control if you want to. Do a \tr{ghc -v -O ...}, +%and you'll see there are plenty of knobs to turn! +% +%The Core-to-Core and STG-to-STG passes can be run multiple times, and +%in varying orders (though you may live to regret it). The on-or-off +%global flags, however, are simply, well, on or off. +% +%The best way to give an exact list of options is the \tr{-Ofile} +%option, described elsewhere. +% +% [Check out \tr{ghc/compiler/simplCore/SimplCore.lhs} and +%\tr{simplStg/SimplStg.lhs} if you {\em really} want to see every +%possible Core-to-Core and STG-to-STG pass, respectively. The +%on-or-off global flags that effect what happens {\em within} one of +%these passes are defined by the \tr{GlobalSwitch} datatype in +%\tr{compiler/main/CmdLineOpts.lhs}.] + +%---------------------------------------------------------------------- +\subsubsection{\tr{-m*}: platform-specific flags} +\index{-m* options (GHC)} +\index{platform-specific options} +\index{machine-specific options} + +Some flags only make sense for particular target platforms. + +\begin{description} +\item[\tr{-mlong-calls}:] +(HPPA machines)\index{-mlong-calls option (HPPA only)} +Means to pass the like-named option to GCC. Required for Very Big +modules, maybe. (Probably means you're in trouble...) + +\item[\tr{-monly-[432]-regs}:] +(iX86 machines)\index{-monly-N-regs option (iX86 only)} +GHC tries to ``steal'' five registers from GCC, for performance +reasons; it almost always works. However, when GCC is compiling some +modules with five stolen registers, it will crash, probably saying: +\begin{verbatim} +Foo.hc:533: fixed or forbidden register was spilled. +This may be due to a compiler bug or to impossible asm +statements or clauses. +\end{verbatim} +Just give some registers back with \tr{-monly-N-regs}. Try `4' first, +then `3', then `2'. If `2' doesn't work, please report the bug to us. +\end{description} + +%---------------------------------------------------------------------- +\subsubsection[optimise-C-compiler]{Code improvement by the C compiler.} +\index{optimisation by GCC} +\index{GCC optimisation} + +The C~compiler, normally GCC, is run with \tr{-O} turned on. (It has +to be, actually.) + +If you want to run GCC with \tr{-O2}---which may be worth a few +percent in execution speed---you can give a +\tr{-O2-for-C}\index{-O2-for-C option} option. + +%If you are brave or foolish, you might want to omit some checking code +% (e.g., for stack-overflow checks), as sketched in +%\sectionref{omit-checking}. + +%************************************************************************ +%* * +\subsection[options-sanity]{Sanity-checking options} +\index{sanity-checking options} +%* * +%************************************************************************ + +If you would like GHC to check that every top-level value has a type +signature, use the \tr{-fsignatures-required} +option.\index{-fsignatures-required option} + +If you would like to disallow ``name shadowing,'' i.e., an inner-scope +value has the same name as an outer-scope value, then use the +\tr{-fname-shadowing-not-ok} +option.\index{-fname-shadowing-not-ok option} +This option catches typographical errors that turn into hard-to-find +bugs, e.g., in the inadvertent cyclic definition \tr{let x = ... x ... in}. + +Consequently, this option does {\em not} allow cyclic recursive +definitions. + +If you're feeling really paranoid, the \tr{-dcore-lint} +option\index{-dcore-lint option} is a good choice. It turns on +heavyweight intra-pass sanity-checking within GHC. (It checks GHC's +sanity, not yours.) + +%************************************************************************ +%* * +\subsection[options-output]{Re-directing the compilation output(s)} +\index{output-directing options} +%* * +%************************************************************************ + +When compiling a Haskell module, GHC may produce several files of +output (usually two). + +One file is usually an {\em interface file}. If compiling +\tr{bar/Foo.hs}, the interface file would normally be \tr{bar/Foo.hi}. +The interface output may be directed to another file +\tr{bar2/Wurble.iface} with the option +\tr{-ohi bar2/Wurble.iface}\index{-ohi option}. + +To avoid generating an interface file at all, use a \tr{-nohi} +option.\index{-nohi option} + +The compiler does not overwrite an existing \tr{.hi} interface file if +the new one is byte-for-byte the same as the old one; this is friendly to +\tr{make}. When an interface does change, it is often enlightening to +be informed. The \tr{-hi-diffs}\index{-hi-diffs option} option will +make \tr{ghc} run \tr{diff} on the old and new \tr{.hi} files. + +GHC's non-interface output normally goes into a \tr{.hc}, \tr{.o}, +etc., file, depending on the last-run compilation phase. The option +\tr{-o foo}\index{-o option} re-directs the output of that last-run +phase to file \tr{foo}. + +Note: this ``feature'' can be counterintuitive: +\tr{ghc -C -o foo.o foo.hs} will put the intermediate C code in the +file \tr{foo.o}, name notwithstanding! + +EXOTICA: But the \tr{-o} option isn't much use if you have {\em +several} input files... Non-interface output files are normally put +in the same directory as their corresponding input file came from. +You may specify that they be put in another directory using the +\tr{-odir }\index{-odir option} (the ``Oh, dear'' option). +For example: + +\begin{verbatim} +% ghc -c parse/Foo.hs parse/Bar.hs gurgle/Bumble.hs -odir `arch` +\end{verbatim} + +The output files, \tr{Foo.o}, \tr{Bar.o}, and \tr{Bumble.o} would be +put into a subdirectory named after the architecture of the executing +machine (\tr{sun4}, \tr{mips}, etc). The directory must already +exist; it won't be created. + +Note that the \tr{-odir} option does {\em not} affect where the +interface files are put. In the above example, they would still be +put in \tr{parse/Foo.hi}, \tr{parse/Bar.hi}, and +\tr{gurgle/Bumble.hi}. + +MORE EXOTICA: The \tr{-osuf }\index{-osuf option} +will change the \tr{.o} file suffix for object files to whatever +you specify. (We use this in compiling the prelude.) + +Similarly, the \tr{-hisuf }\index{-hisuf option} will +change the \tr{.hi} file suffix for non-system interface files. This +can be useful when you are trying to compile a program several ways, +all in the same directory. The suffix given is used for {\em all} +interfaces files written, {\em and} for all non-system interface files +that your read. + +The \tr{-hisuf}/\tr{-osuf} game is useful if you want to compile a +program with both GHC and HBC (say) in the same directory. Let HBC +use the standard \tr{.hi}/\tr{.o} suffixes; add +\tr{-hisuf _g.hi -osuf _g.o} to your \tr{make} rule for GHC compiling... + +% THIS SHOULD HAPPEN AUTOMAGICALLY: +% If you want to change the suffix looked for on system-supplied +% interface files (notably the \tr{Prelude.hi} file), use the +% \tr{-hisuf-prelude }\index{-hisuf-prelude option} +% option. (This may be useful if you've built GHC in various funny +% ways, and you are running tests in even more funny ways. It happens.) + +FURTHER EXOTICA: If you are doing a normal \tr{.hs}-to-\tr{.o} compilation +but would like to hang onto the intermediate \tr{.hc} C file, just +throw in a \tr{-keep-hc-file-too} option\index{-keep-hc-file-too option}. +If you would like to look at the assembler output, toss in a +\tr{-keep-s-file-too},\index{-keep-hc-file-too option} too. + +SAVING GHC STDERR OUTPUT: Sometimes, you may cause GHC to be rather +chatty on standard error; with \tr{-fshow-import-specs}, for example. +You can instruct GHC to {\em append} this output to a particular log +file with a \tr{-odump }\index{-odump option} option. + +TEMPORARY FILES: If you have trouble because of running out of space +in \tr{/tmp/} (or wherever your installation thinks temporary files +should go), you may use the \tr{-tmpdir }\index{-tmpdir option} +option to specify an alternate directory. For example, \tr{-tmpdir .} +says to put temporary files in the current working directory. + +BETTER IDEA FOR TEMPORARY FILES: Use your \tr{TMPDIR} environment +variable.\index{TMPDIR environment variable} Set it to the name of +the directory where temporary files should be put. GCC and other +programs will honour the \tr{TMPDIR} variable as well. + +EVEN BETTER IDEA: Configure GHC with \tr{--with-tmpdir=} when +you build it, and never worry about \tr{TMPDIR} again. + +%************************************************************************ +%* * +\subsection[options-finding-imports-etc]{For finding interface files, etc.} +\index{interface files, finding them} +\index{finding interface files} +%* * +%************************************************************************ + +In your program, you import a module \tr{Foo} by saying +\tr{import Foo}. GHC goes looking for an interface file, \tr{Foo.hi}. +It has a builtin list of directories (notably including \tr{.}) where +it looks. + +The \tr{-i} option\index{-i option} prepends a +colon-separated list of \tr{dirs} to the ``import directories'' list. + +A plain \tr{-i} resets the ``import directories'' list back to nothing. + +GHC normally imports \tr{PreludeCore.hi} and \tr{Prelude.hi} files for +you. If you'd rather it didn't, then give it a +\tr{-fno-implicit-prelude} option\index{-fno-implicit-prelude option}. +(Sadly, it still has to {\em find} a \tr{PreludeNull_.hi} file; it +just won't feed it into the compiler proper.) You are unlikely to get +very far without a Prelude, but, hey, it's a free country. + +If you are using a system-supplied non-Prelude library (e.g., the HBC +library), just use a \tr{-syslib hbc}\index{-syslib option} +option (for example). The right interface files should then be +available. + +Once a Haskell module has been compiled to C (\tr{.hc} file), you may +wish to specify where GHC tells the C compiler to look for \tr{.h} +files. (Or, if you are using the \tr{-cpp} option\index{-cpp option}, +where it tells the C pre-processor to look...) For this purpose, use +a \tr{-I}\index{-I option} in the usual C-ish way. + +Pragmas: Interface files are normally jammed full of +compiler-produced {\em pragmas}, which record arities, strictness +info, etc. If you think these pragmas are messing you up (or you are +doing some kind of weird experiment), you can tell GHC to ignore them +with the \tr{-fignore-interface-pragmas}\index{-fignore-interface-pragmas option} +option. + +See also \sectionref{options-linker}, which describes how the linker +finds standard Haskell libraries. + +%************************************************************************ +%* * +%\subsection[options-names]{Fiddling with namespaces} +%* * +%************************************************************************ + +%-split-objs and -fglobalise-toplev-names. You don't need them and you +%don't want to know; used for the prelude (ToDo). + +%************************************************************************ +%* * +\subsection[options-CPP]{Related to the C pre-processor} +\index{C pre-processor options} +\index{pre-processor (cpp) options} +%* * +%************************************************************************ + +The C pre-processor \tr{cpp} is run over your Haskell code only if the +\tr{-cpp} option \index{-cpp option} is given. Unless you are +building a large system with significant doses of conditional +compilation, you really shouldn't need it. +\begin{description} +\item[\tr{-D}:] +\index{-D option} +Define macro \tr{} in the usual way. NB: does {\em not} affect +\tr{-D} macros passed to the C~compiler when compiling via C! For +those, use the \tr{-optc-Dfoo} hack... + +\item[\tr{-U}:] +\index{-U option} +Undefine macro \tr{} in the usual way. + +\item[\tr{-I}:] +\index{-I option} +Specify a directory in which to look for \tr{#include} files, in +the usual UNIX/C way. +\end{description} + +The \tr{ghc} driver pre-defines several macros: +\begin{description} +\item[\tr{__HASKELL1__}:] +\index{__HASKELL1__ macro} +If defined to $n$, that means GHC supports the +Haskell language defined in the Haskell report version $1.n$. +Currently 2. + +NB: This macro is set both when pre-processing Haskell source and +when pre-processing generated C (\tr{.hc}) files. + +If you give the \tr{-fhaskell-1.3} flag\index{-fhaskell-1.3 option}, +then \tr{__HASKELL1__} is set to 3. Obviously. + +\item[\tr{__GLASGOW_HASKELL__}:] +\index{__GLASGOW_HASKELL__ macro} +For version $n$ of the GHC system, this will be \tr{#define}d to +$100 \times n$. So, for version~0.26, it is 26. + +This macro is {\em only} set when pre-processing Haskell source. +({\em Not} when pre-processing generated C.) + +With any luck, \tr{__GLASGOW_HASKELL__} will be undefined in all other +implementations that support C-style pre-processing. + +(For reference: the comparable symbols for other systems are: +\tr{__YALE_HASKELL__} for Yale Haskell, \tr{__HBC__} for Chalmers +HBC, and \tr{__GOFER__} for Gofer [I think].) + +\item[\tr{__CONCURRENT_HASKELL__}:] +\index{__CONCURRENT_HASKELL__ macro} +Only defined when \tr{-concurrent} is in use! +This symbol is +defined when pre-processing Haskell (input) and pre-processing C (GHC +output). + +\item[\tr{__PARALLEL_HASKELL__}:] +\index{__PARALLEL_HASKELL__ macro} +Only defined when \tr{-parallel} is in use! This symbol is defined when +pre-processing Haskell (input) and pre-processing C (GHC output). +\end{description} + +Options other than the above can be forced through to the C +pre-processor with the \tr{-opt} flags (see +\sectionref{forcing-options-through}). + +A small word of warning: \tr{-cpp} is not friendly to +``string gaps''.\index{-cpp vs string gaps}\index{string gaps vs -cpp} + + +%************************************************************************ +%* * +\subsection[options-C-compiler]{Options affecting the C compiler (if applicable)} +\index{C compiler options} +\index{GCC options} +%* * +%************************************************************************ + +At the moment, quite a few common C-compiler options are passed on +quietly to the C compilation of Haskell-compiler-generated C files. +THIS MAY CHANGE. Meanwhile, options so sent are: + +\begin{tabular}{ll} +\tr{-Wall} & get all warnings from GCC \\ +\tr{-ansi} & do ANSI C (not K\&R) \\ +\tr{-pedantic} & be so\\ +\tr{-dgcc-lint} & (hack) short for ``make GCC very paranoid''\\ +\end{tabular} +\index{-Wall option (for GCC)} +\index{-ansi option (for GCC)} +\index{-pedantic option (for GCC)} +\index{-dgcc-lint option (GCC paranoia)} + +If you are compiling with lots of \tr{ccalls}, etc., you may need to +tell the C~compiler about some \tr{#include} files. There is no +pretty way to do this, but you can use this hack from the +command-line: +\begin{verbatim} +% ghc -c '-#include ' Xstuff.lhs +\end{verbatim} +\index{-#include option} + +%************************************************************************ +%* * +%\subsection[options-native-code]{Options affecting the native-code generator(s)} +%* * +%************************************************************************ + +%The only option is to select the target architecture. Right now, +%you have only at most one choice: \tr{-fasm-sparc}.\index{-fasm- option} +% +%EXPECT this native-code stuff to change in the future. + +%************************************************************************ +%* * +\subsection[options-linker]{Linking and consistency-checking} +\index{linker options} +\index{ld options} +%* * +%************************************************************************ + +GHC has to link your code with various libraries, possibly including: +user-supplied, GHC-supplied, and system-supplied (\tr{-lm} math +library, for example). + +\begin{description} +\item[\tr{-l}:] +\index{-l option} +Link in a library named \tr{lib.a} which resides somewhere on the +library directories path. + +Because of the sad state of most UNIX linkers, the order of such +options does matter. Thus: \tr{ghc -lbar *.o} is almost certainly +wrong, because it will search \tr{libbar.a} {\em before} it has +collected unresolved symbols from the \tr{*.o} files. +\tr{ghc *.o -lbar} is probably better. + +The linker will of course be informed about some GHC-supplied +libraries automatically; these are: + +\begin{tabular}{ll} +-l equivalent & description \\ \hline + +-lHSrts,-lHSclib & basic runtime libraries \\ +-lHS & standard Prelude library \\ +-lgmp & GNU multi-precision library (for Integers)\\ +\end{tabular} +\index{-lHS library} +\index{-lHSrts library} +\index{-lgmp library} + +\item[\tr{-syslib }:] +\index{-syslib option} + +If you are using an optional GHC-supplied library (e.g., the HBC +library), just use the \tr{-syslib hbc} option, and the correct code +should be linked in. + +Please see \sectionref{syslibs} for information about optional +GHC-supplied libraries. + +\item[\tr{-L}:] +\index{-L option} +Where to find user-supplied libraries... Prepend the directory +\tr{} to the library directories path. + +\item[\tr{-static}:] +\index{-static option} +Tell the linker to avoid shared libraries. + +\item[\tr{-no-link-chk} and \tr{-link-chk}:] +\index{-no-link-chk option} +\index{-link-chk option} +\index{consistency checking of executables} +By default, immediately after linking an executable, GHC verifies that +the pieces that went into it were compiled with compatible flags; a +``consistency check''. +(This is to avoid mysterious failures caused by non-meshing of +incompatibly-compiled programs; e.g., if one \tr{.o} file was compiled +for a parallel machine and the others weren't.) You may turn off this +check with \tr{-no-link-chk}. You can turn it (back) on with +\tr{-link-chk} (the default). +\end{description} + +%************************************************************************ +%* * +\subsection[options-compiler-RTS]{For the compiler's RTS: heap, stack sizes, etc.} +\index{heap-size options (for GHC)} +\index{stack-size options (for GHC)} +%* * +%************************************************************************ + +The compiler is itself a Haskell program, so it has a tweakable +runtime-system (RTS), just like any other Haskell program. + +\begin{description} +\item[\tr{-H} or \tr{-Rmax-heapsize }:] +\index{-H option} +\index{-Rmax-heapsize option} +Don't use more than \tr{} {\em bytes} for heap space. If more +than one of these arguments is given, the largest will be taken. + +A size of zero can be used to reset the heap size downwards. For +example, to run GHC with a heap of 250KB (the default is 6MB), do +\tr{-H0 -H250k}. + +\item[\tr{-K} or \tr{-Rmax-stksize }:] +\index{-K option} +\index{-Rmax-stksize option} +Set the stack space to \tr{} bytes. If you have to set it very +high [a megabyte or two, say], the compiler is probably looping, which +is a BUG (please report). + +A size of zero can be used to rest the stack size downwards, as above. + +\item[\tr{-Rscale-sizes}:] +\index{-Rscale-sizes option} +Multiply the given (or default) heap and stack sizes by \tr{}. +For example, on a DEC Alpha (a 64-bit machine), you might want to +double those space sizes; just use \tr{-Rscale-sizes2}. + +A non-integral factor is OK, too: \tr{-Rscale-sizes1.2}. + +\item[\tr{-Rghc-timing}:] +\index{-Rghc-timing option} +Reports a one-line useful collection of time- and space- statistics +for a module's compilation. + +\item[\tr{-Rgc-stats}:] +\index{-Rgc-stats option} +Report garbage-collection statistics. It will create a +\tr{.stat} file, in some obvious place (I hope). + +Alternatively, if you'd rather the GC stats went straight to standard +error, you can ``cheat'' by using, instead: \tr{-optCrts-Sstderr}. + +\item[\tr{-Rhbc}:] +\index{-Rhbc option} +Tell the compiler it has an HBC-style RTS; i.e., it was compiled with +HBC. Not used in Real Life. + +\item[\tr{-Rghc}:] +\index{-Rghc option} +Tell the compiler it has a GHC-style RTS; i.e., it was compiled with +GHC. Not used in Real Life. +\end{description} + +For all \tr{}s: If the last character of \tr{size} is a K, +multiply by 1000; if an M, by 1,000,000; if a G, by 1,000,000,000. +Sizes are always in {\em bytes}, not words. Good luck on the G's (I +think the counter is still only 32-bits [WDP])! + +%************************************************************************ +%* * +%\subsection[options-cross-compiling]{For cross-compiling to another architecture} +%* * +%************************************************************************ +% +% (We do this for GRIP at Glasgow; it's hacked in---not proper +%cross-compiling support. But you could do the same, if required...) +% +%The \tr{-target } option\index{-target option} says to +%generate code for the \tr{} architecture. + +%************************************************************************ +%* * +\subsection[options-parallel]{For Concurrent and Parallel Haskell} +%* * +%************************************************************************ + +For the full story on using GHC for concurrent \& parallel Haskell +programming, please see \Sectionref{concurrent-and-parallel}. + +%The \tr{-fparallel} option\index{-fparallel option} tells the compiler +%to generate code for parallel execution. The \tr{-mgrip} +%option\index{-mgrip option} says that the code should be explicitly +%suitable for the GRIP multiprocessor (the one in our Glasgow basement). + +%************************************************************************ +%* * +\subsection[options-experimental]{For experimental purposes} +\index{experimental options} +%* * +%************************************************************************ + +From time to time, we provide GHC options for ``experimenting.'' Easy +come, easy go. In version~0.26, the ``experimental'' options are: +\begin{description} +\item[\tr{-firrefutable-tuples} option:] +\index{-firrefutable-tuples option (experimental)} +Pretend that every tuple pattern is irrefutable; i.e., has a +``twiddle'' (\tr{~}) in front of it. + +Some parts of the GHC system {\em depend} on strictness properties which +\tr{-firrefutable-tuples} may undo, notably the low-level state-transformer +stuff, which includes I/O (!). You're on your own... + +\item[\tr{-fall-strict} option:] +\index{-fall-strict option (experimental)} +(DOESN'T REALLY WORK, I THINK) Changes the strictness analyser so +that, when it asks the question ``Is this function argument certain to +be evaluated?'', the answer is always ``yes''. + +Compilation is changed in no other way. +\end{description} +% -firrefutable-everything +% -fall-demanded + +%************************************************************************ +%* * +\subsection[options-debugging]{For debugging the compiler} +\index{debugging options (for GHC)} +%* * +%************************************************************************ + +HACKER TERRITORY. HACKER TERRITORY. +(You were warned.) + +%---------------------------------------------------------------------- +\subsubsection[replacing-phases]{Replacing the program for one or more phases.} +\index{GHC phases, changing} +\index{phases, changing GHC} + +You may specify that a different program +be used for one of the phases of the compilation system, in place of +whatever the driver \tr{ghc} has wired into it. For example, you +might want to test a replacement parser. The +\tr{-pgm}\index{-pgm option} option to +\tr{ghc} will cause it to use \pl{} for phase +\pl{}, where the codes to indicate the phases are: + +\begin{tabular}{ll} +code & phase \\ \hline +L & literate pre-processor \\ +P & C pre-processor (if -cpp only) \\ +p & parser \\ +C & Haskell compiler \\ +cO & C compiler for `optimised' (normal) compiling \\ +c & C compiler for `unregisterised' compiling \\ +a & assembler \\ +l & linker \\ +\end{tabular} + +If you use the ambiguous \tr{-pgmcOle}, it will take it to mean +``use program \tr{le} for optimised C compiling.'' + +%---------------------------------------------------------------------- +\subsubsection[forcing-options-through]{Forcing options to a particular phase.} +\index{forcing GHC-phase options} + +The preceding sections describe driver options that are mostly +applicable to one particular phase. You may also {\em force} a +specific option \tr{